(**********************  TD n°6  ***************************)
(*Benjamin Bracquier et Lilian Soler*)
(* Ce TD porte sur la sémantique naturelle codée en Coq    *)
(* du petit langage impératif WHILE déjà vu précédemment.  *)
(* On va l'utiliser pour faire des dérivations, montrer    *)
(* des propriétés, étudier des extensions.                 *)
(***********************************************************)

(* On importe les bibliothèques de Coq utiles pour le TD   *)

Require Import Bool Arith List.
Import List.ListNotations.

(** * On choisit de définir ici un état comme une liste d'entiers naturels.
      On utilise ici le type list de la bibliothèque standard de Coq.
      Ce type est polymorphe. On le spécialise pour des éléments de type nat. *)

Check list.
Check list nat.

Print list.

Check 0::1::3::nil.

(* Ici on observe que la notation des listes façon ocaml est gérée par Coq. *)

Check [0;1;3].

Remark List_Notation: [0;1;3] = 0::1::3::nil.
Proof.
  (* complétez ici NIVEAU 1 *)
  reflexivity .
  Qed.

(** * On reprend ici les AST définis aux séances précédentes *)

(** ** Syntaxe des expressions arithétiques *)

Inductive aexp :=
| Aco : nat -> aexp (* constantes *)
| Ava : nat -> aexp (* variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

(** ** Syntaxe des expressions booléennes *)

Inductive bexp :=
| Btrue : bexp
| Bfalse : bexp
| Bnot : bexp -> bexp
| Band : bexp -> bexp -> bexp
| Bor : bexp -> bexp -> bexp
| Beq : bexp -> bexp -> bexp (* test égalité de bexp *)
| Beqnat : aexp -> aexp -> bexp (* test égalité d'aexp *)
.

(** ** Syntaxe du langage impératif WHILE *)

Inductive winstr :=
| Skip   : winstr
| Assign : nat -> aexp -> winstr
| Seq    : winstr -> winstr -> winstr
| If     : bexp -> winstr -> winstr -> winstr
| While  : bexp -> winstr -> winstr
.

(** ** Quelques listes/états pour faire des tests *)
(** Ci-dessous, S1 est un état dans lequel la variable numéro 0
    vaut 1, la variable numéro 1 vaut 2, et toutes les autres
    valent 0' (valeur par défaut).                                      *)
(** Plus généralement, une variable (Ava i) étant représentée par le
    numéro i, sa valeur dans un état S est la valeur en ieme position
    de la liste qui représente cet état S. *)

Definition state := list nat.

Definition S1 := [1; 2].
Definition S2 := [0; 3].
Definition S3 := [0; 7; 5; 41].

(** * Sémantique *)
(** On reprend les sémantiques fonctionnelles
    des expressions artihmétiques et booléennes      *)

(** La fonction get x s rend la valeur de x dans s. *)
(** Elle rend 0 par défaut, par exemple si la variable
    n'est pas définie/initialisée    *)

Fixpoint get (x:nat) (s:state) : nat :=
match x,s with
| 0   , v::_      => v
| S x1, _::l1 => get x1 l1
| _   , _         => 0
end.

(** Exemples *)

Compute (get 0 S3).
Compute (get 1 S3).
Compute (get 2 S3).
Compute (get 3 S3).
Compute (get 4 S3).

(** La mise à jour d'une variable v par un nouvel entier n dans un état s
    s'écrit 'update s v n'
    Cette fonction n'échoue jamais et écrit la valeur à sa place même
    si elle n'est pas encore définie dans l'état *)

Fixpoint update (s:state) (v:nat) (n:nat): state :=
  match v,s with
  | 0   , a :: l1 => n :: l1
  | 0   , nil     => n :: nil
  | S v1, a :: l1 => a :: (update l1 v1 n)
  | S v1, nil     => 0 :: (update nil v1 n)
  end.

Definition S4 := update (update (update (update (update S1 4 1) 3 2) 2 3) 1 4) 0 5.

Compute S1.
Compute S4.

(** ** Sémantique fonctionnelle de aexp*)
Fixpoint evalA (a: aexp) (s: state) : nat :=
  match a with
  | Aco n => n
  | Ava x => get x s
  | Apl a1 a2 =>  evalA a1 s + evalA a2 s
  | Amu a1 a2 =>  evalA a1 s * evalA a2 s
  | Amo a1 a2 =>  evalA a1 s - evalA a2 s
  end.

(** ** Sémantique fonctionnelle de Baexp*)

Definition eqboolb b1 b2 : bool :=
  match b1, b2  with
  | true , true  => true
  | false, false => true
  | _    , _     => false
  end.

Fixpoint eqnatb n1 n2 : bool :=
  match n1, n2 with
  | O    , O     => true
  | S n1', S n2' => eqnatb n1' n2'
  | _    , _     => false
  end.

Fixpoint evalB (b : bexp) (s : state) : bool :=
  match b with
  | Btrue => true
  | Bfalse => false
  | Bnot b => negb (evalB b s)
  | Band e1 e2 => (evalB e1 s) && (evalB e2 s)
  | Bor e1 e2 => (evalB e1 s) || (evalB e2 s)
  | Beq e1 e2 => eqboolb (evalB e1 s) (evalB e2 s)
  | Beqnat n1 n2 => eqnatb (evalA n1 s) (evalA n2 s)
  end.

(** Pour définir plus facilement des expressions de test on prédéfinit
    des constantes entières ... *)

Definition N0 := Aco 0.
Definition N1 := Aco 1.
Definition N2 := Aco 2.
Definition N3 := Aco 3.
Definition N4 := Aco 4.

(** ...  et des variables *)

Definition X := Ava 1.
Definition Y := Ava 2.
Definition Z := Ava 3.

(** Quelques expressions arithmétiques pour tester *)

(** exp1 = x + 3 *)
Definition E1 := Apl X N3.

(** exp2 = y - 1 *)
Definition E2 := Amo Y N1.

(** exp3 = (x + y) * 2 *)
Definition E3 := Amu (Apl X Y) N2.

Compute (evalA E1 S1).
Compute (evalA E1 S2).
Compute (evalA E2 S1).
Compute (evalA E2 S2).
Compute (evalA E3 S1).
Compute (evalA E3 S2).

(** Quelques expressions booléennes pour tester *)

(** B1 :=  exp1 = 4 *)
Definition B1 := Beqnat E1 N4.

(** B2 := not ( bexp1 /\ (exp1 = 7) *)
Definition B2 := Bnot (Band B1 (Beqnat X N2)).

Compute (evalB B1 S1).
Compute (evalB B1 S2).
Compute (evalB B2 S1).
Compute (evalB B2 S2).

(** Corrigé du travail effectué en TD5 *)

Fail Fixpoint evalW (i : winstr) (s : state) {struct i} : state :=
  match i with
  | Skip       => s
  | Assign x e => update s x (evalA e s)
  | Seq i1 i2  => let s1 := evalW i1 s in evalW i2 s1
               (*   (evalW i2 (evalW i1 s) *)
  | If e i1 i2 => match evalB e s with
                  | true  => evalW i1 s
                  | false => evalW i2 s
                  end
  | (While e i1) as i => match evalB e s with
                  | true  =>
                    let s1 := evalW i1 s in evalW (While e i1) s1
               (*   let s1 := evalW i1 s in evalW i s1                *)
                  | false => s
                  end
  end.

(** ** Version relationnelle, appelée "sémantique naturelle" *)

(** Vu dans le CM précédent.
    La sémantique naturelle (ou sémantique opérationnelle à grands pas)
    du langage WHILE est donnée sous la forme d'un prédicat inductif. *)

Inductive SN: winstr -> state -> state -> Prop :=
| SN_Skip        : forall s,
                   SN Skip s s
| SN_Assign      : forall x a s,
                   SN (Assign x a) s (update s x (evalA a s))
| SN_Seq         : forall i1 i2 s s1 s2,
                   SN i1 s s1 -> SN i2 s1 s2 -> SN (Seq i1 i2) s s2
| SN_If_true     : forall b i1 i2 s s1,
                   (evalB b s = true)  ->  SN i1 s s1 -> SN (If b i1 i2) s s1
| SN_If_false    : forall b i1 i2 s s2,
                   (evalB b s = false) ->  SN i2 s s2 -> SN (If b i1 i2) s s2
| SN_While_false : forall b i s,
                   (evalB b s = false) ->  SN (While b i) s s
| SN_While_true  : forall b i s s1 s2,
                   (evalB b s = true)  ->  SN i s s1 -> SN (While b i) s1 s2 ->
                   SN (While b i) s s2
.

(** On code dans WHILE un programme P1 correspondant à
    while not (i=0) do {i:=i-1;x:=1+x} *)
Definition Il := 0.
Definition Ir := Ava Il.
Definition Xl := 1.
Definition Xr := Ava Xl.

Definition corps_boucle := Seq (Assign Il (Amo Ir N1)) (Assign Xl (Apl N1 Xr)).
Definition P1 := While (Bnot (Beqnat Ir N0)) corps_boucle.

(** On montre que P1 transforme l'état S1 en l'état S2  *)

Theorem reduction1 : SN P1 S1 S2.
(** Regarder les états courants tout au long de la preuve *)
Proof.
  cbv [P1]. cbv [S1]. cbv [S2].
  (** Ou de façon équivalente :
  unfold P1. unfold S1. unfold S2. *)

  (** Ce but devrait être prouvé par l'une des deux dernières règles de SN,
      qui portent sur le cas While.
      On peut deviner laquelle de tête, ou demander de l'aide ainsi : *)
  Compute (evalB (Bnot (Beqnat Ir N0)) [1; 2]).
  (** Ce sera donc avec SN_While_true.
      On peut essayer d'avancer avec 'apply SN_While_true.'  ... mais ça échoue.
      Ici Coq ne peut pas deviner ce que sera l'état intermédiaire s1. *)
  Fail apply SN_While_true.
  (** Une stratégie possible serait d'indiquer directement l'état
      intermédiaire avec la variante 'apply ... with (s1:= ...)'.
      Il faut deviner les paramètres corrects ce qui n'est pas toujours facile.
      Dans notre cas cela serait : *)
  apply SN_While_true with (s1:=[0;3]).
  (** On va donc proposer une autre stratégie· *)
  Undo 1.
  (** Une première possibilité est avec refine, déjà connu :
      ici on indique un joker '_' pour chacun des HUIT arguments ;
      [b], [i], [s] et [s2] se trouvent déterminés par la forme du but,
      [s1] sera déterminé par la preuve de [SN s i s s1] et ne donne donc
      pas lieu à un sous-but. Il restera à prouver :
      [evalB b s = true], [SN i s s1] et [SN (While b i) s1 s2].  *)
  refine (SN_While_true _ _ _ _ _ _ _ _).
  (** On obtient le même effet avec la tactique [eapply], plus commode. *)
  Undo 1.
  eapply SN_While_true.
  - reflexivity.
  - cbv [corps_boucle].
    (** Un nouvel état intermédiaire est à deviner *)
    eapply SN_Seq.
    + apply SN_Assign.
    (* En appliquant cette règle nous avons fixé la valeur de l'état d'arrivée *)
    + (* L'état de départ vient du cas précédent ;
         comme les états sont connus on peut simplifier. *)
      cbn [evalA Ir Il N1 get minus update].
      (** Ou, plus rapidement *)
      Undo 1.
      cbn.
      apply SN_Assign.
  - cbn.
    (** SN_While_true ou SN_While_false ? *)
    Compute (evalB (Bnot (Beqnat Ir N0)) [0; 3]).
    apply SN_While_false.
    cbn.
    reflexivity.
Qed.

(** À FAIRE (NIVEAU 1) : présenter reduction1 sous forme d'arbre *)
Definition AFAIRE_dessin_reduction1 : unit.
Admitted.
(*vu en cours*)
(** Une autre présentation de ce script, structurée par accolades.
    Cela permet de gérer l'indentation autrement
    (surtout utile quand le corps de boucle s'exécute plusieurs fois. *)
Theorem reduction1_accolades : SN P1 S1 S2.
Proof.
  cbv [P1]. cbv [S1]. cbv [S2].
  eapply SN_While_true.
  { cbn. reflexivity. }
  { cbv [corps_boucle].
    eapply SN_Seq.
    + apply SN_Assign.
    + cbn. apply SN_Assign. }
  cbn.
  Compute (evalB (Bnot (Beqnat Ir N0)) [0; 3]).
  apply SN_While_false.
  cbn. reflexivity.
Qed.

(** Exercice d'entraînement *)

Theorem entrainement_P1 : SN P1 [2; 5] [0; 7].
Proof.
  (* complétez ici NIVEAU 1 *)
cbv[P1].
eapply SN_While_true.
{ cbn. reflexivity. }
{ cbv [corps_boucle].
  eapply SN_Seq.
+ apply SN_Assign.
+ cbn. apply SN_Assign.}
cbn.
eapply SN_While_true.
{ cbn. reflexivity. }
{ cbv [corps_boucle].
  eapply SN_Seq.
+ apply SN_Assign.
+ cbn. apply SN_Assign.}
cbn.
apply SN_While_false.
cbn.  reflexivity.
Qed.

(** On veut montrer maintenant que P1 rend toujours un état où
    i vaut 0 et x voit sa valeur augmenter de la valeur initiale de i. *)

(** Rappel : En Coq les entiers naturels sont définis par un type inductif
    comprenant les constructeurs O pour zéro et S pour le successeur. *)

Print nat.

(** Les lemmes suivants de la bibliothèque Coq peuvent être utiles
    - Lemma minus_n_O : forall n, n = n - 0.
    - Lemma plus_n_Sm : forall n m, S (n + m) = n + S m. *)

Theorem reduction2 : forall x y, SN P1 [x;y] [0;x+y].
Proof.
  cbv[P1 Ir Il N1 Xr Xl]; intros x.
  induction x as [ | x Hrec_x];
    intros; cbn [evalA];cbn [evalB].
  (** complétez ici NIVEAU 2 *)
  -apply SN_While_false.
   cbn . reflexivity.
  -eapply SN_While_true.
Admitted.

   (** *** Calcul du carré avec des additions *)
(** On code dans While un programme Pcarre correspondant à
    while not (i=n) do {i:= 1+i; x:= y+x ; y:= 2+y} *)
(* (* *déjà définis *)
Definition Il := 0.
Definition Ir := Ava Il.
Definition Xl := 1.
Definition Xr := Ava Xl.*)
Definition Yl := 2.
Definition Yr := Ava Yl.

Definition incrI := Assign Il (Apl N1 Ir).
Definition incrX := Assign Xl (Apl Yr Xr).
Definition incrY := Assign Yl (Apl N2 Yr).
Definition corps_carre := Seq incrI (Seq incrX incrY).
Definition Pcarre_2 := While (Bnot (Beqnat Ir (Aco 2))) corps_carre.
Definition Pcarre n := While (Bnot (Beqnat Ir (Aco n))) corps_carre.

Theorem reduction_Pcarre_2 : SN (Pcarre_2) [0;0;1] [2;4;5].
Proof.
  (* complétez ici NIVEAU 1 *)
cbv[Pcarre_2].
eapply SN_While_true.
{ cbn. reflexivity.}
{ cbv [corps_carre].
  eapply SN_Seq.
  + apply SN_Assign.
  + cbn. eapply SN_Seq.
 -apply SN_Assign.
 -cbn. apply SN_Assign. }
 cbn. eapply SN_While_true.
{ cbn. reflexivity . }
{ cbv [corps_carre].
  eapply SN_Seq.
 +apply SN_Assign.
 +cbn. eapply SN_Seq .
 - apply SN_Assign .
 -cbn. apply SN_Assign. }
 cbn. apply SN_While_false.
cbn. reflexivity.
Qed.
(** Énoncer et démontrer que Pcarre n permet de calculer le carré de n *)
(* Complétez ici NIVEAU 4
   (pas de technique nouvelle, mais demande de la créativité *)

(** Sur le même modèle, trouver un programme Pcube n'utilisant que des
    additions, énoncer et démontrer qu'il est correct. *)
(* Complétez ici NIVEAU 6
   (pas de technique nouvelle, mais demande de la créativité *)

(* -------------------------------------------------------------------------- *)
(** ** Preuve par récurrence structurelle dans un prédicat inductif *)

(** Transformation simple de programme :
   -  if true  then X else Y ---> X
   -  if false then X else Y ---> Y  *)
Fixpoint simpl_test_Btrue_Bfalse (i: winstr) : winstr :=
  match i with
  | Skip => Skip
  | Assign v a => i
  | Seq w1 w2 => Seq (simpl_test_Btrue_Bfalse w1)
                     (simpl_test_Btrue_Bfalse w2)
  | If Btrue i1 i2 => simpl_test_Btrue_Bfalse i1
  | If Bfalse i1 i2 =>
    (* complétez ici NIVEAU 1 *)
end.
(** Comme indiqué ci-dessus on va procéder par récurrence structurelle sur
     les arbres de preuve de [SN i s s'] *)
Theorem simpl_test_Btrue_Bfalse_correct :
  forall i s s', SN i s s' -> SN (simpl_test_Btrue_Bfalse i) s s'.
Proof.
  (** On essaie d'abord une récurrence sur i.
      Même avec prudence, de la façon la plus générale possible
      (les états [s] et [s'], ainsi que l'hypothèse [SN i s s'] sont
      introduits APRÈS [induction i]), on verra que les buts ne sont
      pas comme souhaité *)
  intro i.
  induction i as [ | | | | ]; (** sans nommer les composantes pour alléger *)
    intros s s' sn (** les introductions sont effectuées systématiquement
                         sur chaque sous-but *).
  (** On observe que l'hypothèse [sn] devrait entraîner [s = s'],
      mais on ne l'a pas obtenu directement ;
      tous les autres sous-buts souffrent de problèmes analogues. *)
  Undo 2.
  (** Il est bien plus opportun de raisonner par récurrence sur [sn] car
      on aura naturellement non seulement la décomposition de [i] mais en plus
      les contraintes dictées par la définition de SN *)
  intros i s s' sn.
  induction sn as  [ (* SN_Skip *) s
                   | (* SN_Assign *) x s a
                   | (* SN_Seq *) i1 i2 s s1 s' sn1 hrec_sn1 sn2 hrec_sn2
                   | (* SN_If_true *) cond i1 i2 s s' e sn hrec_sn
                   | (* SN_If_false *) cond i1 i2 s s' e sn hrec_sn
                   | (* SN_While_false *) (* complétez ici NIVEAU 1 *)
                   | (* SN_While_true *) (* complétez ici NIVEAU 1 *)
                   ]; cbn [simpl_test_Btrue_Bfalse].

 (** La preuve qui suit est un peu fastidieuse, on verra plus tard
     des moyens de la fabriquer plus intelligemment. *)
 (** Certains buts contiendront en une hypothèse se convertissant en
     [false = true] (plus visible en utilisant [cbn in ...].
     On pourra se souvenir d'une technique vue auparavant (égalités contagieuses).
  *)
(** complétez ici
     - nombreux sous-buts NIVEAU 2
     - quelques sous-buts NIVEAU 3, utiliser admit si besoin *)
Admitted.

(* -------------------------------------------------------------------------- *)
(** Une autre transformation simple (facultatif, pour l'entraînement)
  -  if (Bnot b) then X else Y ---> if b then Y else X  *)

Fixpoint simpl_test_echange (i: winstr) : winstr.
  (** complétez ici NIVEAU 1 *)
Admitted.

Lemma negb_negb : forall b, b = negb (negb b).
Proof.
  (** complétez ici NIVEAU 1 *)
Admitted.

Lemma Bnot_negb : forall {B s b}, evalB (Bnot B) s = b -> evalB B s = negb b.
Proof.
 (** complétez ici NIVEAU 1 *)
Admitted.

(** Suivre le même principe que pour simpl_test_Btrue_Bfalse_correct. *)
Theorem simpl_test_echange_correct :
  forall i s s', SN i s s' -> SN (simpl_test_echange i) s s'.
Proof.
  (** complétez ici
     - nombreux sous-buts NIVEAU 2
     - quelques sous-buts NIVEAU 3, utiliser admit si besoin *)
Admitted.

(* -------------------------------------------------------------------------- *)
(** ** Interlude sur l'inversion *)

(** Dans l'exercice qui suit, on aura un but comprenant
    une hypothèse de la forme [SN i s s2],
    où [i] est lui-même de la forme [Seq i1 i2]    (1).
    Sans la condition (1), il serait naturel de procéder par
    cas sur [i], ce qui donnerait lieu aux 7 cas ;
    mais avec la condition (1), on voit que seul un cas
    est pertinent, correpondant à SN_Seq.
    Cette technique de preuve est dite "par inversion".
    On va se ramener à une situation plus simple au moyen du
    prédicat auxiliaire suivant, qui isole le cas intéressant de SN.
 *)

Inductive SN1_Seq i1 i2 s s2 : Prop :=
| SN1_Seq_intro : forall s1,
                  SN i1 s s1 -> SN i2 s1 s2 -> SN1_Seq i1 i2 s s2
.

(** On peut alors démontrer la conséquence suivante d'une hypothèse
    respectant la condition (1) ci-dessus *)

Lemma inv_Seq' : forall {i1 i2 s s2}, SN (Seq i1 i2) s s2 -> SN1_Seq i1 i2 s s2.
Proof.
  intros i1 i2 s s2 sn.
  (** Ici in utilise une tactique magique de Coq. *)
  inversion sn.
  (** Puis une autre, pour nettoyer les égalités. *)
  subst.
  apply (SN1_Seq_intro _ _ _ _ _ H1 H4).
Qed.

(** Mode d'emploi. Devant ce but :

 H18 : SN (Seq i1 i2) s s2
 =========================
 conclusion

Au lieu d'un
  destruct H18
qui donne 7 cas, on observe que
[inv_Seq' H18]   est de type   [SN1_Seq i1 i2 s s2]
et donc on peut de manière plus adéquate utiliser
  destruct (inv_Seq' H18) as [s1 sn1 sn2]
qui ne prévoit qu'un cas, celui qui est pertinent.
*)

(** Voici une preuve par "petites inversions" du même théorème,
    qui n'utilise que les connaissances élémentaires déjà acquises,
    en particulier un programme à la "ouf_ouf" (voir coq3_B_A_BA_ouf.v
    dans les supports de CM).
    Il n'est pas indispensable de la comprendre avant de l'utiliser.
    EXERCICES FACULTATIFS :
    1) expliquer le fonctionnement cette preuve.
    2) dans les scripts à suivre, utiliser SN_inv
       au lieu de inv_Seq
       (intérêt : cela pourra être généralisé).
 *)
Inductive SN1_trivial (s s1 : state) : Prop := Triv : SN1_trivial s s1.

Definition dispatch (i: winstr) : state -> state -> Prop :=
  match i with
  | Seq i1 i2 => SN1_Seq i1 i2
  | _ => SN1_trivial
  end.

Definition SN_inv {i s s2} (sn : SN i s s2) : dispatch i s s2 :=
  match sn with
  | SN_Seq i1 i2 s s1 s2 sn1 sn2 =>
    SN1_Seq_intro _ _ _ _ s1 sn1 sn2
  | _ => Triv _ _
  end.

Lemma inv_Seq : forall {i1 i2 s s2}, SN (Seq i1 i2) s s2 -> SN1_Seq i1 i2 s s2.
Proof.
  intros * sn. apply (SN_inv sn).
Qed.

(** *** Illustration *)
(** Une autre manière d'exprimer la sémantique de WHILE ;
    on prouvera que SN et SN' sont équivalentes. *)
Inductive SN': winstr -> state -> state -> Prop :=
| SN'_Skip        : forall s,
                    SN' Skip s s
| SN'_Assign      : forall x a s,
                    SN' (Assign x a) s (update s x (evalA a s))
| SN'_Seq         : forall i1 i2 s s1 s2,
                    SN' i1 s s1 -> SN' i2 s1 s2 -> SN' (Seq i1 i2) s s2
| SN'_If_true     : forall b i1 i2 s s1,
                    (evalB b s = true)  ->  SN' i1 s s1 -> SN' (If b i1 i2) s s1
| SN'_If_false    : forall b i1 i2 s s2,
                    (evalB b s = false) ->  SN' i2 s s2 -> SN' (If b i1 i2) s s2
| SN'_While_false : forall b i s,
                    (evalB b s = false) ->  SN' (While b i) s s
| SN'_While_true  : forall b i s s1,
                    (evalB b s = true)  ->  SN' (Seq i (While b i)) s s1 ->
                    SN' (While b i) s s1
.

(** La direction suivante ne pose pas de nouvelle difficulté *)
Lemma SN_SN' : forall i s s1, SN i s s1 -> SN' i s s1.
Proof.
  intros i s s1 sn.
  induction sn as  [ (* SN_Skip *) s
                   | (* SN_Assign *) x s a
                   | (* SN_Seq *) i1 i2 s s1 s' sn1 hrec_sn1 sn2 hrec_sn2
                   | (* SN_If_true *) cond i1 i2 s s' e sn hrec_sn
                   | (* SN_If_false *) cond i1 i2 s s' e sn hrec_sn
                   | (* SN_While_false *) (* complétez ici NIVEAU 1 *)
                   | (* SN_While_true *)  (* complétez ici NIVEAU 1 *)
                   ].
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - (** Le sous-but le plus intéressant, où les formulations diffèrent entre
        SN' et SN *)
    apply SN'_While_true.
    + admit (** complétez ici NIVEAU 1 *).
    + eapply SN'_Seq.
      -- admit (** complétez ici NIVEAU 2 *).
      -- admit (** complétez ici NIVEAU 2 *).
Admitted.

(** Pour la réciproque le script est semblable SAUF au dernier sous-but,
    qui précisément demande une inversion. *)
Lemma SN'_SN : forall i s s1, SN' i s s1 -> SN i s s1.
Proof.
  intros i s s1 sn'.
  induction sn' as [ (* SN_Skip *) s
                   | (* SN_Assign *) x s a
                   | (* SN_Seq *) i1 i2 s s1 s' sn1 hrec_sn1 sn2 hrec_sn2
                   | (* SN_If_true *) cond i1 i2 s s' e sn hrec_sn
                   | (* SN_If_false *) cond i1 i2 s s' e sn hrec_sn
                   | (* SN_While_false *) cond i s e
                   | (* SN_While_true *)
                     cond i s s' e sn hrec_sn
                   ].
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - admit (** complétez ici NIVEAU 1 *).
  - (** NIVEAU 4 *)
    (** Ici il faut exploiter l'hypothèse
        hrec_sn : SN (Seq i (While cond i)) s s'
        On observe que cette hypothèse est de la forme SN (Seq i1 i2) s s'
        qui est un cas particulier de SN i s s' ;
        cependant un destruct de hrec_sn oublierait que l'on est
        dans ce cas particulier *)
    destruct hrec_sn as [ | | | | | | ].
    + (** Le but obtenu ici correspond au cas où
          [Seq i (While cond i)] serait en même temps [Skip]
          un cas qui est hors propos. *)
      Undo 1.
    Undo 1.
    (** Cela est résolu en utilisant
        conséquence de hrec_sn indiquée par inv_Seq.
        Voir le mode d'emploi indiqué ci-dessus.
     *)
    destruct (inv_Seq hrec_sn) as [s1 sn1 sn2].
    (** On termine en utilisant ici SN_While_true *)
    + eapply SN_While_true.
      -- apply e.
      -- apply sn1.
      -- apply sn2.
Admitted.

(* -------------------------------------------------------------------------- *)
(** ** Le langage REPEAT *)
(** On considère maintenant un langage impératif sans la commande While,
    mais comportant une autre instruction de boucle
                       'repeat i until b
    qui exécute i puis sort si b est vrai, et sinon recommence.
 *)

(** Voici la syntaxe du langage REPEAT
    (on redéfinit un nouveau type avec de nouveaux constructeurs.    *)

Inductive rinstr :=
| RSkip   : rinstr
| RAssign : nat -> aexp -> rinstr
| RSeq    : rinstr -> rinstr -> rinstr
| RIf     : bexp -> rinstr -> rinstr -> rinstr
| Repeat  : rinstr -> bexp -> rinstr.

(** Définir la sémantique naturelle du langage REPEAT *)

Inductive SNr: rinstr -> state -> state -> Prop :=
| SNr_Skip        : forall s,
                    SNr RSkip s s
| SNr_Assign      : forall x e s,
                    SNr (RAssign x e) s (update s x (evalA e s))
| SNr_Seq         : forall i1 i2 s s1 s2,
                    SNr i1 s s1 -> SNr i2 s1 s2 -> SNr (RSeq i1 i2) s s2
| SNr_If_true     : forall b i1 i2 s s1,
                    evalB b s = true -> SNr i1 s s1 -> SNr (RIf b i1 i2) s s1
| SNr_If_false    : forall b i1 i2 s s2,
                    evalB b s = false -> SNr i2 s s2 -> SNr (RIf b i1 i2) s s2
| SNr_Repeat_true : (** complétez ici NIVEAU 2 *)
| SNr_Repeat_false: (** complétez ici NIVEAU 2 *)
.

(** On code dans REPEAT un programme P2 correspondant à
    repeat {i:=i-1;x:=1+x} until i=0 *)

Definition corps_boucleR : rinstr. Admitted.
Definition P2 := Repeat corps_boucleR (Beqnat Ir N0).

Lemma P2_test : SNr P2 [2; 5] [0; 7].
Proof.
Admitted.

(** À FAIRE : présenter P2_test sous forme d'arbre *)
Definition AFAIRE_dessin_P2_test : unit.
Admitted.

(** *** Preuves sur SNr *)
(** On va maintenant montrer que : 'Repeat i until b'
    peut être traduit  par       : 'i; while (not b) do i'     *)

(** Ecrire une fonction qui traduit toute expression rinstr en winstr en
    remplaçant les Repeat par l'expression équivalente ci-dessus
 *)

Fixpoint repeat_while (i:rinstr) : winstr :=
    match i with
    | RSkip        => Skip
    | RAssign v a  => Assign v a
    | RSeq i1 i2   =>
      (** complétez ici NIVEAU 2 *)
    end.

(** Avant d'aborder la preuve suivante, il est recommandé de tester
    sur un petit programme REPEAT qu'après transformation son exécution
    à partir d'un état initial concret donne bien le même état final.
*)

(** Montrer que cette transformation préserve la sémantique c-a-d : *)

Theorem repeat_while_correct : forall i s1 s2, SNr i s1 s2 -> SN (repeat_while i) s1 s2.
Proof.
  intros i s1 s2 sn.
            (* complétez ici NIVEAU 3 *)
Admitted.

(* -------------------------------------------------------------------------- *)
(** Transformation inverse *)
Fixpoint while_repeat (i:winstr) : rinstr :=
    match i with
    | Skip        => RSkip
    | Assign v a  => RAssign v a
    | Seq i1 i2   =>
      (* complétez ici NIVEAU 3 *)
    end.

(** Avant d'aborder la preuve suivante, il est recommandé de tester
    sur un petit programme WHILE qu'après transformation son exécution
    à partir d'un état initial concret donne bien le même état final.
*)

(** Montrer que cette transformation préserve la sémantique *)
(** La preuve suivante requiert quelques techniques supplémentaires,
    à considérer seulement après la semaine 7 *)

Theorem while_repeat_correct :
  forall i s1 s2, SN i s1 s2 -> SNr (while_repeat i) s1 s2.
Proof.
  intros i s_1 s_2 sn.
            (** complétez ici NIVEAU 4 *)
Admitted.

(* -------------------------------------------------------------------------- *)
(** ** Le langage WHILE-REPEAT *)
(** Remarque : on pourrait également considérer un langage WHILE_REPEAT
    comprenant à la fois l'instruction While et l'instruction Repeat
 *)


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros. simpl. rewrite <- append_assoc. simpl.
   rewrite lem. rewrite IHx. rewrite <- append_assoc. reflexivity.
 - intros. simpl. rewrite lem2. rewrite lem3. reflexivity.
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 (y : natural) (lf1 : natural) (x : natural) : natural :=
  plus lf1 (mult x lf1).


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


Require Import Relation_Definitions.

Section Relations.
  Context {T: Type}.
  Variable R: relation T.
  Definition reflexive: Prop := forall a, R a a.
  Definition transitive: Prop := forall a b c, R a b -> R b c -> R a c.
  Definition symmetric: Prop := forall a b, R a b -> R b a.
  Definition equivalence: Prop := reflexive /\ transitive /\ symmetric.
  Definition antisymmetric: Prop := forall a b, R a b -> R b a -> a = b.
  Definition asymmetric: Prop := forall a b, R a b -> ~R b a.
  Definition preorder: Prop := reflexive /\ transitive.
  Definition partial_order: Prop := preorder /\ antisymmetric.

  (* Asymmetry is stronger than antisymmetry. *)
  Theorem asym_implies_antisym: asymmetric -> antisymmetric.
  Proof.
    unfold asymmetric. unfold antisymmetric. unfold not.
    intros asym a b Rab Rba.
    apply asym in Rab. destruct Rab. apply Rba.
  Qed.
End Relations.


Set Implicit Arguments.
Require Import Lists.List.
Import ListNotations.

Check list.

Print rev.

Fixpoint is_sorted A (l : list A) (R : A -> A -> Prop) :=
  match l with
    [] => True
  | x :: xs => match xs with
                [] => True
              | y :: ys => R x y /\ is_sorted xs R
              end
  end.

Theorem warm_up : is_sorted [3;5;9] le.
Proof.
  firstorder.
  (* alternatively: (...)
  simpl.
  split. repeat constructor. (* constructor. constructor. constructor. *)
  repeat constructor.
   (* constructor. constructor. constructor. constructor.
      constructor. constructor. *) *)
Qed.

Lemma is_sorted' : forall A (l : list A) R a b, is_sorted (l ++ [a]) R -> R a b -> is_sorted (l ++ [a; b]) R.
Proof.
  intros.
  induction l.
  - simpl. firstorder.
  - simpl.
    destruct l.
    (* `simpl in *` simplifies the goal and all the premises.
       it is not needed here, but will help you see why `firstorder`
       works. *)
    + simpl in *. firstorder.
      (* alternatively:
      split.
      * apply H.
      * apply IHl. constructor. *)
    + simpl in *. firstorder.
      (* alternatively:
      split.
      * apply H.
      * apply IHl. apply H. *)
Qed.

Theorem rev_sorted : forall l, is_sorted l lt -> is_sorted (rev l) gt.
Proof.
  induction l.
  - intro; simpl. trivial.
  - simpl. induction l.
    + simpl. trivial.
    + simpl. simpl in IHl. firstorder. rewrite <- app_assoc. apply is_sorted'.
      * assumption.
      * assumption.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Supplementary Coq material: subset types
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)

Require Import FrapWithoutSets.
(* We import a pared-down version of the book library, to avoid notations that
 * clash with some we want to use here. *)

Set Implicit Arguments.
Set Asymmetric Patterns.
(* Compatibility flag that affects pattern matching for fancy types *)

(* So far, we have seen many examples of what we might call "classical program
 * verification."  We write programs, write their specifications, and then prove
 * that the programs satisfy their specifications.  The programs that we have
 * written in Coq have been normal functional programs that we could just as
 * well have written in Haskell or ML.  In this lecture, we start investigating
 * uses of _dependent types_ to integrate programming, specification, and
 * proving into a single phase.  The techniques we will learn make it possible
 * to reduce the cost of program verification dramatically. *)

(** * Introducing Subset Types *)

(** Let us consider several ways of implementing the natural-number-predecessor
 * function.  We start by displaying the definition from the standard library: *)

Compute pred.

(* We can use a new command, [Extraction], to produce an OCaml version of this
 * function. *)

Extraction pred.

(* Returning 0 as the predecessor of 0 can come across as somewhat of a hack.
 * In some situations, we might like to be sure that we never try to take the
 * predecessor of 0.  We can enforce this by giving [pred] a stronger, dependent
 * type. *)

Lemma zgtz : 0 > 0 -> False.
Proof.
  linear_arithmetic.
Qed.

Definition pred_strong1 (n : nat) : n > 0 -> nat :=
  match n with
  | O => fun pf : 0 > 0 => match zgtz pf with end
  | S n' => fun _ => n'
  end.

(* We expand the type of [pred] to include a _proof_ that its argument [n] is
 * greater than 0.  When [n] is 0, we use the proof to derive a contradiction,
 * which we can use to build a value of any type via a vacuous pattern match.
 * When [n] is a successor, we have no need for the proof and just return the
 * answer.  The proof argument can be said to have a _dependent_ type, because
 * its type depends on the _value_ of the argument [n].
 *
 * Coq's [Compute] command can execute particular invocations of [pred_strong1]
 * just as easily as it can execute more traditional functional programs. *)

Theorem two_gt0 : 2 > 0.
Proof.
  linear_arithmetic.
Qed.

Compute pred_strong1 two_gt0.

(* One aspect in particular of the definition of [pred_strong1] may be
 * surprising.  We took advantage of [Definition]'s syntactic sugar for defining
 * function arguments in the case of [n], but we bound the proofs later with
 * explicit [fun] expressions.  Let us see what happens if we write this
 * function in the way that at first seems most natural. *)

Fail Definition pred_strong1' (n : nat) (pf : n > 0) : nat :=
  match n with
  | O => match zgtz pf with end
  | S n' => n'
  end.

(* The term [zgtz pf] fails to type-check.  Somehow the type checker has failed
 * to take into account information that follows from which [match] branch that
 * term appears in.  The problem is that, by default, [match] does not let us
 * use such implied information.  To get refined typing, we must always rely on
 * [match] annotations, either written explicitly or inferred.
 *
 * In this case, we must use a [return] annotation to declare the relationship
 * between the _value_ of the [match] discriminee and the _type_ of the result.
 * There is no annotation that lets us declare a relationship between the
 * discriminee and the type of a variable that is already in scope; hence, we
 * delay the binding of [pf], so that we can use the [return] annotation to
 * express the needed relationship.
 *
 * We are lucky that Coq's heuristics infer the [return] clause (specifically,
 * [return n > 0 -> nat]) for us in the definition of [pred_strong1], leading to
 * the following elaborated code: *)

Definition pred_strong1' (n : nat) : n > 0 -> nat :=
  match n return n > 0 -> nat with
  | O => fun pf : 0 > 0 => match zgtz pf with end
  | S n' => fun _ => n'
  end.

(* By making explicit the functional relationship between value [n] and the
 * result type of the [match], we guide Coq toward proper type checking.  The
 * clause for this example follows by simple copying of the original annotation
 * on the definition.  In general, however, the [match] annotation inference
 * problem is undecidable.  The known undecidable problem of
 * _higher-order unification_ reduces to the [match] type inference problem.
 * Over time, Coq is enhanced with more and more heuristics to get around this
 * problem, but there must always exist [match]es whose types Coq cannot infer
 * without annotations.
 *
 * Let us now take a look at the OCaml code Coq generates for [pred_strong1]. *)

Extraction pred_strong1.

(* The proof argument has disappeared!  We get exactly the OCaml code we would
 * have written manually.  This is our first demonstration of the main
 * technically interesting feature of Coq program extraction: proofs are erased
 * systematically.
 *
 * We can reimplement our dependently typed [pred] based on _subset types_,
 * defined in the standard library with the type family [sig]. *)

Print sig.

(* We rewrite [pred_strong1], using some syntactic sugar for subset types, after
 * we deactivate some clashing notations for set literals. *)

Locate "{ _ : _ | _ }".

Definition pred_strong2 (s : {n : nat | n > 0} ) : nat :=
  match s with
  | exist O pf => match zgtz pf with end
  | exist (S n') _ => n'
  end.

(* To build a value of a subset type, we use the [exist] constructor, and the
 * details of how to do that follow from the output of our earlier [Print sig]
 * command, where we elided the extra information that parameter [A] is
 * implicit.  We need an extra [_] here and not in the definition of
 * [pred_strong2] because _parameters_ of inductive types (like the predicate
 * [P] for [sig]) are not mentioned in pattern matching, but _are_ mentioned in
 * construction of terms (if they are not marked as implicit arguments).
 * (Actually, this behavior changed between Coq versions 8.4 and 8.5, hence the
 * command at the top of the file to revert to the old behavior.) *)

Compute pred_strong2 (exist _ 2 two_gt0).

Extraction pred_strong2.

(* We arrive at the same OCaml code as was extracted from [pred_strong1], which
 * may seem surprising at first.  The reason is that a value of [sig] is a pair
 * of two pieces, a value and a proof about it.  Extraction erases the proof,
 * which reduces the constructor [exist] of [sig] to taking just a single
 * argument.  An optimization eliminates uses of datatypes with single
 * constructors taking single arguments, and we arrive back where we started.
 *
 * We can continue on in the process of refining [pred]'s type.  Let us change
 * its result type to capture that the output is really the predecessor of the
 * input. *)

Definition pred_strong3 (s : {n : nat | n > 0}) : {m : nat | proj1_sig s = S m} :=
  match s return {m : nat | proj1_sig s = S m} with
  | exist 0 pf => match zgtz pf with end
  | exist (S n') pf => exist _ n' (eq_refl _)
  end.

Compute pred_strong3 (exist _ 2 two_gt0).

(* A value in a subset type can be thought of as a _dependent pair_ (or
 * _sigma type_) of a base value and a proof about it.  The function [proj1_sig]
 * extracts the first component of the pair.  It turns out that we need to
 * include an explicit [return] clause here, since Coq's heuristics are not
 * smart enough to propagate the result type that we wrote earlier.
 *
 * By now, the reader is probably ready to believe that the new [pred_strong]
 * leads to the same OCaml code as we have seen several times so far, and Coq
 * does not disappoint. *)

Extraction pred_strong3.

(* We have managed to reach a type that is, in a formal sense, the most
 * expressive possible for [pred].  Any other implementation of the same type
 * must have the same input-output behavior.  However, there is still room for
 * improvement in making this kind of code easier to write.  Here is a version
 * that takes advantage of tactic-based theorem proving.  We switch back to
 * passing a separate proof argument instead of using a subset type for the
 * function's input, because this leads to cleaner code.  ([False_rec] is a
 * library function that can be used to produce a value in any type given a
 * proof of [False].  It's defined in terms of the vacuous pattern match we saw
 * earlier.) *)

Definition pred_strong4 : forall (n : nat), n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
    | O => fun _ => False_rec _ _
    | S n' => fun _ => exist _ n' _
    end).

  (* We build [pred_strong4] using tactic-based proving, beginning with a
   * [Definition] command that ends in a period before a definition is given.
   * Such a command enters the interactive proving mode, with the type given for
   * the new identifier as our proof goal.
   *
   * We do most of the work with the [refine] tactic, to which we pass a partial
   * "proof" of the type we are trying to prove.  There may be some pieces left
   * to fill in, indicated by underscores.  Any underscore that Coq cannot
   * reconstruct with type inference is added as a proof subgoal.  In this case,
   * we have two subgoals.
   *
   * We can see that the first subgoal comes from the second underscore passed
   * to [False_rec], and the second subgoal comes from the second underscore
   * passed to [exist].  In the first case, we see that, though we bound the
   * proof variable with an underscore, it is still available in our proof
   * context.  Both subgoals are easy to discharge, so let us back up and ask to
   * prove all subgoals automatically. *)

  Undo.
  refine (fun n =>
    match n with
    | O => fun _ => False_rec _ _
    | S n' => fun _ => exist _ n' _
    end); equality || linear_arithmetic.
Defined.

(* We end the "proof" with [Defined] instead of [Qed], so that the definition we
 * constructed remains visible.  This contrasts to the case of ending a proof
 * with [Qed], where the details of the proof are hidden afterward.  (More
 * formally, [Defined] marks an identifier as _transparent_, allowing it to be
 * unfolded; while [Qed] marks an identifier as _opaque_, preventing unfolding.)
 * Let us see what our proof script constructed. *)

Print pred_strong4.

(* We see the code we entered, with some (pretty long!) proofs filled in. *)

Compute pred_strong4 two_gt0.

(* We are almost done with the ideal implementation of dependent predecessor.
 * We can use Coq's syntax-extension facility to arrive at code with almost no
 * complexity beyond a Haskell or ML program with a complete specification in a
 * comment.  In this book, we will not dwell on the details of syntax
 * extensions; the Coq manual gives a straightforward introduction to them. *)

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

Definition pred_strong5 : forall (n : nat), n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
    | O => fun _ => !
    | S n' => fun _ => [n']
    end); equality || linear_arithmetic.
Defined.

(* By default, notations are also used in pretty-printing terms, including
 * results of evaluation. *)

Compute pred_strong5 two_gt0.

(** * Decidable Proposition Types *)

(* There is another type in the standard library that captures the idea of
 * a program value indicating which of two propositions is true. *)

Print sumbool.

(* We have been using this type family behind the scenes for various equality
 * checks, for instance: *)
Check "x" ==v "y".

(* Here, the constructors of [sumbool] have types written in terms of a
 * registered notation for [sumbool], such that the result type of each
 * constructor desugars to [sumbool A B].  We can define some notations of our
 * own to make working with [sumbool] more convenient. *)

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).

(* The [Reduce] notation is notable because it demonstrates how [if] is
 * overloaded in Coq.  The [if] form actually works when the test expression has
 * any two-constructor inductive type.  Moreover, in the [then] and [else]
 * branches, the appropriate constructor arguments are bound.  This is important
 * when working with [sumbool]s, when we want to have the proof stored in the
 * test expression available when proving the proof obligations generated in the
 * appropriate branch.
 *
 * Now we can write [eq_nat_dec], which compares two natural numbers, returning
 * either a proof of their equality or a proof of their inequality. *)

Definition eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
  refine (fix f (n m : nat) : {n = m} + {n <> m} :=
    match n, m with
    | O, O => Yes
    | S n', S m' => Reduce (f n' m')
    | _, _ => No
    end); equality.
Defined.

Compute eq_nat_dec 2 2.
Compute eq_nat_dec 2 3.

(* Note that the [Yes] and [No] notations are hiding proofs establishing the
 * correctness of the outputs.
 *
 * Our definition extracts to reasonable OCaml code. *)

Extraction eq_nat_dec.

(* Proving this kind of decidable equality result is so common that Coq comes
 * with a tactic for automating it. *)

Definition eq_nat_dec' (n m : nat) : {n = m} + {n <> m}.
  decide equality.
Defined.

(* Curious readers can verify that the [decide equality] version extracts to the
 * same OCaml code as our more manual version does.  That OCaml code had one
 * undesirable property, which is that it uses [Left] and [Right] constructors
 * instead of the Boolean values built into OCaml.  We can fix this, by using
 * Coq's facility for mapping Coq inductive types to OCaml variant types. *)

Extract Inductive sumbool => "bool" ["true" "false"].
Extraction eq_nat_dec'.

(* We can build "smart" versions of the usual Boolean operators and put them to
 * good use in certified programming.  For instance, here is a [sumbool] version
 * of Boolean "or." *)

Notation "x || y" := (if x then Yes else Reduce y).

(* Let us use it for building a function that decides list membership.  We need
 * to assume the existence of an equality decision procedure for the type of
 * list elements. *)

Section In_dec.
  Variable A : Set.
  Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  (* The final function is easy to write using the techniques we have developed
   * so far. *)

  Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~ In x ls}.
    refine (fix f (x : A) (ls : list A) : {In x ls} + {~ In x ls} :=
      match ls with
      | nil => No
      | x' :: ls' => A_eq_dec x x' || f x ls'
      end); simplify; equality.
  Defined.
End In_dec.

Compute In_dec eq_nat_dec 2 [1; 2].
Compute In_dec eq_nat_dec 3 [1; 2].

(* The [In_dec] function has a reasonable extraction to OCaml. *)

Extraction In_dec.

(* This is more or the less code for the corresponding function from the OCaml
 * standard library. *)

(** * Partial Subset Types *)

(* Our final implementation of dependent predecessor used a very specific
 * argument type to ensure that execution could always complete normally.
 * Sometimes we want to allow execution to fail, and we want a more principled
 * way of signaling failure than returning a default value, as [pred] does for
 * [0].  One approach is to define this type family [maybe], which is a version
 * of [sig] that allows obligation-free failure. *)

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

(* We can define some new notations, analogous to those we defined for subset
 * types. *)

Notation "{{ x | P }}" := (maybe (fun x => P)).
Notation "??" := (Unknown _).
Notation "[| x |]" := (Found _ x _).

(* Now our next version of [pred] is trivial to write. *)

Definition pred_strong7 : forall n : nat, {{m | n = S m}}.
  refine (fun n =>
    match n return {{m | n = S m}} with
    | O => ??
    | S n' => [|n'|]
    end); trivial.
Defined.

Compute pred_strong7 2.
Compute pred_strong7 0.

(* Because we used [maybe], one valid implementation of the type we gave
 * [pred_strong7] would return [??] in every case.  We can strengthen the type
 * to rule out such vacuous implementations, and the type family [sumor] from
 * the standard library provides the easiest starting point.  For type [A] and
 * proposition [B], [A + {B}] desugars to [sumor A B], whose values are either
 * values of [A] or proofs of [B]. *)

Print sumor.

(* We add notations for easy use of the [sumor] constructors.  The second
 * notation is specialized to [sumor]s whose [A] parameters are instantiated
 * with regular subset types, since this is how we will use [sumor] below. *)

Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

(* Now we are ready to give the final version of possibly failing predecessor.
 * The [sumor]-based type that we use is maximally expressive; any
 * implementation of the type has the same input-output behavior. *)

Definition pred_strong8 : forall n : nat, {m : nat | n = S m} + {n = 0}.
  refine (fun n =>
    match n with
    | O => !!
    | S n' => [||n'||]
    end); trivial.
Defined.

Compute pred_strong8 2.
Compute pred_strong8 0.

(* As with our other maximally expressive [pred] function, we arrive at quite
 * simple output values, thanks to notations. *)

(** * Monadic Notations *)

(* We can treat [maybe] like a monad, in the same way that the Haskell [Maybe]
 * type is interpreted as a failure monad.  Our [maybe] has the wrong type to be
 * a literal monad, but a "bind"-like notation will still be helpful. *)

Notation "x <- e1 ; e2" := (match e1 with
                            | Unknown => ??
                            | Found x _ => e2
                            end)
(right associativity, at level 60).

(* The meaning of [x <- e1; e2] is: First run [e1].  If it fails to find an
 * answer, then announce failure for our derived computation, too.  If [e1]
 * _does_ find an answer, pass that answer on to [e2] to find the final result.
 * The variable [x] can be considered bound in [e2].
 *
 * This notation is very helpful for composing richly typed procedures.  For
 * instance, here is a very simple implementation of a function to take the
 * predecessors of two naturals at once. *)

Definition doublePred : forall n1 n2 : nat, {{p | n1 = S (fst p) /\ n2 = S (snd p)}}.
  refine (fun n1 n2 =>
    m1 <- pred_strong7 n1;
    m2 <- pred_strong7 n2;
    [|(m1, m2)|]); propositional.
Defined.

(* We can build a [sumor] version of the "bind" notation and use it to write a
 * similarly straightforward version of this function. *)

Notation "x <-- e1 ; e2" := (match e1 with
                             | inright _ => !!
                             | inleft (exist x _) => e2
                             end)
(right associativity, at level 60).

Definition doublePred' : forall n1 n2 : nat,
  {p : nat * nat | n1 = S (fst p) /\ n2 = S (snd p)}
  + {n1 = 0 \/ n2 = 0}.
  refine (fun n1 n2 =>
    m1 <-- pred_strong8 n1;
    m2 <-- pred_strong8 n2;
    [||(m1, m2)||]); propositional.
Defined.

(* This example demonstrates how judicious selection of notations can hide
 * complexities in the rich types of programs. *)

(** * A Type-Checking Example *)

(* We can apply these specification types to build a certified type checker for
 * a simple expression language. *)

Inductive exp :=
| Nat (n : nat)
| Plus (e1 e2 : exp)
| Bool (b : bool)
| And (e1 e2 : exp).

(* We define a simple language of types and its typing rules. *)

Inductive type := TNat | TBool.

Inductive hasType : exp -> type -> Prop :=
| HtNat : forall n,
  hasType (Nat n) TNat
| HtPlus : forall e1 e2,
  hasType e1 TNat
  -> hasType e2 TNat
  -> hasType (Plus e1 e2) TNat
| HtBool : forall b,
  hasType (Bool b) TBool
| HtAnd : forall e1 e2,
  hasType e1 TBool
  -> hasType e2 TBool
  -> hasType (And e1 e2) TBool.

(* It will be helpful to have a function for comparing two types.  We build one
 * using [decide equality]. *)

Definition eq_type_dec : forall t1 t2 : type, {t1 = t2} + {t1 <> t2}.
  decide equality.
Defined.

(* Another notation complements the monadic notation for [maybe] that we defined
 * earlier.  Sometimes we want to include "assertions" in our procedures.  That
 * is, we want to run a decision procedure and fail if it fails; otherwise, we
 * want to continue, with the proof that it produced made available to us.  This
 * infix notation captures that idea, for a procedure that returns an arbitrary
 * two-constructor type. *)

Notation "e1 ;; e2" := (if e1 then e2 else ??)
  (right associativity, at level 60).

(* With that notation defined, we can implement a [typeCheck] function, whose
 * code is only more complex than what we would write in ML because it needs to
 * include some extra type annotations.  Every [[|e|]] expression adds a
 * [hasType] proof obligation, and [eauto] makes short work of them when we add
 * [hasType]'s constructors as hints. *)

Local Hint Constructors hasType : core.

Definition typeCheck : forall e : exp, {{t | hasType e t}}.
  refine (fix F (e : exp) : {{t | hasType e t}} :=
    match e return {{t | hasType e t}} with
    | Nat _ => [|TNat|]
    | Plus e1 e2 =>
      t1 <- F e1;
      t2 <- F e2;
      eq_type_dec t1 TNat;;
      eq_type_dec t2 TNat;;
      [|TNat|]
    | Bool _ => [|TBool|]
    | And e1 e2 =>
      t1 <- F e1;
      t2 <- F e2;
      eq_type_dec t1 TBool;;
      eq_type_dec t2 TBool;;
      [|TBool|]
    end); subst; eauto.
Defined.

(* Despite manipulating proofs, our type checker is easy to run. *)

Compute typeCheck (Nat 0).
Compute typeCheck (Plus (Nat 1) (Nat 2)).
Compute typeCheck (Plus (Nat 1) (Bool false)).

(* The type checker also extracts to some reasonable OCaml code. *)

Extraction typeCheck.

(* We can adapt this implementation to use [sumor], so that we know our type-checker
 * only fails on ill-typed inputs.  First, we define an analogue to the
 * "assertion" notation. *)

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60).

(* Next, we prove a helpful lemma, which states that a given expression can have
 * at most one type. *)

Lemma hasType_det : forall e t1,
  hasType e t1
  -> forall t2, hasType e t2
    -> t1 = t2.
Proof.
  induct 1; invert 1; equality.
Qed.

(* Now we can define the type-checker.  Its type expresses that it only fails on
 * untypable expressions. *)

Local Hint Resolve hasType_det : core.
(* The lemma [hasType_det] will also be useful for proving proof obligations
 * with contradictory contexts. *)

Definition typeCheck' : forall e : exp, {t : type | hasType e t} + {forall t, ~ hasType e t}.
  (* Finally, the implementation of [typeCheck] can be transcribed literally,
   * simply switching notations as needed. *)

  refine (fix F (e : exp) : {t : type | hasType e t} + {forall t, ~ hasType e t} :=
    match e return {t : type | hasType e t} + {forall t, ~ hasType e t} with
      | Nat _ => [||TNat||]
      | Plus e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TNat;;;
        eq_type_dec t2 TNat;;;
        [||TNat||]
      | Bool _ => [||TBool||]
      | And e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TBool;;;
        eq_type_dec t2 TBool;;;
        [||TBool||]
    end); simplify; propositional; subst; eauto;
    match goal with
    | [ H : hasType ?x _ |- _ ] =>
      match goal with
      | [ y : _ |- _ ] =>
        match y with
        | x => fail 2
        end
      | _ => invert2 H
      end
    end; eauto.
Defined.

(* The short implementation here hides just how time-saving automation is.
 * Every use of one of the notations adds a proof obligation, giving us 12 in
 * total.  Most of these obligations require inversions and either uses of
 * [hasType_det] or applications of [hasType] rules.
 *
 * Our new function remains easy to test: *)

Compute typeCheck' (Nat 0).
Compute typeCheck' (Plus (Nat 1) (Nat 2)).
Compute typeCheck' (Plus (Nat 1) (Bool false)).

(* The results of simplifying calls to [typeCheck'] look deceptively similar to
 * the results for [typeCheck], but now the types of the results provide more
 * information. *)


Require Import ZArith Vec3 Algebra Tactics Equal.
Open Scope Z_scope.

Inductive Matrix3x3 : Type :=
| matrix : Vec3 -> Vec3 -> Vec3 -> Matrix3x3.

(* Addition *)

Definition specification_of_add_matrix_3x3 (add : Matrix3x3 ->
                                                  Matrix3x3 ->
                                                  Matrix3x3) :=
  forall v1 v2 v3 w1 w2 w3 : Vec3,
    add (matrix v1 v2 v3) (matrix w1 w2 w3) = matrix (add_vec3 v1 w1)
                                                     (add_vec3 v2 w2)
                                                     (add_vec3 v3 w3).

Theorem specification_of_add_matrix_3x3_is_unique :
  forall add add' : Matrix3x3 -> Matrix3x3 -> Matrix3x3,
    specification_of_add_matrix_3x3 add ->
    specification_of_add_matrix_3x3 add' ->
    forall A B : Matrix3x3,
      add A B = add' A B.
Proof.
  intros add add'.
  unfold specification_of_add_matrix_3x3.
  intros S_add S_add'.
  intros [v1 v2 v3] [w1 w2 w3].
  rewrite -> S_add.
  symmetry.
  exact (S_add' v1 v2 v3 w1 w2 w3).
Qed.

Function add_matrix (A B : Matrix3x3) : Matrix3x3 :=
  match A, B with
    | matrix v1 v2 v3, matrix w1 w2 w3 =>
      matrix (add_vec3 v1 w1)
             (add_vec3 v2 w2)
             (add_vec3 v3 w3)
  end.

Lemma unfold_add_matrix :
  forall v1 v2 v3 w1 w2 w3 : Vec3,
    add_matrix (matrix v1 v2 v3) (matrix w1 w2 w3) = matrix (add_vec3 v1 w1)
                                                            (add_vec3 v2 w2)
                                                            (add_vec3 v3 w3).
Proof.
  unfold_tactic add_matrix.
Qed.

Theorem add_matrix_satisfies_the_specification :
  specification_of_add_matrix_3x3 add_matrix.
Proof.
  unfold specification_of_add_matrix_3x3.
  exact unfold_add_matrix.
Qed.

Theorem Matrix3x3_and_addition_is_associative :
  Associative Matrix3x3 add_matrix eq.
Proof.
  unfold Associative.
  intros [v1 v2 v3] [w1 w2 w3] [x1 x2 x3].
  rewrite ->4 unfold_add_matrix.
  rewrite ->3 Vec3_and_addition_is_associative.
  reflexivity.
Qed.

Corollary Matrix3x3_and_addition_is_a_semi_group :
  Semi_Group Matrix3x3 add_matrix eq.
Proof.
  unfold Semi_Group.
  split.
  exact (eq_is_a_valid_Equal Matrix3x3).
  exact Matrix3x3_and_addition_is_associative.
Qed.

Definition O_matrix : Matrix3x3 := matrix O_vec3 O_vec3 O_vec3.

Lemma add_O_matrix_l :
  forall A : Matrix3x3,
    add_matrix O_matrix A = A.
Proof.
  intros [a b c].
  unfold O_matrix.
  rewrite -> unfold_add_matrix.
  rewrite ->3 add_O_vec3_l.
  reflexivity.
Qed.

Lemma add_O_matrix_r :
  forall A : Matrix3x3,
    add_matrix A O_matrix = A.
Proof.
  intros [a b c].
  unfold O_matrix.
  rewrite -> unfold_add_matrix.
  rewrite ->3 add_O_vec3_r.
  reflexivity.
Qed.

Theorem Matrix3x3_and_addition_have_neutral_element :
  exists O : Matrix3x3,
    Neutral Matrix3x3 add_matrix O eq.
Proof.
  unfold Neutral.
  exists O_matrix.
  intro A.
  split.
    exact (add_O_matrix_r A).

    exact (add_O_matrix_l A).
Qed.

Corollary Matrix3x3_and_addition_is_a_monoid :
  (exists O : Matrix3x3, Neutral Matrix3x3 add_matrix O eq) /\
  Semi_Group Matrix3x3 add_matrix eq.
Proof.
  split.
    exact Matrix3x3_and_addition_have_neutral_element.
    exact Matrix3x3_and_addition_is_a_semi_group.
Qed.

Theorem Matrix3x3_and_addition_is_commutative :
  Commutative Matrix3x3 add_matrix eq.
Proof.
  unfold Commutative.
  intros [v1 w1 x1] [v2 w2 x2].
  rewrite ->2 unfold_add_matrix.
  symmetry.
  rewrite -> (Vec3_and_addition_is_commutative v2 v1).
  rewrite -> (Vec3_and_addition_is_commutative w2 w1).
  rewrite -> (Vec3_and_addition_is_commutative x2 x1).
  reflexivity.
Qed.

Definition opp_matrix (A : Matrix3x3) : Matrix3x3 :=
  match A with
    | matrix a b c => matrix (opp_vec3 a) (opp_vec3 b) (opp_vec3 c)
  end.

Theorem Matrix3x3_and_addition_have_an_inverse :
  Inverse Matrix3x3 add_matrix eq.
Proof.
  unfold Inverse.
  intro A.
  exists O_matrix.
  exists (opp_matrix A).
  unfold opp_matrix.
  destruct A as [a b c].
  rewrite -> unfold_add_matrix.
  rewrite ->3 add_opp_vec3_r.
  fold O_matrix.
  reflexivity.
Qed.

Corollary Matrix3x3_and_addition_is_an_abelian_group :
  Abelian_Group Matrix3x3 add_matrix eq.
Proof.
  unfold Abelian_Group.
  split.
    exact Matrix3x3_and_addition_is_commutative.
    split.
      exact Matrix3x3_and_addition_have_an_inverse.
      exact Matrix3x3_and_addition_is_a_monoid.
Qed.

(* Multiplication *)

Definition specification_of_3x3_matrix_multiplication (mult : Matrix3x3 ->
                                                              Matrix3x3 ->
                                                              Matrix3x3) :=
  forall a11 a12 a13 a21 a22 a23 a31 a32 a33 b11 b12 b13 b21 b22 b23 b31 b32 b33 : Z,
    mult (matrix (vec3 a11 a12 a13)
                 (vec3 a21 a22 a23)
                 (vec3 a31 a32 a33))
         (matrix (vec3 b11 b12 b13)
                 (vec3 b21 b22 b23)
                 (vec3 b31 b32 b33)) =
    matrix (vec3 (mult_vec3 (vec3 a11 a12 a13) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a11 a12 a13) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a11 a12 a13) (vec3 b13 b23 b33)))
             (vec3 (mult_vec3 (vec3 a21 a22 a23) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a21 a22 a23) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a21 a22 a23) (vec3 b13 b23 b33)))
             (vec3 (mult_vec3 (vec3 a31 a32 a33) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a31 a32 a33) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a31 a32 a33) (vec3 b13 b23 b33))).

Theorem specification_of_3x3_matrix_multiplication_is_unique :
  forall mult mult' : Matrix3x3 -> Matrix3x3 -> Matrix3x3,
    specification_of_3x3_matrix_multiplication mult ->
    specification_of_3x3_matrix_multiplication mult' ->
    forall A B : Matrix3x3,
      mult A B = mult' A B.
Proof.
  intros mult mult'.
  unfold specification_of_3x3_matrix_multiplication.
  intros S_mult S_mult'.
  intros [[a11 a12 a13]
          [a21 a22 a23]
          [a31 a32 a33]]

         [[b11 b12 b13]
          [b21 b22 b23]
          [b31 b32 b33]].
  rewrite -> S_mult.
  symmetry.
  exact (S_mult' a11 a12 a13 a21 a22 a23 a31 a32 a33 b11 b12 b13 b21 b22 b23 b31 b32 b33).
Qed.

Function mult_matrix (A B : Matrix3x3) : Matrix3x3 :=
  match A, B with
    | (matrix (vec3 a11 a12 a13)
              (vec3 a21 a22 a23)
              (vec3 a31 a32 a33)),
      (matrix (vec3 b11 b12 b13)
              (vec3 b21 b22 b23)
              (vec3 b31 b32 b33)) =>
      matrix (vec3 (mult_vec3 (vec3 a11 a12 a13) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a11 a12 a13) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a11 a12 a13) (vec3 b13 b23 b33)))
             (vec3 (mult_vec3 (vec3 a21 a22 a23) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a21 a22 a23) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a21 a22 a23) (vec3 b13 b23 b33)))
             (vec3 (mult_vec3 (vec3 a31 a32 a33) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a31 a32 a33) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a31 a32 a33) (vec3 b13 b23 b33)))
  end.

Lemma unfold_mult_matrix :
  forall a11 a12 a13 a21 a22 a23 a31 a32 a33 b11 b12 b13 b21 b22 b23 b31 b32 b33 : Z,
    mult_matrix (matrix (vec3 a11 a12 a13)
                        (vec3 a21 a22 a23)
                        (vec3 a31 a32 a33))
                (matrix (vec3 b11 b12 b13)
                        (vec3 b21 b22 b23)
                        (vec3 b31 b32 b33)) =
    matrix (vec3 (mult_vec3 (vec3 a11 a12 a13) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a11 a12 a13) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a11 a12 a13) (vec3 b13 b23 b33)))
             (vec3 (mult_vec3 (vec3 a21 a22 a23) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a21 a22 a23) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a21 a22 a23) (vec3 b13 b23 b33)))
             (vec3 (mult_vec3 (vec3 a31 a32 a33) (vec3 b11 b21 b31))
                   (mult_vec3 (vec3 a31 a32 a33) (vec3 b12 b22 b32))
                   (mult_vec3 (vec3 a31 a32 a33) (vec3 b13 b23 b33))).
Proof.
  unfold_tactic mult_matrix.
Qed.

Theorem mult_matrix_satifies_the_specification_of_matrix_multiplication :
  specification_of_3x3_matrix_multiplication mult_matrix.
Proof.
  unfold specification_of_3x3_matrix_multiplication.
  exact unfold_mult_matrix.
Qed.

Theorem Matrix3x3_and_multiplication_is_associative :
  Associative Matrix3x3 mult_matrix eq.
Proof.
  unfold Associative.
  intros [[a11 a12 a13]
          [a21 a22 a23]
          [a31 a32 a33]]

         [[b11 b12 b13]
          [b21 b22 b23]
          [b31 b32 b33]]

         [[c11 c12 c13]
          [c21 c22 c23]
          [c31 c32 c33]].
  rewrite ->4 unfold_mult_matrix.
  assert (H_row : forall (a11 a12 a13 : Z)
                         (b11 b12 b13 b21 b22 b23 b31 b32 b33 : Z)
                         (c11 c21 c31 : Z),
                    (vec3
                       (mult_vec3 (vec3 a11 a12 a13)
                                  (vec3 (mult_vec3 (vec3 b11 b12 b13) (vec3 c11 c21 c31))
                                        (mult_vec3 (vec3 b21 b22 b23) (vec3 c11 c21 c31))
                                        (mult_vec3 (vec3 b31 b32 b33) (vec3 c11 c21 c31))))
                       (mult_vec3 (vec3 a11 a12 a13)
                                  (vec3 (mult_vec3 (vec3 b11 b12 b13) (vec3 c12 c22 c32))
                                        (mult_vec3 (vec3 b21 b22 b23) (vec3 c12 c22 c32))
                                        (mult_vec3 (vec3 b31 b32 b33) (vec3 c12 c22 c32))))
                       (mult_vec3 (vec3 a11 a12 a13)
                                  (vec3 (mult_vec3 (vec3 b11 b12 b13) (vec3 c13 c23 c33))
                                        (mult_vec3 (vec3 b21 b22 b23) (vec3 c13 c23 c33))
                                        (mult_vec3 (vec3 b31 b32 b33) (vec3 c13 c23 c33))))) =
                    (vec3
                       (mult_vec3
                          (vec3 (mult_vec3 (vec3 a11 a12 a13) (vec3 b11 b21 b31))
                                (mult_vec3 (vec3 a11 a12 a13) (vec3 b12 b22 b32))
                                (mult_vec3 (vec3 a11 a12 a13) (vec3 b13 b23 b33)))
                          (vec3 c11 c21 c31))
                       (mult_vec3
                          (vec3 (mult_vec3 (vec3 a11 a12 a13) (vec3 b11 b21 b31))
                                (mult_vec3 (vec3 a11 a12 a13) (vec3 b12 b22 b32))
                                (mult_vec3 (vec3 a11 a12 a13) (vec3 b13 b23 b33)))
                          (vec3 c12 c22 c32))
                       (mult_vec3
                          (vec3 (mult_vec3 (vec3 a11 a12 a13) (vec3 b11 b21 b31))
                                (mult_vec3 (vec3 a11 a12 a13) (vec3 b12 b22 b32))
                                (mult_vec3 (vec3 a11 a12 a13) (vec3 b13 b23 b33)))
                          (vec3 c13 c23 c33)))).
    intros a1 a2 a3 b1 b2 b3 b4 b5 b6 b7 b8 b9 c1 c2 c3.
    unfold mult_vec3.
    assert (H_entry : forall x1 x2 x3 y1 y2 y3 y4 y5 y6 y7 y8 y9 z1 z2 z3 : Z,
                                (x1 * (y1 * z1 + y2 * z2 + y3 * z3) +
                                 x2 * (y4 * z1 + y5 * z2 + y6 * z3) +
                                 x3 * (y7 * z1 + y8 * z2 + y9 * z3)) =
                                ((x1 * y1 + x2 * y4 + x3 * y7) * z1 +
                                 (x1 * y2 + x2 * y5 + x3 * y8) * z2 +
                                 (x1 * y3 + x2 * y6 + x3 * y9) * z3)).
      intros; ring.

    rewrite ->3 H_entry.
    reflexivity.
    rewrite ->3 H_row.
    reflexivity.
    Show Proof.
Qed.

Corollary Matrix3x3_and_multiplication_is_a_semi_group :
  Semi_Group Matrix3x3 mult_matrix eq.
Proof.
  unfold Semi_Group.
  split.
  exact (eq_is_a_valid_Equal Matrix3x3).
  exact Matrix3x3_and_multiplication_is_associative.
Qed.

Definition I : Matrix3x3 :=
  matrix (vec3 1 0 0)
         (vec3 0 1 0)
         (vec3 0 0 1).

Lemma mult_matrix_I_l :
  forall A : Matrix3x3,
    mult_matrix I A = A.
Proof.
  intros [[a b c]
          [d e f]
          [g h i]].
  unfold I.
  rewrite -> unfold_mult_matrix.
  rewrite ->9 unfold_mult_vec3.
  rewrite ->9 Z.mul_0_l.
  rewrite ->10 Z.add_0_r.
  rewrite ->6 Z.add_0_l.
  rewrite ->9 Z.mul_1_l.
  reflexivity.
Qed.

Lemma mult_matrix_I_r :
  forall A : Matrix3x3,
    mult_matrix A I = A.
Proof.
  intros [[a b c]
          [d e f]
          [g h i]].
  unfold I.
  rewrite -> unfold_mult_matrix.
  rewrite ->9 unfold_mult_vec3.
  rewrite ->9 Z.mul_0_r.
  rewrite ->10 Z.add_0_r.
  rewrite ->6 Z.add_0_l.
  rewrite ->9 Z.mul_1_r.
  reflexivity.
Qed.

Theorem Matrix3x3_and_multiplication_have_a_neutral_element :
  (exists O : Matrix3x3,
     Neutral Matrix3x3 mult_matrix O eq).
Proof.
  unfold Neutral.
  exists I.
  intro A.
  split.
    exact (mult_matrix_I_r A).

    exact (mult_matrix_I_l A).
Qed.

Corollary Matrix3x3_and_multiplication_is_a_monoid :
  Monoid Matrix3x3 mult_matrix eq.
Proof.
  unfold Monoid.
  split.
  exact Matrix3x3_and_multiplication_have_a_neutral_element.
  exact Matrix3x3_and_multiplication_is_a_semi_group.
Qed.

Proposition Matrix3x3_and_multiplication_is_NOT_in_the_Abelian_Group :
  not (Abelian_Group Matrix3x3 mult_matrix eq).
Proof.
  unfold Abelian_Group.
  unfold not.
  intros [H_comm [H_inv H_Monoid]].
  unfold Commutative in H_comm.
  assert (H_comm_absurd := H_comm (matrix (vec3 1 0 1)
                                          (vec3 0 1 0)
                                          (vec3 0 0 1))
                                  (matrix (vec3 1 0 0)
                                          (vec3 1 1 0)
                                          (vec3 0 0 1))).
    rewrite ->2 unfold_mult_matrix in H_comm_absurd.
    rewrite ->17 unfold_mult_vec3 in H_comm_absurd.
    compute in H_comm_absurd.
    discriminate.
Qed.

Lemma mult_matrix_distr_add_matrix_l :
  forall A B C: Matrix3x3,
    mult_matrix A (add_matrix B C) =
    add_matrix (mult_matrix A B) (mult_matrix A C).
Proof.
  intros [[a11 a12 a13]
          [a21 a22 a23]
          [a31 a32 a33]]

         [[b11 b12 b13]
          [b21 b22 b23]
          [b31 b32 b33]]

         [[c11 c12 c13]
          [c21 c22 c23]
          [c31 c32 c33]].
  rewrite -> unfold_add_matrix.
  rewrite ->3 unfold_add_vec3.
  rewrite -> unfold_mult_matrix.
  rewrite ->9 unfold_mult_vec3.
  symmetry.
  rewrite ->2 unfold_mult_matrix.
  rewrite ->18 unfold_mult_vec3.
  rewrite -> unfold_add_matrix.
  rewrite ->3 unfold_add_vec3.
  assert (H_row : forall a1 a2 a3 b1 b2 b3 c1 c2 c3 : Z,
                    (a1 * b1 + a2 * b2 + a3 * b3 + (a1 * c1 + a2 * c2 + a3 * c3)) =
                    (a1 * (b1 + c1) + a2 * (b2 + c2) + a3 * (b3 + c3))).
   intros; ring.
 rewrite ->9 H_row.
 reflexivity.
Qed.

Lemma mult_matrix_distr_add_matrix_r :
  forall A B C: Matrix3x3,
    mult_matrix (add_matrix A B) C =
    add_matrix (mult_matrix A C) (mult_matrix B C).
Proof.
  intros [[a11 a12 a13]
          [a21 a22 a23]
          [a31 a32 a33]]

         [[b11 b12 b13]
          [b21 b22 b23]
          [b31 b32 b33]]

         [[c11 c12 c13]
          [c21 c22 c23]
          [c31 c32 c33]].
  rewrite -> unfold_add_matrix.
  rewrite ->3 unfold_add_vec3.
  rewrite -> unfold_mult_matrix.
  rewrite ->9 unfold_mult_vec3.
  symmetry.
  rewrite ->2 unfold_mult_matrix.
  rewrite ->18 unfold_mult_vec3.
  rewrite -> unfold_add_matrix.
  rewrite ->3 unfold_add_vec3.
  assert (H_row : forall a1 a2 a3 b1 b2 b3 c1 c2 c3 : Z,
                     (a1 * c1 + a2 * c2 + a3 * c3 + (b1 * c1 + b2 * c2 + b3 * c3)) =
                     ((a1 + b1) * c1 + (a2 + b2) * c2 + (a3 + b3) * c3)).
   intros; ring.
 rewrite ->9 H_row.
 reflexivity.
Qed.

Theorem Matrix3x3_multiplication_distributes_over_addition :
  Distributive Matrix3x3 mult_matrix add_matrix eq.
Proof.
  unfold Distributive.
  intros A B C.
  split.
  exact (mult_matrix_distr_add_matrix_l A B C).
  exact (mult_matrix_distr_add_matrix_r A B C).
Qed.

Corollary Matrix3x3_forms_a_ring :
  Ring Matrix3x3 mult_matrix add_matrix eq.
Proof.
  unfold Ring.
  split.
    exact Matrix3x3_multiplication_distributes_over_addition.
    split.
    exact Matrix3x3_and_addition_is_an_abelian_group.
    exact Matrix3x3_and_multiplication_is_a_monoid.
Qed.

(* Please continue with Functions. *)


Require Export Arith.
Require Export ArithRing.
Require Export ZArith.

Fixpoint fib (n:nat) : nat :=
  match n with
    0 => 1
  | 1 => 1
  | S ((S p) as q) => fib p + fib q
  end.

Theorem fib_ind :
  forall P : nat -> Prop,
    P 0 -> P 1 ->
    (forall n, P n -> P (S n) -> P (S (S n)))->
    forall n, P n.
Proof.
 intros P H0 H1 Hstep n.
 assert (P n/\P(S n)).
 elim n; intuition.
 intuition.
Qed.

Theorem fib_unroll :
  forall n, fib (S (S n)) = fib n + fib (S n).
Proof.
 auto.
Qed.

Theorem fib_n_p :
  forall n p, fib (n + p + 2) =
             fib (n + 1) * fib (p + 1) + fib n * fib p.
Proof.
  intros n; elim n using fib_ind.
  intros p; replace (0 + p+2) with (S (S p)).
  replace (p+1) with (S p).
  rewrite fib_unroll.
  simpl (fib 0).
  simpl (fib (0+1)).
  ring.
  ring.
  ring.

  intros p; replace (1+p+2) with (S (S (S p))).
  repeat rewrite fib_unroll.
  simpl (fib (1+1)).
  simpl (fib 1).
  replace (p+1) with (S p).
  ring.
  ring.
  ring.

  intros n' IHn' IHn'1 p.
  replace (S (S n') + p + 2) with (S (S (n'+p + 2))).
  simpl (S (S n') + 1).
  repeat rewrite fib_unroll.
  replace (S (n'+p+2)) with (S n' +p+2).
  rewrite IHn'1.
  rewrite IHn'.
  replace (S n'+1) with (S (S n')).
  replace (S (n'+1)) with (S (S n')).
  rewrite fib_unroll.
  ring.
  ring.
  ring.
  ring.
  ring.
Qed.

Theorem fib_monotonic :  forall n, fib n <= fib (n+1).
Proof.
 intros n; elim n using fib_ind; auto with arith.
 intros n' H1 H2; replace (S (S n')+1) with (S (S (S n'))).
 rewrite (fib_unroll (S n')).
 auto with arith.
 ring.
Qed.

Theorem fib_n_p' :
  forall n p, fib (n + p) =
     fib n * fib p + (fib (n+1) - fib n)*(fib (p+1) - fib p).
Proof.
 intros n; elim n using fib_ind.
 intros p; simpl; ring.

 intros p; replace (1 + p) with (p + 1); simpl.  ring_simplify.
 (*
 ring_simplify. *)
 (*rewrite <- (plus_comm (fib p)).*)
 rewrite le_plus_minus_r.
 auto.
 apply fib_monotonic.
 rewrite plus_comm.
 auto.
 intros n' IHn' IHn'1 p.
 simpl (S (S n') + p).
 rewrite fib_unroll.
 replace (S (n' + p)) with (S n' + p).
 rewrite IHn'.
 rewrite IHn'1.
 simpl (S (S n')+1).
 replace (S n' + 1) with (S (S n')).
 replace (S (n' + 1)) with (S (S n')).
 repeat rewrite fib_unroll.
 rewrite (plus_comm (fib (S n'))
             (fib n' + fib (S n'))).
 rewrite minus_plus.
 rewrite (plus_comm (fib n')(fib (S n'))).
 rewrite minus_plus.
 rewrite mult_minus_distr_r.
 replace
   (fib n' * fib p +
   (fib (n' + 1) * (fib (p + 1) - fib p) - fib n' * (fib (p + 1) - fib p)) +
   (fib (S n') * fib p + fib n' * (fib (p + 1) - fib p)))
  with
   (fib n' * fib p +
   (fib n' * (fib (p + 1) - fib p) +
   (fib (n' + 1) * (fib (p + 1) - fib p) -
         fib n' * (fib (p + 1) - fib p))) +   fib (S n') * fib p).
 rewrite (le_plus_minus_r).
 replace (n' + 1) with (S n').
 ring.
 ring.
 apply mult_le_compat_r.
 apply fib_monotonic.
 ring.
 ring.
 ring.
 ring.
Qed.

Theorem fib_2n :
  forall n, fib (2*n) = fib (n) * fib (n) +
           (fib (n+1) - fib n)*(fib (n+1) - fib n).
Proof.
 intros n; replace (2*n) with (n+n).
 apply fib_n_p'.
 ring.
Qed.

Theorem fib_2n_plus_1 :
  forall n, fib (2*n+1) = 2 * fib n * fib (n+1) - fib n * fib n.
Proof.
 intros n; replace (2*n+1) with (n + (n + 1)).
 rewrite fib_n_p'.
 replace (n + 1 + 1) with (S (S n)).
 rewrite fib_unroll.
 replace (S n) with (n + 1).
 rewrite (plus_comm (fib n) (fib (n + 1))).
 rewrite minus_plus.
 apply plus_reg_l with (fib n * fib n).
 rewrite le_plus_minus_r.
 rewrite plus_permute.
 rewrite mult_minus_distr_r.
 rewrite le_plus_minus_r.
 ring.
 apply mult_le_compat_r.
 apply fib_monotonic.
 replace (fib n * fib n) with (1 * (fib n * fib n)).
 rewrite mult_assoc_reverse.
 apply mult_le_compat.
 auto with arith.
 apply mult_le_compat_l.
 apply fib_monotonic.
 ring.
 ring.
 ring.
 ring.
Qed.

Theorem fib_2n_plus_2 :
  forall n, fib (S (2*n+1)) = fib (n+1) * (fib (n+1)) + fib n * fib n.
Proof.
 intros n; replace (S (2*n+1)) with ((n+1)+(n+1)).
 rewrite fib_n_p'.
 replace (n + 1 + 1) with (S (S n)).
 rewrite fib_unroll.
 replace (S n) with (n + 1).
 rewrite (plus_comm (fib n) (fib (n + 1))).
 rewrite minus_plus.
 auto.
 ring.
 ring.
 ring.
Qed.

Theorem th_fib_positive1 :
  forall p : positive,
  forall u v : nat,
    u = fib (nat_of_P p) /\ v = fib (S (nat_of_P p)) ->
      2*u*v - u*u = fib(nat_of_P (xI p)) /\
      v*v + u*u = fib(S (nat_of_P (xI p))).
Proof.
 intros p u v [Hu Hv]; rewrite Hu; rewrite Hv.
 rewrite nat_of_P_xI.
 replace (S (2* nat_of_P p)) with (2*nat_of_P p + 1).
 rewrite fib_2n_plus_1.
 rewrite fib_2n_plus_2.
 replace (S (nat_of_P p)) with (nat_of_P p + 1).
 auto.
 ring.
 ring.
Qed.

Theorem th_fib_positive0 :
  forall p : positive,
  forall u v : nat,
    u = fib (nat_of_P p) /\ v = fib (S (nat_of_P p)) ->
    u*u + (v-u)*(v-u) = fib (nat_of_P (xO p)) /\
    2*u*v - u*u = fib (S (nat_of_P (xO p))).
Proof.
 intros p u v [Hu Hv]; subst.
 rewrite nat_of_P_xO.
 rewrite fib_2n.
 replace (S (nat_of_P p)) with (nat_of_P p + 1).
 replace (S (2*nat_of_P p)) with (2*nat_of_P p+1).
 rewrite fib_2n_plus_1.
 auto.
 ring.
 ring.
Qed.

Fixpoint fib_positive (p:positive) :
  {u:nat & { v : nat | u = fib (nat_of_P p) /\  v = fib (S (nat_of_P p))}} :=
match p return
   {u:nat & { v : nat | u = fib (nat_of_P p) /\  v = fib (S (nat_of_P p))}}
     with
  xH => (existS (fun u=> { v : nat | u = 1 /\  v = 2})
              1 (exist (fun v => 1 = 1 /\  v = 2)
                    2 (conj (refl_equal 1) (refl_equal 2))))
| xI p' =>
   match fib_positive p' with
     (existS u (exist v h)) =>
       (existS (fun u =>
                  { v: nat | u = fib (nat_of_P (xI p')) /\
                             v = fib (S (nat_of_P (xI p')))})
           (2*u*v - u*u)
          (exist (fun w=> 2*u*v-u*u = fib (nat_of_P (xI p')) /\
                            w= fib (S (nat_of_P (xI p'))))
             (v*v + u*u) (th_fib_positive1 p' u v h)))
   end
| xO p' =>
   match fib_positive p' with
     (existS u (exist v h)) =>
       (existS (fun u =>
                  { v: nat | u = fib (nat_of_P (xO p')) /\
                             v = fib (S (nat_of_P (xO p')))})
            (u*u+(v-u)*(v-u))
          (exist (fun w => u*u+(v-u)*(v-u) = fib (nat_of_P (xO p'))/\
                           w = fib (S (nat_of_P (xO p'))))
                (2*u*v-u*u) (th_fib_positive0 p' u v h)))
   end
end.

Definition fib' :
  forall n:nat, {u : nat &{v : nat | u = fib n /\ v = fib (S n)}}.
Proof.
  intros n; case n.
  exists 1; exists 1; auto.
  intros n'; elim (fib_positive (P_of_succ_nat n'));
  intros u [v [Hu Hv]].
  exists u; exists v.
  rewrite Hu; rewrite Hv; rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
  auto.
Qed.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Print unit.

Print True.

(* Propositional Logic *)

Section Propositional.
  Variables P Q R : Prop.

  Theorem obvious : True.
    apply I.
  Qed.

  Theorem obvious' : True.
    constructor.
  Qed.

  Theorem False_imp : False -> 2 + 2 = 5.
    destruct 1.
  Qed.

  Theorem arith_neq : 2 + 2 = 5 -> 9 + 9 = 835.
    intro.
    elimtype False.
    crush.
  Qed.

  Print not.

  Theorem arith_neq' : ~ (2 + 2 = 5).
    unfold not.
    crush.
  Qed.

  Print and.

  Theorem and_comm : P /\ Q -> Q /\ P.
    destruct 1.
    split.
    assumption.
    assumption.
  Qed.

  Print or.

  Theorem or_comm : P \/ Q -> Q \/ P.
    destruct 1.
    right; assumption.
    left; assumption.
  Qed.

  Theorem or_comm' : P \/ Q -> Q \/ P.
    tauto.
  Qed.

  Theorem arith_comm : forall ls1 ls2 : list nat,
      length ls1 = length ls2 \/ length ls1 + length ls2 = 6
      -> length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
    intuition.
    rewrite app_length.
    tauto.
  Qed.

  Theorem arith_comm' : forall ls1 ls2 : list nat,
      length ls1 = length ls2 \/ length ls1 + length ls2 = 6
      -> length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
    Hint Rewrite app_length.
    crush.
  Qed.
End Propositional.

(* First Order Logic *)

Print ex.

Theorem exist1 : exists x : nat, x + 1 = 2.
  exists 1.
  reflexivity.
Qed.

Theorem exist2 : forall n m : nat, (exists x : nat, n + x = m) -> n <= m.
  destruct 1.
  crush.
Qed.

(* Predicates with Implicit Equality *)

Inductive isZero : nat -> Prop :=
| IsZero : isZero 0.

Theorem isZero_zero : isZero 0.
  constructor.
Qed.

Print eq.

Theorem isZero_plus : forall n m : nat, isZero m -> n + m = n.
  destruct 1.
  crush.
Qed.

Theorem isZero_contra : isZero 1 -> False.
  inversion 1.
Qed.

Theorem isZero_contra' : isZero 1 -> 2 + 2 = 5.
  destruct 1.
Abort.

Check isZero_ind.

(* Recursive Predicates *)

Inductive even : nat -> Prop :=
| EvenO : even 0
| EvenSS : forall n, even n -> even (S (S n)).

Theorem even_0 : even 0.
  constructor.
Qed.

Theorem even_4 : even 4.
  constructor; constructor; constructor.
Qed.

Hint Constructors even.

Theorem even_4' : even 4.
  auto.
Qed.

Theorem even_1_contra : even 1 -> False.
  inversion 1.
Qed.

Theorem even_3_contra : even 3 -> False.
  inversion 1.
  inversion H1.
Qed.

Theorem even_plus : forall n m, even n -> even m -> even (n + m).
  induction 1; crush.
Qed.

Lemma even_contra' : forall n', even n' -> forall n, n' = S (n + n) -> False.
  Hint Rewrite <- plus_n_Sm.
  induction 1; crush.
  match goal with
  | [H : S ?N = ?N0 + ?N0 |- _] => destruct N; destruct N0
  end; crush.
Qed.

Theorem even_contra : forall n, even (S (n + n)) -> False.
  intros; eapply even_contra'; eauto.
Qed.

Lemma even_contra'' : forall n' n, even n' -> n' = S (n + n) -> False.
  Hint Rewrite <- plus_n_Sm.
  induction 1; crush.
  match goal with
  | [H : S ?N = ?N0 + ?N0 |- _] => destruct N; destruct N0
  end; crush.
Abort.


Require Export P03.

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n). { reflexivity. }
  rewrite -> H.
  reflexivity.
Qed.

(** **** Problem : 3 stars (mult_comm) *)

Theorem mult_plus_distr_r : forall n m p : nat,
    (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p. induction n.
  - reflexivity.
  - simpl. rewrite -> IHn. rewrite -> plus_assoc. reflexivity.
Qed.


(* PREAMBLE *)

(** * Algebraic laws and helpers *)

(** ** Inverse in [Prop] *)
Section Inverse.
  (** [T__inv] is a transformation that is right inverse of [T] on a given domain Dom *)

  Context {A} (T T__inv: A -> A).

  Definition left_inverse_on (Dom: A -> Prop)  : Prop :=
    forall a, Dom a -> T__inv (T a) = a.

  (** If [T__inv] is the left inverse (i.e. [T__inv o T === id]). *)
  Definition left_inverse : Prop :=
    left_inverse_on (fun _ => True) .

  Definition right_inverse_on (Dom: A -> Prop) : Prop :=
    forall a, Dom a -> T (T__inv a) = a.

  (** If [T__inv] is the right inverse (i.e. [T o T__inv === id]). *)

  Definition right_inverse : Prop :=
    right_inverse_on (fun _ => True).

  Definition option_inverse  {U V:Type} (F: U -> option V) (G: V -> option U )
    := forall u v, F u = Some v <-> G v = Some u.

  Theorem option_inverse_symm:
    forall {U} (f1 f2: U -> option U),
      option_inverse f1 f2 -> option_inverse f2 f1.
  Proof. unfold option_inverse. intros U f g H u v. split; intros; eapply H; auto. Qed.

End Inverse.

Section InverseProperties.

  Lemma left_inverse_id: forall A, @left_inverse A (@id _) (@id _).
  Proof.
    intros ? ? _; reflexivity.
  Qed.

  Lemma right_inverse_id: forall A, @right_inverse A (@id _) (@id _).
  Proof.
    intros ? ? _; reflexivity.
  Qed.

End InverseProperties.

(** ** Functions *)
Notation "g ∘ f" := (fun x => g (f x)) (at level 51, right associativity).

Section Functions.
  (** Single valued means that for each first argument of [R] only one or zero
values of the second argument make the relation [R] hold. *)

  Definition single_valued {A B} (p:A -> B -> Prop) :=
    forall x1 x2 x3,
      p x1 x2 -> p x1 x3 -> x2 = x3.

  (** Different arguments are mapped to different values. *)
  Definition injectivity {A B} (p:A -> B -> Prop) :=
    forall x1 x2 x3,
      p x1 x3 -> p x2 x3 -> x1 = x2.

  (** Different arguments are mapped to different values. *)
  Definition option_injectivity {A B} (f:A -> option B) :=
    forall x y x' y',
      x <> y ->
      f x = Some x' ->
      f y = Some y' ->
      x' <> y'.

  (** Extensional equality *)
  Definition ext_eq {T U} (f g: T -> U) := forall x, f x = g x.

  Lemma ext_eq_symm {T U} (f g: T -> U) : ext_eq f g -> ext_eq g f.
  Proof. intros H x. rewrite H. reflexivity. Qed.

  Theorem eq_implies_ext_eq:
    forall {T U} (f g: T -> U),
      f = g -> ext_eq f g .
  Proof. intros T U f g H. subst. intros ?. reflexivity. Qed.

  Lemma option_inverse_extensional:
    forall {A B} (f f': A -> option B) g,
      option_inverse f g ->
      ext_eq f f' ->
      option_inverse f' g.
  Proof. intros A B f f' g H H0 u v. rewrite <-H0. auto. Qed.

  (** Flip arguments of a function with two arguments. *)
  Definition flip {A B C} (p: A -> B -> C ) : B -> A -> C :=
    fun a b => p b a.

  (** Apply to the second component *)
  Definition skip1 {A B C} (f: B->C) : (A*B) -> C := f ∘ snd.

  Definition involution {A} (f: A->A) := forall x, f ( f x ) = x.

  Definition True1 {A} := fun _:A => True.
  Definition True2 {A B} := fun _:A =>  @True1 B.
  Definition True3 {A B C} := fun _:A =>  @True2 B C.
  Definition True4 {A B C D} := fun _:A =>  @True3 B C D.
End Functions.

Hint Resolve option_inverse_extensional ext_eq_symm eq_implies_ext_eq : ext.

Notation "f ≃ g" := (ext_eq f g) (at level 51, no associativity).

Section Relations.

  (** Flip arguments of a binary relation. *)
  Definition converse {A B} (p: A -> B -> Prop) : B -> A -> Prop :=
    fun a b => p b a.

  Definition stability {T} (R: T -> Prop) (U: T -> T -> Prop) := forall x1 x2, R x1 -> U x1 x2 -> R x2.

  Definition transitivity {A:Type} (R: A->A->Prop)  := forall a b c, R a b -> R b c -> R a c.

End Relations.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint drop (drop_arg0 : Nat) (drop_arg1 : Lst) : Lst
           := match drop_arg0, drop_arg1 with
              | x, nil => nil
              | zero, x => x
              | succ x, cons y z => drop x z
              end.

Theorem drop_nil: forall (x: Nat), drop x nil = nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_cons: forall (x n: Nat) (l: Lst), drop (succ x) (cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_cons_assoc: forall (x1 x2 x3: Nat) (l: Lst),
    drop x1 (drop x2 (cons x3 l)) = drop x2 (drop x1 (cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  { induction l.
    { rewrite 2 drop_cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_cons.
      induction l.
      { rewrite IHx1. reflexivity. }
      { rewrite 3 drop_nil. reflexivity. }
    }
    { simpl. rewrite 2 drop_nil. reflexivity. }
  }
  { intros. simpl. destruct (drop x1 l); reflexivity. }
  { intros. simpl. destruct (drop x2 l); reflexivity. }
Qed.

Theorem theorem0 : forall (x : Nat) (y : Nat) (z : Lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  { rewrite 2 drop_cons_assoc. reflexivity. }
  { rewrite 3 drop_nil. reflexivity. }
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) (x : natural) : natural :=
  plus Zero (mult x lf1).


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


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


Require Import Arith.

Definition Var := nat.

Definition Env := Var -> nat.

Definition empty : Env := fun v => 0.

Definition update (env:Env) (v:Var) (n:nat) : Env :=
    fun (x:Var) => if beq_nat x v then n else env x.

Inductive Exp : Set :=
| EConst : nat -> Exp
| EVar   : Var -> Exp
| EPlus  : Exp -> Exp -> Exp
.

(* interpreter fixes the semantics *)
Fixpoint evalExp (env:Env) (e:Exp) : nat :=
    match e with
    | EConst n      => n
    | EVar v        => env v
    | EPlus e1 e2   => evalExp env e1 + evalExp env e2
    end.

Example test_evalExp1 : evalExp empty (EConst 5) = 5.
Proof. reflexivity. Qed.

Example test_evalExp2 : evalExp (update empty 3 12) (EVar 3) = 12.
Proof. reflexivity. Qed.

Example test_evalExp3 : evalExp (update empty 3 12)(EPlus(EConst 5)(EVar 3)) = 17.
Proof. reflexivity. Qed.

Inductive Cmd : Set :=
| CAssign : Var -> Exp -> Cmd
| CSeq    : Cmd -> Cmd -> Cmd
| CWhile  : Exp -> Cmd -> Cmd
.

CoInductive evalCmd : Env -> Cmd -> Env -> Prop :=
| EvalAssign : forall (env:Env) (v:Var) (e:Exp),
    evalCmd env (CAssign v e) (update env v (evalExp env e))
| EvalSeq : forall (e1 e2 e3:Env) (c1 c2:Cmd),
    evalCmd e1 c1 e2 -> evalCmd e2 c2 e3 -> evalCmd e1 (CSeq c1 c2) e3
| EvalWhileFalse : forall (env:Env) (e:Exp) (c:Cmd),
    evalExp env e = 0 -> evalCmd env (CWhile e c) env
| EvalWhileTrue : forall (e1 e2 e3:Env) (e:Exp) (c:Cmd),
    evalExp e1 e <> 0 -> evalCmd e1 c e2 -> evalCmd e2 (CWhile e c) e3 ->
        evalCmd e1 (CWhile e c) e3
.

(* Need to build a coinduction principle for evalCmd        *)
Theorem evalCmd_coind : forall (R:Env -> Cmd -> Env -> Prop),
    (forall (e1 e2:Env) (e:Exp) (v:Var),
        R e1 (CAssign v e) e2 -> e2 = update e1 v (evalExp e1 e))    ->
    (forall (e1 e3:Env) (c1 c2:Cmd),
        R e1 (CSeq c1 c2) e3 -> exists e2, R e1 c1 e2 /\ R e2 c2 e3) ->
    (forall (e1 e3:Env) (e:Exp) (c:Cmd),
        R e1 (CWhile e c) e3 -> (evalExp e1 e = 0 /\ e3 = e1) \/
        (exists (e2:Env),
            evalExp e1 e <> 0 /\ R e1 c e2 /\ R e2 (CWhile e c) e3)) ->
    (forall (e1 e2:Env) (c:Cmd), R e1 c e2 -> evalCmd e1 c e2).
Proof.
    intros R H1 H2 H3. cofix coIH. intros e1 e2 c H. destruct c.
    - apply H1 in H. rewrite H. constructor.
    - rename e2 into e3. apply H2 in H. destruct H as [e2 [H12 H23]].
      apply EvalSeq with e2; apply coIH; assumption.
    - rename e2 into e3. apply H3 in H. destruct H as [H|H].
        + destruct H as [E1 E2]. subst. apply EvalWhileFalse. assumption.
        + destruct H as [e2 [E1 [E2 E3]]]. apply EvalWhileTrue with e2.
            { assumption. }
            { apply coIH. assumption. }
            { apply coIH. assumption. }
Qed.

Fixpoint optExp (e:Exp) : Exp :=
    match e with
    | EPlus (EConst 0) e    => optExp e
    | EPlus e1 e2           => EPlus (optExp e1) (optExp e2)
    | _                     => e
    end.

Fixpoint optCmd (c:Cmd) : Cmd :=
    match c with
    | CAssign v e   => CAssign v (optExp e)
    | CSeq c1 c2    => CSeq (optCmd c1) (optCmd c2)
    | CWhile e c    => CWhile (optExp e) (optCmd c)
    end.

Lemma optExp_correct : forall (env:Env) (e:Exp),
    evalExp env (optExp e) = evalExp env e.
Proof.
    intros env. induction e as [n|v|e1 IH1 e2 IH2].
    - reflexivity.
    - reflexivity.
    - destruct e1 as [n1|v1|e1' e2'].
        + destruct n1 as [|n1].
            { simpl. assumption. }
            { simpl. rewrite IH2. reflexivity. }
        + simpl. rewrite IH2. reflexivity.
        + simpl in IH1. simpl. rewrite IH1, IH2. reflexivity.
Qed.

Lemma optCmd_correct1 : forall (e1 e2:Env) (c:Cmd),
    evalCmd e1 c e2 -> evalCmd e1 (optCmd c) e2.
Proof.
    intros e1 e2 c H.
    apply (evalCmd_coind (fun e1 c' e2 =>
        exists c, c' = optCmd c /\ evalCmd e1 c e2)).
    - clear e1 e2 c H. intros e1 e2 e v [c [H1 H2]]. revert e v H1.
      destruct H2.
        + intros e' v' H. simpl in H. inversion H. subst.
          rewrite optExp_correct. reflexivity.
        + intros e v H. simpl in H. inversion H.
        + intros e' v H'. simpl in H'. inversion H'.
        + intros e' v H'. simpl in H'. inversion H'.
    - clear e1 e2 c H. intros e1 e3 c1 c2 [c [H1 H2]].
      revert c1 c2 H1. destruct H2.
        + intros c1 c2 H. simpl in H. inversion H.
        + intros c3 c4 H. simpl in H. inversion H. subst.
          exists e2. split.
            { exists c1. split. { reflexivity. } { assumption. } }
            { exists c2. split. { reflexivity. } { assumption. } }
        + intros c1 c2 H'. simpl in H'. inversion H'.
        + intros c1 c2 H'. simpl in H'. inversion H'.
    - clear e1 e2 c H. intros e1 e3 e c [c' [H1 H2]].
      revert e c H1. destruct H2.
        + intros e' c H. simpl in H. inversion H.
        + intros e c H. simpl in H. inversion H.
        + intros e' c' H'. simpl in H'. inversion H'. subst.
          left. split.
            { rewrite optExp_correct. assumption. }
            { reflexivity. }
        + intros e' c' H'. simpl in H'. inversion H'. subst. right.
          exists e2. split.
            { rewrite optExp_correct. assumption. }
            { split.
                { exists c. split. { reflexivity. } { assumption. }}
                { exists (CWhile e c). split. { reflexivity. } { assumption. }}}
    - exists c. split.
        + reflexivity.
        + assumption.
Qed.

Lemma optCmd_correct2 : forall (e1 e2:Env) (c:Cmd),
    evalCmd e1 (optCmd c) e2 -> evalCmd e1 c e2.
Proof.
    apply (evalCmd_coind (fun e1 c e2 => evalCmd e1 (optCmd c) e2)).
    -  intros e1 e2 e v H. simpl in H.
       remember (CAssign v (optExp e)) as c' eqn:E.
       revert e v E. destruct H.
        + intros e' v' H. inversion H. subst. clear H.
          rewrite optExp_correct. reflexivity.
        + intros e v H'. inversion H'.
        + intros e' v H'. inversion H'.
        + intros e' v H'. inversion H'.
    - intros e1 e3 c1 c2 H. simpl in H.
      remember (CSeq (optCmd c1) (optCmd c2)) as c' eqn:E.
      revert c1 c2 E. destruct H.
        + intros c1 c2 H. inversion H.
        + intros c1' c2' H'. inversion H'. subst. clear H'. exists e2. split; assumption.
        + intros c1 c2 H'. inversion H'.
        + intros c1 c2 H'. inversion H'.
    - intros e1 e3 e c H. simpl in H.
      remember (CWhile (optExp e) (optCmd c)) as c' eqn:E.
      revert e c E. destruct H.
        + intros e' c H. inversion H.
        + intros e c H'. inversion H'.
        + intros e' c' H'. inversion H'. subst. clear H'. left. split.
            { rewrite optExp_correct in H. assumption. }
            { reflexivity. }
        + intros e' c' H'. inversion H'. subst. clear H'. right. exists e2. split.
            { rewrite optExp_correct in H. assumption. }
            { split; assumption. }
Qed.

Theorem optCmd_correct : forall (e1 e2:Env) (c:Cmd),
    evalCmd e1 (optCmd c) e2 <-> evalCmd e1 c e2.
Proof.
    intros e1 e2 c. split.
    - apply optCmd_correct2.
    - apply optCmd_correct1.
Qed.