(*|
==================
TAPFA - Partie Coq
==================

:Auteurs: Jean-Paul Bodeveix (resp. UE), Erik Martin-Dorel, Pierre Roux
:Date:    L3 Info, Semestre 6, Année 2021-2022

Supports de ce cours :

-  https://pfitaxel.github.io/tapfa-coq-alectryon/

Aperçu des fonctionnalités de Coq
=================================

Présentation du logiciel Coq
----------------------------

-  Implémenté en OCaml

.. image:: https://coq.inria.fr/files/barron_logo.png
   :alt: Coq
   :target: https://coq.inria.fr

-  Initié par Thierry Coquand et Gérard Huet, et développé par Inria
   depuis 1984 (la dernière version stable étant, lors de l'écriture de
   ce document, Coq 8.15.0).

.. image:: https://img.shields.io/docker/v/coqorg/coq/latest
   :alt: coq latest version
   :target: https://github.com/coq/coq/releases
|*)

(*|
-  Comprend un langage fonctionnel pur, statiquement typé, et
   *très expressif* (on détaillera cet aspect dans quelques minutes),
   muni d’un environnement de preuve interactive (vu au Cours n°2).

-  Coq a une grande communauté d’utilisateurs. Projets notables :

   -  CompCert : compilateur C99 complètement prouvé en Coq [Inria]

   -  C-CoRN : bibliothèque d’analyse constructive [à Nijmegen]

   -  Preuve formelle du théorème des 4 couleurs [G. Gonthier,
      B. Werner]

   -  MathComp : bibliothèque d’algèbre et preuve formelle du théorème
      de Feit–Thompson (la preuve papier fait :math:`{>}300` pages)
      [Inria, Microsoft Research]

   -  | Vérification de systèmes critiques (voir par exemple :
      | `<https://github.com/ligurio/practical-fm>`_)

   -  `FiatCrypto <https://github.com/mit-plv/fiat-crypto>`_ :
      "Simple High-Level Code For Cryptographic Arithmetic: With
      Proofs, Without Compromises" (*Implementations from our library
      were included in BoringSSL to replace existing specialized code,
      for inclusion in several large deployments for Chrome, Android,
      and CloudFlare.*)

-  Ouvrage (publié chez Springer et téléchargeable en français) :

   `Coq'Art: Interactive Theorem Proving and Program Development
   <http://www.labri.fr/perso/casteran/CoqArt/coqartF.pdf>`_
|*)

(*|
Caractéristiques intéressantes de Coq
-------------------------------------

-  langage fonctionnel pur proche d’OCaml

   -  terminaison garantie (impossible d’écrire ``let rec f x = f x``)

   -  typage fort et très expressif (on peut définir des listes à taille
      fixée, des fonctions à arité variable, etc.)

-  | langage logique (expression de formules quantifiées, etc.)
   | `forall n : nat, n > 0 -> exists m : nat, S m = n`

-  environnement de preuve (assistance à la construction de preuve)

-  | vérification automatique de la correction de ces preuves
   | vérification de preuve = vérification de type

-  | tactiques utilisateur pour automatiser les preuves :
   | `tauto` pour la logique des propositions,
   | `firstorder` pour la logique du premier ordre,
   | `lia` pour l’arithmétique linéaire sur les entiers
     (`2 * (n + 1) - n > n`)
   | etc.
|*)

Require Import Lia. (* pour utiliser la tactique "lia" *)

(*|
Rappel : installation de l’environnement de TP
----------------------------------------------

Environnement recommandé
~~~~~~~~~~~~~~~~~~~~~~~~

-  Coq 8.15 + Emacs + ProofGeneral + Company-Coq
   [cf. `tutoriel <https://github.com/erikmd/tapfa-init.el>`_]

-  Carte de référence / raccourcis clavier [cf. Moodle]

-  Dictionnaire OCaml/Coq [cf. Moodle ; autorisé à l'examen a priori]

Tutoriel d’installation
~~~~~~~~~~~~~~~~~~~~~~~

- avec OPAM, sous GNU/Linux, macOS ou Windows 10 :

  `<https://github.com/erikmd/tapfa-init.el>`_

-  à installer avant le 1er TP TAPFA-Coq

-  avant cela, jsCoq peut être utilisé dans votre navigateur :

  `<https://jscoq.github.io/scratchpad.html>`_

-  n’hésitez pas à poser des questions sur Moodle
|*)

(*|
Utilisations possibles de Coq
-----------------------------

-  Synthèse du type d’une expression :
|*)

Check fun x y => x + y + 1.
(* .unfold *)

(*|
-  Évaluation d’expressions (calcul) :
|*)

Eval compute in (fun x y => x+y+1) 2 3.
(* .unfold *)

(*|
-  Implantation de fonctions et vérification de leurs propriétés :
|*)

Definition f x := x + 2.

Theorem f_croissante : forall x y : nat, x < y -> f x < f y.
Proof.
(* On ne détaille pas pour le moment le script de preuve => Cours 2 *)
intros x y; unfold f; lia. (* .none *)
Qed.

(*|
- Définition de sous-types :
|*)

Definition Mod3 := {x : nat | x < 3}.

(*|
-  Synthèse de fonctions à partir d’une preuve de sa spécification :
|*)

Definition pred :
  forall n : nat, (* précond *) n > 0 ->
    {m : nat | (* postcond *) S m = n}.
Proof.
(* On ne détaille pas pour le moment le script de preuve *)
destruct n as [|n'];
  [ lia
  | intros _; exists n'; reflexivity]. (* .none *)
Defined.

Require Extraction.
(* Génération automatique de code OCaml à partir du code Coq prouvé *)
Recursive Extraction pred. (* .unfold *)

(*|
Motivations pour utiliser Coq
=============================

Positionnement de Coq par rapport aux types abstraits
-----------------------------------------------------

Par rapport à PFITA
~~~~~~~~~~~~~~~~~~~

-  **explicitation des axiomes** dans la spécification des types abstraits

-  **preuve formelle** que l'implémentation satisfait bien la spécification

-  compilation et **vérification** modulaire possible

   (implémentation et **vérification** d'un composant utilisateur
   indépendemment de l'implémentation du composant utilisé)

-  donc : plus besoin de tests unitaires ou d'intégration...

-  mais : Toujours besoin de **validation** de l'implémentation par
   rapport aux exigences attendues (qui peuvent différer des exigences
   exprimées dans le cahier des charges !)

   Voir aussi : la notion de `V & V <https://en.wikipedia.org/wiki/V%20&%20V>`_
|*)

(*|
Exemple de vérification modulaire
---------------------------------

-  Définition d'une signature
|*)

Module Type tPickGt.
  Parameter pick : nat -> nat.
  Axiom pick_gt : forall n, pick n > n.
End tPickGt.

(*|
-  Implantation de la signature
|*)

Module PickGt <: tPickGt. (* vérif conformité sans masquage *)
  Definition pick n := S n.
  Lemma pick_gt : forall n, pick n > n.
  Proof. auto. Qed.
End PickGt.

(*|
-  Utilisation d'un module respectant la signature
|*)

Module Use (P : tPickGt).
  Definition num := P.pick O.
  Lemma num_gt0 : num > O.
  Proof. apply P.pick_gt. Qed.
End Use.

(*|
-  Instantiation du module paramétré
|*)

Module M := Use(PickGt).

(*|
Introduction à Coq
==================

Types et expressions
--------------------

| À retenir :
| En Coq, tout terme bien formé a un type (y compris les types !)
| donc contrairement à OCaml, les termes/expressions et les types ne
  forment pas deux "collections disjointes"

Exemples d’expressions Coq et leur type
---------------------------------------

+------------------+--------------+--------------+-------------+
| valeur/programme | type         | type de type | …           |
+==================+==============+==============+=============+
| `0`              | `nat`        | Set          | …           |
+------------------+--------------+--------------+-------------+
| `true`           | `bool`       | Set          | …           |
+------------------+--------------+--------------+-------------+
| `fun x => x + 1` | `nat -> nat` | Set          | …           |
+------------------+--------------+--------------+-------------+
|*)

Check 0.
(* .unfold *)
Check true.
(* .unfold *)
Check fun x => x + 1.
(* .unfold *)
Check nat.
(* .unfold *)
Check Set.
(* .unfold *)

(*|
Exemples avancés d’expressions Coq et leur type
-----------------------------------------------

+------------------------+------------------+--------------+-------------+
| valeur/programme       | type             | type de type | …           |
+========================+==================+==============+=============+
| `list`                 | `Type -> Type`   | `Type`       | …           |
+------------------------+------------------+--------------+-------------+
| "preuve de `2<=2`"     | `2 <= 2`         | `Prop`       | …           |
+------------------------+------------------+--------------+-------------+
| "(1; preuve de `1>0`)" | `{x: nat | x>0}` | `Set`        | …           |
+------------------------+------------------+--------------+-------------+
|*)

Check 2 <= 2.
(* .unfold *)
Check le 2 2.
(* .unfold *)
Check le_n 2.
(* .unfold *)
Check le_n.
(* .unfold *)
Check le.
(* .unfold *)
(* Prop est le type des formules logiques *)
Check Prop.
(* .unfold *)

(*|
Remarques
---------

-  `Prop` est le type des formules logiques ;

-  à ne pas confondre avec `bool`, le type des booléens.

Les deux ont leur utilité :

-  les prédicats renvoyant un `bool` correspondent à des "prédicats calculables"
   (par exemple un algorithme décidant si un entier est pair ou pas) :
   on peut déterminer leur résultat par un *calcul* ;

-  les prédicats renvoyant un `Prop` correspondent à des "prédicats logiques"
   (définis par une formule) :
   on peut prouver leur véracité par un *raisonnement*.
|*)

(*|
Le type des listes : comparaison OCaml / Coq
--------------------------------------------

+-----------------------------------+------------------------------------------+
| OCaml                             | Coq                                      |
+===================================+==========================================+
| `'a list`                         | `list a`                                 |
+-----------------------------------+------------------------------------------+
| `bool list`                       | `list bool`                              |
+-----------------------------------+------------------------------------------+
| notation spéciale, mais familière | `list` est une fonction : `Type -> Type` |
+-----------------------------------+------------------------------------------+
|*)

Check list.
(* .unfold *)

(*|
Éléments de syntaxe
-------------------

-  Les mots "terme" et "expression" sont synonymes.

- | Rappel :
  | En Coq, tout terme bien formé a un type (y compris les types !) ;
  | contrairement à OCaml, les termes/expressions et les types ne
    forment pas deux "collections disjointes" ;
  | donc la grammaire des termes ci-dessous contient aussi Type, Set, Prop :

.. code-block:: Coq

   terme ::= Type | Set | Prop           "sortes" (= types de type)
           | var                         "variable"
           | ( terme )
           | terme terme                 "application"
           | terme op terme              "opérateur infixe"
           | fun var : terme ⇒ terme     "abstraction"
           | let var := terme in terme   "définition locale"
           | if terme then terme else terme
           | terme -> terme              "type flèche" (= type des fonctions)

|*)

(*|
Exemples
--------

Que renvoient les commandes suivantes ?
|*)

Check fun x => x + 1.

Check (fun f x => f (f x)) (fun x => x + 1).

Eval compute in (fun f x => f (f x)) (fun x => x + 1) 3.

Definition f1 := fun x => x + 1. Eval compute in f1 0.

Definition double f := fun (x : nat) => f (f x). Check double.

Definition double2 (f : nat -> nat) := fun x => f (f x). Check double2.

Fail Definition double3 f := fun x => f (f x).

(*|
Cette dernière définition est refusée car en Coq, les *paramètres de
généricité* sont explicites. Pas de synthèse automatique de leur nom ;
il faut expliciter ces arguments.
|*)

(*|
Généricité
----------

Une fonction générique prend un type en paramètre.

Exemple de définition d'une fonction générique : la fonction identité.
|*)

Definition id := fun (T : Type) => fun (x : T) => x.
(* ou *)
Definition id_v2 := fun (T : Type) (x : T) => x.
(* ou *)
Definition id_v3 (T : Type) := fun (x : T) => x.
(* ou *)
Definition id_v4 (T : Type) (x : T) := x.
(* ou *)
Definition id_v5 T (x : T) := x.

(*| :math:`\leadsto` ces fonctions ont toutes 2 arguments ! *)

(*|
Utilisation d’une fonction générique
|*)

Check id nat.
(* .unfold *)
Check id nat 0.
(* .unfold *)
Check id bool.
(* .unfold *)
Check id bool true.
(* .unfold *)

Print id.
(* .unfold *)

(*|
Généricité et typage
--------------------

Type d’une fonction générique

-  En OCaml : ``id : 'a -> 'a`` :math:`\leadsto` pour tout type ``'a``,
   id prend un argument de type ``'a`` et retourne un résultat de
   type ``'a``

-  En Coq : `id : forall a, a -> a` :math:`\leadsto` la quantification
   est explicite

-  extension du langage des termes :

.. code-block:: Coq

   terme ::= Type | Set | Prop
           | var
           | ( terme )
           | terme terme
           | terme op terme
           | fun var : terme ⇒ terme
           | let var := terme in terme
           | if terme then terme else terme
           | terme -> terme             (type d'une fonction)
           | forall var : terme, terme  (type d'une fonction générique)

- | Comme on le verra par la suite, `t1 -> t2` est en fait
  | une syntaxe alternative (plus intuitive) de "`forall _ : t1, t2`".
|*)

Check id.
(* .unfold *)

(*|
Inférence d'arguments
---------------------

Dans le terme `id bool true` ci dessus, Coq pourrait deviner
automatiquement le premier argument `bool` puisque c'est le type
du deuxième argument `true` d'après le type de `id`. Il est
effectivement possible d'écrire
|*)
Check id _ true.
(* .unfold *)
(*|
Coq remplace automatiquement le `_` par la seule valeur possible `bool`.

On peut ainsi remplacer tout sous terme par un trou `_` et laisser Coq
tenter de le remplir. Coq retourne une erreur quand il ne trouve pas
de solution canonique.
|*)
Fail Definition id_bool := id bool _.

(*|
Généricité et arguments implicites I
------------------------------------

Les remarques qui suivent ne sont pas "exigibles à l'examen" mais
permettront d'avoir plus de confort, notamment en TP, en évitant de
devoir expliciter tous les paramètres de généricité lors de l'appel
d'une fonction polymorphe.

Les arguments implicites permettent d'écrire `id true` au lieu de `id _ true`.
Redéfinissons la fonction id après activation des arguments implicites
|*)

Set Implicit Arguments. (* au début du fichier en principe *)

Definition id' (T : Type) (x : T) := x.
Print id'.
(* .unfold *)

(* même code que *)
Print id.
(* .unfold *)

(* mais *)
About id'.
(* id' : forall [T : Type], T -> T *)
(*|
(:math:`\leadsto` noter le [T] au lieu de T)

L'argument T est implicite : il peut être inféré à partir de l'argument d'après.

D'où une syntaxe concise à la OCaml :
|*)

Check id' true.
(* .unfold *)

Set Printing All. (* affiche tout, dont les arguments implicites *)
Check id' true.
(* .unfold *)
(*|
Le `@` indique que tous les arguments de `id'` sont explicités.
Grâce aux arguments implicites, entrer `id' true` est equivalent à entrer
|*)
Check @id' _ true.
(* .unfold *)
Unset Printing All.

(*|
Généricité et arguments implicites II
-------------------------------------

En OCaml :

``let id x = x;;``

``id 0;; (* : int = 0 *)``

``id true;; (* : bool = true *)``

En Coq :

`Set Implicit Arguments.`

`Definition id T (x:T) := x.`

`Check id 0. (* id 0 : nat *)`

`Check id true. (* id true : bool *)`
|*)

(*|
Paramètres de généricité : un plus gros exemple
-----------------------------------------------

En OCaml :

``let comp f g x = g (f x);;``

``val comp : (’a -> ’b) -> (’b -> ’c) -> ’a -> ’c = <fun>``

``comp (fun x -> x + 1) (fun x -> x * 2) 3;;``

:math:`\leadsto` ?

En Coq :

Pas de synthèse du nom des paramètres de généricité : il faut
déclarer ces paramètres de généricité lors de la définition.
|*)

(* Set Implicit Arguments. (* déjà fait auparavant *) *)

Definition comp T1 T2 T3 (f:T1->T2) (g:T2->T3) (x : T1) : T3 := g (f x).
(* ou *)
Definition comp_v2 T1 T2 T3 (f:T1->T2) (g:T2->T3) (x : T1) := g (f x).
(* ou *)
Definition comp_v3 T1 T2 T3 (f:T1->T2) (g:T2->T3) x := g (f x).
(* ou *)
Definition comp_v4 T1 T2 T3 f (g:T2->T3) (x:T1) := g (f x).
(* ou *)
Definition comp_v5 T1 T2 T3 (f:T1->T2) g (x:T1) : T3 := g (f x).

Eval compute in comp (fun x => x + 1) (fun x => x * 2) 3.

(*|
Exercices
---------

1. Ecrire la fonction ``mult2`` retournant le double de son argument.
|*)

Definition mult2 := (* todo *)0.

(*|
2. | **Supposons défini** le prédicat `leq : nat -> nat -> bool`,
     retournant `true` si son 1er argument est inférieur à son second.
   | Définir la fonction ``max`` retournant le plus grand de ses 2 arguments.
   | En déduire la fonction ``max3`` retournant le plus grand de ses 3 arguments.
   | Ecrire une variante ``max3'`` où la définition de ``max`` est locale.
|*)

Parameter leq : nat -> nat -> bool.

Definition max := (* todo *)0.

Definition max3 := (* todo *)0.

Definition max3' := (* todo *)0.

(*|
3. Quel est le type de l'expression suivante ?
|*)

Definition expr3 := fun (T:Type) (f:T -> T) x => f (f x).
(* *)

(*|
4. Quel est le type de l'expression suivante ? (donner 2 syntaxes équivalentes)
|*)

Definition expr4 := fun (T:Type) => T -> T.

(*|
5. Quel est le type de l'expression suivante ?
|*)

Definition expr5 := fun (T:Type) (x:T) => x=x.

(*|
6. Écrire une fonction de type `forall a b : Type, a -> b -> a`
|*)

Definition expr6 := (* todo *)0.

(*|
7. Écrire une fonction de type `forall a b : Type, a -> (a -> b) -> b`
|*)

Definition expr7 := (* todo *)0.

(*|
8. Écrire une fonction de type
`forall a b c : Type, (a -> b -> c) -> (a -> b) -> a -> c`
|*)

Definition expr8 := (* todo *)0.

(*|
9. Écrire une fonction de type `forall a b c : Type, (a -> c) -> (a -> b -> c)`
|*)

Definition expr9 := (* todo *)0.

(*|
10. Écrire une fonction de type
`forall a b c : Type, (a -> b -> c) -> b -> a -> c`
|*)

Definition expr10 := (* todo *)0.

(*|
11. Écrire une fonction de type `forall a b : Type, (a -> a -> b) -> a -> b`
|*)

Definition expr11 := (* todo *)0.

(*|
12. Peut-on écrire une fonction de type `forall a b : Type, a -> b` ?
|*)

(* En OCaml :

   let exemple =

 *)

(* En Coq ? *)

(*|
Retour sur `->` et `forall`
---------------------------

`T1 -> T2` correspond :

-  au type des fonctions de `T1` dans `T2`, c’est-à-dire

-  au type des fonctions qui associent à tout `x:T1` un élément de `T2`,

-  que l’on peut aussi écrire `forall (x : T1), T2`

`forall` est une notation :

-  généralisant `->`,

-  utile lorsque le type d’arrivée `T2` dépend du terme fourni `x`.

Exemples de types définissables en Coq
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-  `forall (T : Type), T -> T`

-  `forall (p q : nat), q <> 0 -> nat`

-  `forall (b : bool), if b then nat else bool * bool`
|*)

(*|
La correspondance de Curry–Howard : double lecture
--------------------------------------------------

+---------------+------------------------------------+------------------------+
| Notation      | Lecture fonctionnelle              | Lecture logique        |
+===============+====================================+========================+
| `x : T`       | `x` a pour type `T`                | `x` "preuve" de `T`    |
+---------------+------------------------------------+------------------------+
| *aucun* `x:T` | le type `T` est vide               | `T` est insatisfiable  |
+---------------+------------------------------------+------------------------+
| `P -> Q`      | type des fonctions de `P` dans `Q` | l'implication logique  |
+---------------+------------------------------------+------------------------+
| `f : P -> Q`  | f est une fonction de `P` dans `Q` | f preuve de ``P => Q`` |
+---------------+------------------------------------+------------------------+
|               | f transforme une "preuve" de `P` en une "preuve" de `Q`     |
+---------------+-------------------------------------------------------------+
|*)

(*|
Types inductifs
---------------

Définition d’un type inductif paramétré par ``a1,...,am``.

En OCaml :

.. code-block:: OCaml

   type ('a1, ..., 'am) t =     (* m paramètres de généricité *)
     | C1 of t1_1 * ... * t1_n1 (* constructeur C1 d'arité n1 *)
     | ...
     | Ck of tk_1 * ... * tk_nk (* kième constructeur *)

En Coq :

.. code-block:: Coq

   Inductive t a1 ... am :=
     | C1 (p1 : t1_1) ... (pn1 : t1_n1)
     | ...
     | Ck (p1 : tk_1) ... (pnk : tk_nk). (* ne pas oublier le point *)
|*)

(*|
Analyse par cas
---------------

En OCaml :

.. code-block:: OCaml

   match x with
   | C1 (x1, ..., xn1) -> ...
   | ...
   | Ck (x1, ..., xnk) -> ...

En Coq :

.. code-block:: Coq

   match x with
   | C1 x1 ... xn1 => ...
   | ...
   | Ck x1 ... xnk => ...
   end

Différences :

-  Les constructeurs sont typiquement "curryfiés" en Coq.

-  Les `->` sont remplacées par `=>`

-  Il y a un `end` en plus (pratique)

-  Sinon c'est la même syntaxe :-)
|*)

(*|
Exemples de types inductifs
---------------------------

Type de données prédéfini dans Coq :
|*)
Print bool.
(* .unfold *)

Inductive entier_nat := Zero | Succ (p : entier_nat).
Inductive liste T := Vide | Cons (x : T) (l : liste T).

(*|
Eléments d’un type inductif :
|*)

Check true.
(* .unfold *)

Check (Succ (Succ Zero)).
(* .unfold *)

Definition liste1 := @Cons entier_nat (Succ Zero) (Vide entier_nat).
Print liste1.
(* .unfold *)

(*|
Fonctions récursives
--------------------

| **Obligation de terminaison :**
| un des arguments doit être *structurellement décroissant*
| (appels récursifs sur un sous-terme de cet argument)

| Comme déjà dit en introduction :
| il est impossible de définir en Coq une fonction récursive qui ne termine pas.
|*)

Fixpoint add n m :=
  match n with
  | Zero => m
  | Succ p => Succ (add p m)
  end.

Fixpoint long T (l : liste T) :=
  match l with
  | Vide _ => Zero
  | Cons x r => Succ (long r)
  end.

(*|
Est-ce normal d'écrire `Cons x r => Succ (long r)` ?

Précisons :

- Le constructeur `Cons` a trois arguments,

- La fonction `long` a 2 arguments...

- Mais on avait activé les arguments implicites : `Set Implicit Arguments`.

- On pourrait néanmoins écrire en étant pleinement explicite :
|*)

Fixpoint long_v2 T (l : liste T) :=
  match l with
  | Vide _ => Zero
  | @Cons _ x r => Succ (@long_v2 T r)
  end.

Eval compute in long_v2 liste1.

(*|
**Remarque:**
Coq n'est pas limité aux fonctions primitives récursives. Par exemple, la `fonction d'Ackermann <https://mathworld.wolfram.com/AckermannFunction.html>`_ peut être définie comme ci-dessous et il serait possible de démontrer qu'elle est identique à la définition usuelle:

.. image:: https://mathworld.wolfram.com/images/equations/AckermannFunction/NumberedEquation1.svg
|*)

Fixpoint pow (f:nat->nat) n a :=
  match n with
    0 => a
  | S p => pow f p (f a)
  end.

Fixpoint ack a b : nat :=
match a with
| 0 => S b
| S a => pow (ack a) (S b) 1
end.

Eval compute in (ack 3 4).

(*|
Schémas inductifs
-----------------

Preuve par récurence sur les entiers naturels (construits avec Zero, Succ)

Est-ce que la fonction suivante (ou son type) vous rappellent quelque chose ?

.. code-block:: Coq

   Fixpoint entier_nat_ind (P : entier_nat -> Prop)
   (fZero : P Zero) (fSucc : forall n : entier_nat, P n -> P (Succ n))
   (n : entier_nat) : P n :=
     match n with
     | Zero => fZero
     | Succ n => fSucc n (entier_nat_ind P fZero fSucc n)
     end.

qui a pour type :
|*)

Check entier_nat_ind.
(* .unfold *)

(*|
Il s'agit du "Principe d’induction" pour les entiers naturels, généré
automatiquement par Coq.

(Et il se trouve que le "code" qui implémente ce principe correspond à
l'itérateur le plus général sur le type `entier_nat` :)

Le type en question est donc :

.. code-block:: Coq

   forall P : entier_nat -> Prop, P Zero ->
     (forall n : entier_nat, P n -> P (Succ n))
   -> forall n : entier_nat, P n.
|*)

(*|
Un peu d’intuition sur ce principe d’induction
----------------------------------------------

-  Hypothèses :

   -  pZero : preuve de P Zero
   -  pSucc : preuve de :math:`\forall n,\ P n \implies P (n+1)`

-  Conclusion :

   -  :math:`\forall n,\ P n`

On peut l'écrire sous la forme d'une "Règle d'inférence" :

.. code-block:: Coq

   (pZero : P Zero)  (pSucc : forall n : entier_nat, P n -> P (Succ n))
   --------------------------------------------------------------------
        entier_nat_ind P pZero pSucc :  forall n : entier_nat, P n
|*)

(*|
L'effet domino
--------------

Une petite image vaut mieux qu'un long discours :

.. image:: https://upload.wikimedia.org/wikipedia/commons/9/92/Dominoeffect.png
   :alt: CC BY-SA 3.0
   :target: https://commons.wikimedia.org/wiki/File:Dominoeffect.png
|*)

(*|
Le type inductif des listes (prédéfini)
---------------------------------------
|*)

Require Import List.
Import ListNotations.
(* Set Implicit Arguments. (* déjà fait auparavant *) *)

Check list.
(* .unfold *)

Print list.
(* .unfold *)

(*|
.. code-block:: Coq

   Fixpoint list_ind T (P : list T -> Prop)
   (pNil : P nil) (pCons : forall x l, P l -> P (x :: l)) l
   : P l :=
     match l with
     | [] => pNil
     | x :: r => pCons x r (@list_ind T P pNil pCons r)
     end.

Généré automatiquement !

Permet la "preuve par induction" sur les listes (construites avec `[]` et `::`)
|*)

(*|
Règle d'inférence du schéma inductif des listes
-----------------------------------------------

.. code-block:: Coq

   (pNil : P [])  (pCons : forall x l, P l -> P (x :: l))
   ------------------------------------------------------
           list_ind P pNil pCons :  forall l, P l

Ici, on a omis les types implicites (le param. de généricité T) par simplicité.
|*)

(*|

Correspondance entre les types et les formules logiques
-------------------------------------------------------

La correspondance de Curry–Howard : double lecture
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+--------------------+--------------------------------+------------------------+
| Notation           | Lecture fonctionnelle          | Lecture logique        |
+====================+================================+========================+
| `x : T`            | `x` a pour type `T`            | `x` "preuve" de `T`    |
+--------------------+--------------------------------+------------------------+
| *aucun* `x:T`      | le type `T` est vide           | `T` est insatisfiable  |
+--------------------+--------------------------------+------------------------+
| `P -> Q`           | type des fonctions de P dans Q | l'implication logique  |
+--------------------+--------------------------------+------------------------+
| `f : P -> Q`       | f est une fonction de P dans Q | f preuve de ``P => Q`` |
+--------------------+--------------------------------+------------------------+
|                    | f transforme une "preuve" de P en une "preuve" de Q     |
+--------------------+--------------------------------+------------------------+
| `forall T, T -> T` | type générique de l'identité   | exemple de tautologie  |
+--------------------+--------------------------------+------------------------+
| `forall n, n+1 > n`| fonction associant à chaque    | quantification         |
|                    | entier une preuve              | universelle            |
+--------------------+--------------------------------+------------------------+
| `forall x : X, P x`| fonction dont le type          | ∀x∈X, P x              |
|                    | d'arrivée dépend de l'argument |                        |
+--------------------+--------------------------------+------------------------+

| Remarque :
| en Coq et contrairement à la "théorie des ensembles",
| toutes les variables quantifiées sont associées à un type (qui peut
  cependant être inféré :)
|*)

Check forall n, n + 1 > n.
(* .unfold *)

(*|
Exemple de types inductifs : propositions logiques
--------------------------------------------------

La Conjonction
~~~~~~~~~~~~~~

.. code-block:: Coq

   Inductive and (P Q : Prop) : Prop :=
     Conj (p : P) (q : Q).

   -->

     (p : P)  (q : Q)
   --------------------
    Conj p q :  P /\ Q

La Disjonction
~~~~~~~~~~~~~~

.. code-block:: Coq

   Inductive or (P Q: Prop): Prop :=
     | Or1 (p: P)
     | Or2 (q: Q).

   -->

         p : P              q : Q
   -----------------  -----------------
    Or1 p :  P \/ Q    Or2 q :  P \/ Q
|*)

(*|
La proposition True
~~~~~~~~~~~~~~~~~~~

.. code-block:: Coq

   Inductive True : Prop := I.  -->  ----------
                                      I : True

La proposition False
~~~~~~~~~~~~~~~~~~~~

.. code-block:: Coq

   Inductive False : Prop := .  -->  pas de preuve de `False` !
|*)

(*|
Et la quantification existentielle ?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

.. code-block:: Coq

   Inductive ex T (P: T -> Prop) :=
     ex_intro (t: T) (p: P t).

   -->

             (t : T)  (p : P t)
   ----------------------------------------
    @ex_intro T P t p :  exists x : T, P x
|*)

(*|
À suivre au prochain cours
--------------------------

- Retour sur la correspondance de Curry-Howard
- | Présentation des "tactiques Coq"
  | pour construire une preuve interactivement/semi-automatiquement !
|*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B S MA : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ E O /\ (wd_ S O /\ (wd_ S B /\ (wd_ MA O /\ (wd_ MA B /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E S /\ col_ O E MA)))))))))))) -> col_ S O B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Bprime : Universe, ((wd_ A P /\ (wd_ A C /\ (wd_ P C /\ (wd_ P B /\ (wd_ P D /\ (wd_ A B /\ (wd_ A D /\ (wd_ B Bprime /\ (wd_ A Bprime /\ (wd_ C D /\ (col_ B A C /\ (col_ B A Bprime /\ col_ P A C)))))))))))) -> col_ P A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj29eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 (plus Zero lv0))).
Admitted.
QuickChick conj29eqsynthconj4.


Require Import Iron.Language.SimplePCF.Preservation.
Require Export Iron.Language.SimplePCF.SubstExpExp.
Require Export Iron.Language.SimplePCF.Step.
Require Export Iron.Language.SimplePCF.Ty.
Require Export Iron.Language.SimplePCF.Exp.

(* Big Step Evaluation.
   This is also called 'Natural Semantics'.
   It provides a relation between the expression to be reduced
   and its final value. *)
Inductive EVAL : exp -> exp -> Prop :=

 (* Values are already evaluated ******)
 | EvDone
   :  forall v2
   ,  wnfX v2
   -> EVAL v2 v2

 (* Function Applications *************)
 | EvLamApp
   :  forall x1 t11 x12 x2 v2 v3
   ,  EVAL x1 (XLam t11 x12) -> EVAL x2 v2 -> EVAL (substX 0 v2 x12) v3
   -> EVAL (XApp x1 x2) v3

 (* Fixpoint recursion ****************)
 | EvFix
   :  forall t11 x12 v3
   ,  EVAL (substX 0 (XFix t11 x12) x12) v3
   -> EVAL (XFix t11 x12) v3

 (* Naturals **************************)
 | EvSucc
   :  forall x1 n
   ,  EVAL x1 (XNat n)
   -> EVAL (XSucc x1) (XNat (S n))

 | EvPredZero
   :  forall x1
   ,  EVAL x1 (XNat O)
   -> EVAL (XPred x1) (XNat O)

 | EvPredSucc
   :  forall x1 n
   ,  EVAL x1 (XNat (S n))
   -> EVAL (XPred x1) (XNat n)

 (* Booleans **************************)
 | EvIsZeroTrue
   :  forall x1
   ,  EVAL x1 (XNat O)
   -> EVAL (XIsZero x1) XTrue

 | EvIsZeroFalse
   :  forall x1 n
   ,  EVAL x1 (XNat (S n))
   -> EVAL (XIsZero x1) XFalse

 (* Branching *************************)
 | EvIfThen
   :  forall x1 x2 x3 v2
   ,  EVAL x1 XTrue -> EVAL x2 v2
   -> EVAL (XIf x1 x2 x3) v2

 | EvIfElse
   :  forall x1 x2 x3 v3
   ,  EVAL x1 XFalse -> EVAL x3 v3
   -> EVAL (XIf x1 x2 x3) v3.

Hint Constructors EVAL.

(* A terminating big-step evaluation always produces a whnf.
   The fact that the evaluation terminated is implied by the fact
   that we have a finite proof of EVAL to pass to this lemma. *)
Lemma eval_produces_wnfX
 :  forall x1 v1
 ,  EVAL   x1 v1
 -> wnfX  v1.
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve eval_produces_wnfX.

(********************************************************************)
(* Big to Small steps.
   Convert a big-step evaluation into a list of individual
   machine steps. *)
Lemma steps_of_eval
 :  forall x1 t1 x2
 ,  TYPE nil x1 t1
 -> EVAL  x1 x2
 -> STEPS x1 x2.
Proof.
 intros x1 t1 v2 HT HE.
 gen t1.
 induction HE;
  intros;
  inverts keep HT; eauto;

  (* This gets simple expressions with a single context *)
  try (  eapply EsAppend ;
       [ eapply steps_context ; [ eauto | eapply IHHE ; eauto ]
       | eauto ]).

 - lets E1: IHHE1 H2.
   lets E2: IHHE2 H4.
   lets T1: preservation_steps H2 E1. inverts keep T1.
   lets T2: preservation_steps H4 E2.
   lets T3: subst_exp_exp H1 T2.
   lets E3: IHHE3 T3.
   eapply EsAppend.
    lets D: steps_context XcApp1. eapply D. eauto.
   eapply EsAppend.
    eapply steps_context; eauto.
   eapply EsAppend.
    eapply EsStep.
      eapply EsLamApp. eauto. eauto.

 - lets T1: subst_exp_exp H3 HT.
   lets E1: IHHE T1.
   eapply EsAppend.
    eapply EsStep.
     eapply EsFix. eauto.

 - lets S1: IHHE1 H3.
   lets S2: IHHE2 H5.
   eapply EsAppend.
    eapply (steps_context (fun xx => XIf xx x2 x3)); eauto.
    eauto.

 - lets S1: IHHE1 H3.
   lets S2: IHHE2 H6.
   eapply EsAppend.
    eapply (steps_context (fun xx => XIf xx x2 x3)); eauto.
    eauto.
Qed.

(********************************************************************)
(* Small to Big steps.
   Convert a list of individual machine steps to a big-step
   evaluation. The main part of this is the expansion lemma, which
   we use to build up the overall big-step evaluation one small-step
   at a time. The other lemmas are used to feed it small-steps.
 *)

(* Given an existing big-step evalution, we can produce a new one
   that does an extra step before returning the original value.
 *)
Lemma eval_expansion
 :  forall te x1 t1 x2 v3
 ,  TYPE te x1 t1
 -> STEP x1 x2 -> EVAL x2 v3
 -> EVAL x1 v3.
Proof.
 intros te x1 t1 x2 v3 HT HS. gen te t1 v3.
 induction HS; intros;
  try (solve [inverts H; eauto]); eauto.

 - destruct H.
    eauto.
    inverts HT; inverts H0; try (inverts H); eauto.
    inverts HT; inverts H0; try (inverts H1); eauto.
    inverts HT; inverts H0; try (inverts H); eauto.
    inverts HT; inverts H0; try (inverts H); eauto.
    inverts HT; inverts H0; try (inverts H); eauto.
    inverts HT; inverts H0; try (inverts H); eauto.
Qed.

(* Convert a list of small steps to a big-step evaluation. *)
Lemma eval_of_stepsl
 :  forall x1 t1 v2
 ,  TYPE nil x1 t1
 -> STEPSL x1 v2 -> value v2
 -> EVAL   x1 v2.
Proof.
 intros x1 t1 v2 HT HS HV.
 induction HS; burn.

 - eapply eval_expansion;
    burn using preservation.
Qed.

(* Convert a multi-step evaluation to a big-step evaluation.
   We use stepsl_of_steps to flatten out the append constructors
   in the multi-step evaluation, leaving a list of individual
   small-steps. *)
Lemma eval_of_steps
 :  forall x1 t1 v2
 ,  TYPE nil x1 t1
 -> STEPS x1 v2 -> value v2
 -> EVAL  x1 v2.
Proof.
 intros.
 eapply eval_of_stepsl; burn.
  apply  stepsl_of_steps; burn.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect eqtype ssrbool.

Variable T : Type.
Variables P : T -> Prop.

Definition f := fun x y : T => x.

Lemma test1 : forall x y : T, P (f x y) -> P x.
Proof.
move=> x y; set fxy := f x y; move=> Pfxy.
wlog H : @fxy Pfxy / P x.
  match goal with |- (let fxy0 := f x y in P fxy0 -> P x -> P x) -> P x => by auto | _ => fail end.
exact: H.
Qed.

Lemma test2 : forall x y : T, P (f x y) -> P x.
Proof.
move=> x y; set fxy := f x y; move=> Pfxy.
wlog H : fxy Pfxy / P x.
  match goal with |- (forall fxy, P fxy -> P x -> P x) -> P x => by auto | _ => fail end.
exact: H.
Qed.

Lemma test3 : forall x y : T, P (f x y) -> P x.
Proof.
move=> x y; set fxy := f x y; move=> Pfxy.
move: {1}@fxy (Pfxy) (Pfxy).
match goal with |- (let fxy0 := f x y in P fxy0 -> P fxy -> P x) => by auto | _ => fail end.
Qed.

Lemma test4 : forall n m z: bool, n = z -> let x := n in x = m && n -> x = m && n.
move=> n m z E x H.
case: true.
  by rewrite  {1 2}E in (x) H |- *.
by rewrite {1}E in x H |- *.
Qed.


Require Import Extraction.
From Coq Require Import Init.Datatypes.

Module boom.
(* Adapted from S. Glondu, Vers une certification de l’extraction de Coq
 * https://stephane.glondu.net/these/memoire.pdf
 *)

Definition G {A : Type} (x : A) (X : (A -> A) * True) :=
  (fst X x, O).

(* Extracts to Haskell but crashes at runtime *)
Definition boom_true :=
  G I ((fun x => x), I).

Definition boom_unit :=
  G tt ((fun x => x), I).

End boom.

Module sigmas.
(* From https://github.com/coq/coq/issues/10749 *)

(* Erased during extraction  *)
Definition prop_and_prop : { n: True & True } :=
  existT (fun _ : True => True) I I.

(* Extracted: ExistT (__, Tt) *)
Definition prop_and_type : { n: True & unit } :=
  existT (fun _ : True => unit) I tt.

(* Extracted: ExistT (Tt, __) *)
Definition type_and_prop : { n: unit & True } :=
  existT (fun _ : unit => True) tt I.

(* Extracted: ExistT (Tt, Tt) *)
Definition type_and_type : { n: unit & unit } :=
  existT (fun _ : unit => unit) tt tt.

(* all of these are extracted as Pair __ __ *)
Definition pair_unit_unit := (unit, unit).
Definition pair_true_unit := (True, unit).
Definition pair_Type_Type := (Prop, Type).
Definition pair_Prop_Type := (Prop, Type).

End sigmas.

(** Extraction **)

Extraction Language OCaml.
Fail Extraction boom.
(* The informative inductive type prod has a Prop instance
 * in boom.boom_true (or in its mutual block).
 * This happens when a sort-polymorphic singleton inductive type
 * has logical parameters, such as (I,I) : (True * True) : Prop.
 * The Ocaml extraction cannot handle this situation yet.
 * Instead, use a sort-monomorphic type such as (True /\ True)
 * or extract to Haskell.
 *)

Extraction Language Haskell.
Extraction boom.

Extraction Language OCaml.
Fail Extraction sigmas.
(* The informative inductive type sigT has a Prop instance
 * in sigmas.prop_and_prop (or in its mutual block).
 * This happens when a sort-polymorphic singleton inductive type
 * has logical parameters, such as (I,I) : (True * True) : Prop.
 * The Ocaml extraction cannot handle this situation yet.
 * Instead, use a sort-monomorphic type such as (True /\ True)
 * or extract to Haskell.
 *)

Extraction Language Haskell.
Extraction sigmas.


(* Enhanced Integers *)

From iris_c.lib Require Export prelude Integers.
Require Import stdpp.prelude.
From mathcomp Require Export ssreflect.

Definition op_safe op opn (i j: nat) : Prop :=
    Z.to_nat (Byte.intval (op (Byte.repr i) (Byte.repr j))) = opn i j.

Definition mul_safe := op_safe Byte.mul Init.Nat.mul.

Coercion Byte.repr : Z >-> int8.

Global Instance int_eq_dec : EqDecision int.
Proof. apply Int.eq_dec. Defined.
Global Instance byte_eq_dec : EqDecision byte.
Proof. apply Byte.eq_dec. Defined.
Global Instance int8_eq_dec : EqDecision int8.
Proof. apply Byte.eq_dec. Defined.
Global Instance int32_eq_dec: EqDecision int32 := Int.eq_dec.

Definition int8_encode (i: int8) : positive := encode (Byte.unsigned i).
Definition int8_decode (p: positive) : option int8 :=
  match decode p with
    | Some z => Some (Byte.repr z)
    | None => None
  end.

Lemma int8_decode_encode i: int8_decode (int8_encode i) = Some i.
Proof. unfold int8_encode, int8_decode. rewrite decode_encode.
       f_equal. apply Byte.repr_unsigned. Qed.

Global Instance int8_countable: Countable int8 :=
  Build_Countable _ _ int8_encode int8_decode int8_decode_encode.

Bind Scope int_scope with int.
Delimit Scope int_scope with int.

Notation "i1 + i2" := (Byte.add i1%int i2%int)
  (at level 50, left associativity) : int_scope.
Notation "i1 * i2" := (Byte.mul i1%int i2%int)
  (at level 40, left associativity) : int_scope.
Notation "i1 - i2" := (Byte.sub i1%int i2%int)
  (at level 50, left associativity) : int_scope.

Ltac rewrite_byte :=
  match goal with
    | |- context [ Byte.mul _ (Byte.repr Z0) ] => rewrite Byte.mul_zero
    | |- context [ offset_by_byte ?off Byte.zero ] =>
      rewrite /offset_by_byte;
        replace (Z.to_nat (Byte.intval Byte.zero)) with O; last done;
        replace (off + O) with off; last done
    | |- context [ offset_by_byte ?off (Byte.repr ?b) ] =>
      rewrite /offset_by_byte;
        replace (Z.to_nat (Byte.intval (Byte.repr b))) with (Z.to_nat b); last done
  end.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Lemmas from the Lambda JAR paper. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export TLC.LibFset.
Require Export Cyclone_LN_Tactics Cyclone_LN_Types Cyclone_LN_Terms Cyclone_LN_Types_In_Terms.
Require Export Cyclone_LN_Types_Lemmas Cyclone_LN_Terms_Lemmas.
Open Scope cyclone_scope.
Open Scope nat_scope.
Open Scope fset_scope.
Import TMP.
Import TTM.
(* This is the version just for the lemmas manipulating types in terms. *)
Module TTMP. (* T = Types TM = Term P = Proof. *)

(* With the new typeclass based propositions, you'll find some of them in the
Terms lemmas. *)

(* ====================================================================== *)
(** ** Proofs *)

(* ********************************************************************** *)
(** Variable closing and variable opening are reciprocal of one another *)

(** Showing that [close_var] after [open_var] is the identity is easy *)

Function close_open_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall (x : Variables.var) (n : nat),
    x \notin fv' t ->
    close_rec' n x (open_rec' n (ftvar x) t) = t.
Hint Unfold close_open_prop.

Lemma close_open_v :
  forall (t : V), close_open_prop TauTermVLangFuns t.
Proof.
  introv.
  induction t; simpl; introv Fr; fequals~.
Qed.

Ltac close_open_proof :=
  simpl;
  intros*;
  fequals~;
  try applys* close_open_v;
  try case_nat~;
  simpl;
  try case_var~;
  try case_var~.

Lemma close_open_st:
  forall (t : St), close_open_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual close_open_prop;
  close_open_proof.
Qed.

Lemma close_open_e:
  forall (t : E), close_open_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual close_open_prop;
  close_open_proof.
Qed.

Lemma close_open_f:
  forall (t : F), close_open_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual close_open_prop;
  close_open_proof.
Qed.

Lemma close_open_tau:
  forall (t : Tau), close_open_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual close_open_prop;
  close_open_proof.
Qed.

Lemma close_open :
  forall (t : Term), close_open_prop TauTermLangFuns t.
Proof.
  lets*: close_open_st.
  lets*: close_open_e.
  lets*: close_open_f.
  lets*: close_open_tau.
  destruct t; simpl; intros; fequals*.
Qed.

(** The other direction is much harder; First, we first need
    to establish the injectivity of [open_var] *)

Function open_rec_inj_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t1 t2 : In) =>
    forall n alpha,
      alpha \notin (fv' t1) ->
      alpha \notin (fv' t2) ->
      open_rec' n (ftvar alpha) t1 = open_rec' n (ftvar alpha) t2 ->
      (t1 = t2).
Hint Unfold open_rec_inj_prop.

Lemma open_rec_inj_v:
  forall (t1 t2 : V), open_rec_inj_prop TauTermVLangFuns t1 t2.
Proof.
  intros*.
Qed.

Ltac open_rec_inj_proof t1 t2 alpha n T H1:=
  intros*;
  rewrite* <- (@T t1 alpha n);
  rewrite* <- (@T t2 alpha n);
  rewrite* H1.

Lemma open_rec_inj_st:
  forall (t1 t2 : St), open_rec_inj_prop TauTermStLangFuns t1 t2.
Proof.
  open_rec_inj_proof t1 t2 alpha n close_open_st H1.
Qed.

Lemma open_rec_inj_e:
  forall (t1 t2 : E), open_rec_inj_prop TauTermELangFuns t1 t2.
Proof.
  open_rec_inj_proof t1 t2 alpha n close_open_e H1.
Qed.

Lemma open_rec_inj_f:
  forall (t1 t2: F), open_rec_inj_prop TauTermFLangFuns t1 t2.
Proof.
  open_rec_inj_proof t1 t2 alpha n close_open_f H1.
Qed.

Lemma open_rec_inj_tau:
  forall (t1 t2: Tau), open_rec_inj_prop TauTermTauLangFuns t1 t2.
Proof.
  open_rec_inj_proof t1 t2 alpha n close_open_tau H1.
Qed.

Lemma open_rec_st_inj :
  forall (t1 t2: Term), open_rec_inj_prop TauTermLangFuns t1 t2.
Proof.
  intros*.
  open_rec_inj_proof t1 t2 alpha n close_open H1.
Qed.

(** We also need one (tricky) auxiliary lemma to handle the binder case *)

Function open_close_var_on_open_var_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall alpha beta gamma i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv' t) ->
    open_rec' i (ftvar beta) (open_rec' j (ftvar gamma) (close_rec' j alpha t))
  = open_rec' j (ftvar gamma) (close_rec' j alpha (open_rec' i (ftvar beta) t)).
Hint Unfold open_close_var_on_open_var_prop.

Lemma open_close_var_on_open_var_v:
  forall (t : V), open_close_var_on_open_var_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac open_close_var_on_open_var_proof :=
  try solve[simpl; intros*; try solve [ fequals~ ]];
  try repeat (simpl; intros*; try case_nat*; try case_var*).

Lemma open_close_var_on_open_var_st:
  forall (t : St), open_close_var_on_open_var_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual open_close_var_on_open_var_prop;
  open_close_var_on_open_var_proof.
Qed.

Lemma open_close_var_on_open_var_e:
  forall (t : E), open_close_var_on_open_var_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual open_close_var_on_open_var_prop;
  open_close_var_on_open_var_proof.
Qed.

Lemma open_close_var_on_open_var_f:
  forall (t : F), open_close_var_on_open_var_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual open_close_var_on_open_var_prop;
  open_close_var_on_open_var_proof.
Qed.

Lemma open_close_var_on_open_var_tau:
  forall (t : Tau), open_close_var_on_open_var_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual open_close_var_on_open_var_prop;
  open_close_var_on_open_var_proof.
Qed.

Lemma open_close_var_on_open_var:
  forall (t : Term), open_close_var_on_open_var_prop TauTermLangFuns t.
Proof.
  intros*.
  lets*: open_close_var_on_open_var_st.
  lets*: open_close_var_on_open_var_e.
  lets*: open_close_var_on_open_var_f.
  lets*: open_close_var_on_open_var_tau.
  destruct t; simpl; intros*; fequals*.
Qed.

(** Now we can prove that [open_var] after [close_var] is the identity *)

Function open_close_var_prop
   (In : Type) (H: LangFuns Tau Tau In) (L : LcJudgement In) :=
  fun (t : In) (_ : lc' t) =>
  forall alpha n,
    open_rec' n (ftvar alpha) (close_rec' n alpha t)  = t.
Hint Unfold open_close_var_prop.

Lemma open_close_var_v:
 forall (t : V) (l : lc' t), open_close_var_prop TauTermVLangFuns LcVJudgement t l.
Proof.
  intros*.
Qed.

Ltac invert_lc_btvar :=
  match goal with
    | H : T.lc (btvar _) |- _  => inversion H
  end.

Hint Extern 1 (T.lc (btvar _)) => invert_lc_btvar.

Ltac inversion_on_lc :=
  match goal with
    | H : T.lc (_ _)    |- _ => inversions~ H
    | H : T.lc (_ _ _)    |- _ => inversions~ H
    | H : TTM.lc (_ _)    |- _ => inversions~ H
    | H : TTM.lc (_ _ _)    |- _ => inversions~ H
end.

Hint Extern 1 (T.lc (_ _)) => inversion_on_lc.
Hint Extern 1 (T.lc (_ _ _)) => inversion_on_lc.

Ltac open_close_var_proof t :=
  intros*;
  lets: open_close_var_v;
  lets~ M: TP.open_close_var;
  try solve[simpl; intros; fequals~];
  simpl;
  intros;
  fequals~;
  try induction t; simpl; intros; fequals~;
  try solve[case_var~; simpl; case_nat~].

Lemma open_close_var_st:
 forall (t : St) (l : lc' t), open_close_var_prop TauTermStLangFuns LcTauStJudgement t l.
Proof.
  LCSt_Tau_Induction lc_st_ind_mutual open_close_var_prop;
  open_close_var_proof t.
Qed.

Lemma open_close_var_e:
 forall (t : E) (l : lc' t), open_close_var_prop TauTermELangFuns LcTauEJudgement t l.
Proof.
  LCSt_Tau_Induction lc_e_ind_mutual open_close_var_prop;
  open_close_var_proof t.
Qed.

Lemma open_close_var_f:
 forall (t : F) (l : lc' t), open_close_var_prop TauTermFLangFuns LcTauFJudgement t l.
Proof.
  LCSt_Tau_Induction lc_f_ind_mutual open_close_var_prop;
  open_close_var_proof t.
Qed.

Lemma open_close_var:
 forall (t : Term) (l : lc' t), open_close_var_prop TauTermLangFuns LcTauTermJudgement t l.
Proof.
  lets*: open_close_var_st.
  lets*: open_close_var_e.
  lets*: open_close_var_f.
  destruct t; intros; inversion l; intros; simpl; fequals*.
Qed.

(** As a bonus, we get the injectivity of [close_var] *)

Lemma close_on_var_inj :
  forall alpha t1 t2,
    lc t1 ->
    lc t2 ->
    close alpha t1 = close alpha t2 ->
    (t1 = t2).
Proof.
  unfold close.
  introv T1 T2 Eq.
  rewrite~ <- (@open_close_var t1 T1 alpha 0).
  rewrite~ <- (@open_close_var t2 T2 alpha 0).
  fequals~.
Qed.

(* ********************************************************************** *)
(** Interaction of [fv] with [open_var] and [close_var] *)

(** Opening with [u] adds [fv u] to the set of free variables *)

Function fv_open_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall (u : var) (n: nat),
    fv' (open_rec' n (ftvar u) t) \c  fv' t \u \{u}.
Hint Unfold fv_open_prop.

Lemma fv_open_v:
  forall (t : V), fv_open_prop TauTermVLangFuns t.
Proof.
  intros*.
  destruct t; simpl; try case_nat; simpl; fset.
Qed.

Ltac fv_open_proof :=
  simpl;
  intros*;
  try case_nat*;
  fset.

Lemma fv_open_st:
  forall (t: St), fv_open_prop TauTermStLangFuns t.
Proof.
  intros*.
  StEF_Tau_Induction Tau_St_ind_mutual fv_open_prop;
  fv_open_proof.
Qed.

Lemma fv_open_e:
  forall (t: E), fv_open_prop TauTermELangFuns t.
Proof.
  intros*.
  StEF_Tau_Induction Tau_E_ind_mutual fv_open_prop;
  fv_open_proof.
Qed.

Lemma fv_open_f:
  forall (t: F), fv_open_prop TauTermFLangFuns t.
Proof.
  intros*.
  StEF_Tau_Induction Tau_F_ind_mutual fv_open_prop;
  fv_open_proof.
Qed.

Lemma fv_open_tau:
  forall (t: Tau), fv_open_prop TauTermTauLangFuns t.
Proof.
  intros*.
  StEF_Tau_Induction Tau_Tau_ind_mutual fv_open_prop;
  fv_open_proof.
Qed.

Lemma fv_open : forall t u,
  fv (open (ftvar u) t) \c fv t \u \{u}.
Proof.
  lets*: fv_open_st.
  lets*: fv_open_e.
  lets*: fv_open_f.
  lets*: fv_open_tau.
  destruct t; simpl; intros*.
Qed.

(** In particular, opening with variable [x] adds [x] to the set
    of free variables *)

Function open_var_fv_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
    forall alpha,
      fv' (open_rec' 0 (ftvar alpha) t) \c (fv' t \u \{alpha}).
Hint Unfold open_var_fv_prop.

Lemma open_var_fv_v:
  forall (t : V), open_var_fv_prop TauTermVLangFuns t.
Proof.
  lets*:fv_open_v.
Qed.

Lemma open_var_fv_st:
  forall (t : St), open_var_fv_prop TauTermStLangFuns t.
Proof.
  lets*:fv_open_st.
Qed.

Lemma open_var_fv_e:
  forall (t : E), open_var_fv_prop TauTermELangFuns t.
Proof.
  lets*:fv_open_e.
Qed.

Lemma open_var_fv_f:
  forall (t : F), open_var_fv_prop TauTermFLangFuns t.
Proof.
  lets*:fv_open_f.
Qed.

Lemma open_var_fv_tau:
  forall (t : Tau), open_var_fv_prop TauTermTauLangFuns t.
Proof.
  lets*:fv_open_tau.
Qed.

Lemma open_var_fv :
  forall (t : Term), open_var_fv_prop TauTermLangFuns t.
Proof.
  lets*: fv_open.
Qed.

(** Closing w.r.t variable [x] removes [x] from the set of free variables *)

Function close_var_fv_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
    forall alpha n,
      fv' (close_rec' n alpha t) \c (fv' t \- \{alpha}).
Hint Unfold close_var_fv_prop.

Lemma close_var_fv_v:
  forall (t : V), close_var_fv_prop TauTermVLangFuns t.
Proof.
  intros*.
  destruct t; simpl; fset.
Qed.

Ltac close_var_fv_proof :=
  lets*: close_var_fv_v;
  lets*: TP.close_fv;
  simpl;
  intros;
  try case_var*;
  try fset.

Lemma close_var_fv_st:
  forall (t : St), close_var_fv_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual close_var_fv_prop;
  close_var_fv_proof.
Qed.

Lemma close_var_fv_e:
  forall (t : E), close_var_fv_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual close_var_fv_prop;
  close_var_fv_proof.
Qed.

Lemma close_var_fv_f:
  forall (t : F), close_var_fv_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual close_var_fv_prop;
  close_var_fv_proof.
Qed.

Lemma close_var_fv_tau:
  forall (t : Tau), close_var_fv_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual close_var_fv_prop;
  close_var_fv_proof.
Qed.

Lemma close_var_fv :
  forall (t : Term), close_var_fv_prop TauTermLangFuns t.
Proof.
  lets*: close_var_fv_st.
  lets*: close_var_fv_e.
  lets*: close_var_fv_f.
  lets*: close_var_fv_tau.
  destruct t; simpl; intros*.
Qed.

(* ********************************************************************** *)
(** Properties of substitution *)

(** Distributivity of [subst] on [open].
    Two (tricky) intermediate lemmas are required *)

Function open_rec_lc_ind_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall j v i u,
    i <> j ->
    open_rec' i u (open_rec' j v t) = open_rec' j v t ->
    open_rec' i u t = t.
Hint Unfold open_rec_lc_ind_prop.

Lemma open_rec_lc_ind_v:
  forall (t : V), open_rec_lc_ind_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac open_rec_lc_ind_proof :=
  lets*: open_rec_lc_ind_v;
  lets*: TP.close_fv;
  simpl;
  intros*;
  try inversion_on_equated_constructors;
  fequals*;
  try repeat case_nat*.

Lemma open_rec_lc_ind_st:
  forall (t : St), open_rec_lc_ind_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual open_rec_lc_ind_prop;
  open_rec_lc_ind_proof.
Qed.

Lemma open_rec_lc_ind_e:
  forall (t : E), open_rec_lc_ind_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual open_rec_lc_ind_prop;
  open_rec_lc_ind_proof.
Qed.

Lemma open_rec_lc_ind_f:
  forall (t : F), open_rec_lc_ind_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual open_rec_lc_ind_prop;
  open_rec_lc_ind_proof.
Qed.

Lemma open_rec_lc_ind_tau:
  forall (t : Tau), open_rec_lc_ind_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual open_rec_lc_ind_prop;
  open_rec_lc_ind_proof.
Qed.

Lemma open_rec_lc_ind:
  forall (t : Term), open_rec_lc_ind_prop TauTermLangFuns t.
Proof.
  lets*: open_rec_lc_ind_st.
  lets*: open_rec_lc_ind_e.
  lets*: open_rec_lc_ind_f.
  lets*: open_rec_lc_ind_tau.
  destruct t;
  simpl;
  intros*;
  try inversion_on_equated_constructors;
  fequals*.
Qed.

Function open_rec_lc_prop
   (In : Type) (H: LangFuns Tau Tau In) (L : LcJudgement In) :=
  fun (t : In) (_ : lc' t) =>
    forall u k,
      open_rec' k u t = t.
Hint Unfold open_rec_lc_prop.

Lemma open_rec_lc_v:
  forall (t : V) (l : lc' t), open_rec_lc_prop TauTermVLangFuns LcTauVJudgement t l.
Proof.
  destruct t; intros; simpls~.
Qed.

Ltac open_rec_lc_proof :=
  lets: open_rec_lc_v;
  lets: TP.open_rec_lc;
  intros*;
  simpl;
  fequals~.

Lemma open_rec_lc_st:
  forall (t : St) (l : lc' t), open_rec_lc_prop TauTermStLangFuns LcTauStJudgement t l.
Proof.
  LCSt_Tau_Induction lc_st_ind_mutual open_rec_lc_prop;
  open_rec_lc_proof.
Qed.

Lemma open_rec_lc_e:
  forall (t : E) (l : lc' t), open_rec_lc_prop TauTermELangFuns LcTauEJudgement t l.
Proof.
  LCSt_Tau_Induction lc_e_ind_mutual open_rec_lc_prop;
  open_rec_lc_proof.
Qed.

Lemma open_rec_lc_f:
  forall (t : F) (l : lc' t), open_rec_lc_prop TauTermFLangFuns LcTauFJudgement t l.
Proof.
  LCSt_Tau_Induction lc_f_ind_mutual open_rec_lc_prop;
  open_rec_lc_proof.
Qed.

Lemma open_rec_lc :
  forall (t : Term) (l : lc' t), open_rec_lc_prop TauTermLangFuns LcTauTermJudgement t l.
Proof.
  lets*: open_rec_lc_st.
  lets*: open_rec_lc_e.
  lets*: open_rec_lc_f.
  destruct t; intros; simpl; inversion l; fequals~.
Qed.

Function subst_open_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall alpha u v n,
    T.lc u ->
    subst' u alpha (open_rec' n v t) =
    open_rec' n (T.subst u alpha v) (subst' u alpha t).
Hint Unfold subst_open_prop.

Lemma subst_open_v:
  forall (t : V), subst_open_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac subst_open_proof :=
  intros*;
  lets: TP.subst_open_rec;
  intros*; simpl; fequals~.

Lemma subst_open_st:
  forall (t : St), subst_open_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual subst_open_prop;
  subst_open_proof.
Qed.

Lemma subst_open_e:
  forall (t : E), subst_open_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual subst_open_prop;
  subst_open_proof.
Qed.

Lemma subst_open_f:
  forall (t : F), subst_open_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual subst_open_prop;
  subst_open_proof.
Qed.

Lemma subst_open_tau:
  forall (t : Tau), subst_open_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual subst_open_prop;
  subst_open_proof.
Qed.

Lemma subst_open:
  forall (t : Term), subst_open_prop TauTermLangFuns t.
Proof.
  lets*: subst_open_st.
  lets*: subst_open_e.
  lets*: subst_open_f.
  lets*: subst_open_tau.
  destruct t;
  simpl;
  intros;
  fequals~.
Qed.

(** In particular, we can distribute [subst] on [open_var] *)

Function subst_open_var_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall alpha beta u,
    alpha <> beta ->
    T.lc u ->
    subst' u alpha (open_rec' 0 (ftvar beta) t) =
    open_rec' 0 (ftvar beta) (subst' u alpha t).
Hint Unfold subst_open_var_prop.

Lemma subst_open_var_v:
  forall (t : V), subst_open_var_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac subst_open_var_proof:=
  intros*;
  try rewrite~ subst_open_st;
  try rewrite~ subst_open_e;
  try rewrite~ subst_open_f;
  try rewrite~ subst_open_tau;
  try rewrite~ subst_open;
  fequals;
  simpl;
  case_var~.

Lemma subst_open_var_st:
  forall (t : St), subst_open_var_prop TauTermStLangFuns t.
Proof.
  subst_open_var_proof.
Qed.

Lemma subst_open_var_e:
  forall (t : E), subst_open_var_prop TauTermELangFuns t.
Proof.
  subst_open_var_proof.
Qed.

Lemma subst_open_var_f:
  forall (t : F), subst_open_var_prop TauTermFLangFuns t.
Proof.
  subst_open_var_proof.
Qed.

Lemma subst_open_var_tau:
  forall (t : Tau), subst_open_var_prop TauTermTauLangFuns t.
Proof.
  subst_open_var_proof.
Qed.

Lemma subst_open_var:
  forall (t : Term), subst_open_var_prop TauTermLangFuns t.
Proof.
  subst_open_var_proof.
Qed.

(** For the distributivity of [subst] on [close_var],
    one simple intermediate lemmas is required to
    say that closing on a fresh name is the identity *)

Function close_var_rec_fresh_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall alpha k,
    alpha \notin fv' t -> close_rec' k alpha t = t.
Hint Unfold close_var_rec_fresh_prop.

Lemma close_var_rec_fresh_v:
  forall (t : V), close_var_rec_fresh_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac close_var_rec_fresh_proof :=
  lets*: close_var_rec_fresh_v;
  lets*: TP.close_rec_fresh;
  simpl;
  intros*;
  fequals~.

Lemma close_var_rec_fresh_st:
  forall (t : St), close_var_rec_fresh_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual close_var_rec_fresh_prop;
  close_var_rec_fresh_proof.
Qed.

Lemma close_var_rec_fresh_e:
  forall (t : E), close_var_rec_fresh_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual close_var_rec_fresh_prop;
  close_var_rec_fresh_proof.
Qed.

Lemma close_var_rec_fresh_f:
  forall (t : F), close_var_rec_fresh_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual close_var_rec_fresh_prop;
  close_var_rec_fresh_proof.
Qed.

Lemma close_var_rec_fresh_tau:
  forall (t : Tau), close_var_rec_fresh_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual close_var_rec_fresh_prop;
  close_var_rec_fresh_proof.
Qed.

Lemma close_rec_fresh:
  forall (t : Term), close_var_rec_fresh_prop TauTermLangFuns t.
Proof.
  lets*: close_var_rec_fresh_st.
  lets*: close_var_rec_fresh_e.
  lets*: close_var_rec_fresh_f.
  lets*: close_var_rec_fresh_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** Distributivity of [subst] on [close_var] *)

Function subst_close_var_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
  forall (alpha beta : var) (u : Tau),
    alpha <> beta ->
    beta \notin T.fv u ->
    forall n,
      subst' u alpha (close_rec' n beta t) =
      close_rec' n beta (subst' u alpha t).
Hint Unfold subst_close_var_prop.

Lemma subst_close_var_v:
  forall (t : V), subst_close_var_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac subst_close_var_proof :=
  lets*: TP.subst_close_rec;
  simpl;
  intros*;
  fequals~.

Lemma subst_close_var_st:
  forall (t : St), subst_close_var_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual subst_close_var_prop;
  subst_close_var_proof.
Qed.

Lemma subst_close_var_e:
  forall (t : E), subst_close_var_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual subst_close_var_prop;
  subst_close_var_proof.
Qed.

Lemma subst_close_var_f:
  forall (t : F), subst_close_var_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual subst_close_var_prop;
  subst_close_var_proof.
Qed.

Lemma subst_close_var_tau:
  forall (t : Tau), subst_close_var_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual subst_close_var_prop;
  subst_close_var_proof.
Qed.

Lemma subst_close_var_fresh:
  forall (t : Term), subst_close_var_prop TauTermLangFuns t.
Proof.
  lets*: subst_close_var_st.
  lets*: subst_close_var_e.
  lets*: subst_close_var_f.
  lets*: subst_close_var_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** Substitution for a fresh name is the identity *)

Function subst_fresh_prop (In : Type) (H: LangFuns Tau Tau In) :=
  fun (t : In) =>
    forall alpha u,
    alpha \notin fv' t -> subst' u alpha t = t.
Hint Unfold subst_fresh_prop.

Lemma subst_fresh_v:
  forall (t : V), subst_fresh_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac subst_fresh_proof :=
  lets*: subst_fresh;
  lets*: TP.subst_fresh;
  simpl;
  intros;
  fequals~.

Lemma subst_fresh_st:
  forall (t : St), subst_fresh_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual subst_fresh_prop;
  subst_fresh_proof.
Qed.

Lemma subst_fresh_e:
  forall (t : E), subst_fresh_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual subst_fresh_prop;
  subst_fresh_proof.
Qed.

Lemma subst_fresh_f:
  forall (t : F), subst_fresh_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual subst_fresh_prop;
  subst_fresh_proof.
Qed.

Lemma subst_fresh_tau:
  forall (t : Tau), subst_fresh_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual subst_fresh_prop;
  subst_fresh_proof.
Qed.

Lemma subst_fresh :
  forall (t : Term), subst_fresh_prop TauTermLangFuns t.
Proof.
  lets*: subst_fresh_st.
  lets*: subst_fresh_e.
  lets*: subst_fresh_f.
  lets*: subst_fresh_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** Substitution can be introduced to decompose an opening *)

Function subst_intro_prop (In : Type) (H: LangFuns Tau Tau In) (L : LcJudgement In) :=
 fun (t : In) =>
   forall alpha u n,
     alpha \notin (fv' t) ->
     T.lc u ->
     open_rec' n u t = subst' u alpha (open_rec' n (ftvar alpha) t).
Hint Unfold subst_intro_prop.

Lemma subst_intro_v:
  forall (t : V), subst_intro_prop TauTermVLangFuns LcVJudgement t.
Proof.
  intros*.
Qed.

Ltac subst_intro_proof :=
  intros*;
  try rewrite~ subst_open_st;
  try rewrite~ subst_open_e;
  try rewrite~ subst_open_f;
  try rewrite~ subst_open_tau;
  fequals;
  simpl;
  try case_var*;
  try rewrite~ subst_fresh_st;
  try rewrite~ subst_fresh_e;
  try rewrite~ subst_fresh_f;
  try rewrite~ subst_fresh_tau.

Lemma subst_intro_st:
  forall (t : St), subst_intro_prop TauTermStLangFuns LcStJudgement t.
Proof.
  subst_intro_proof.
Qed.

Lemma subst_intro_e:
  forall (t : E), subst_intro_prop TauTermELangFuns LcEJudgement t.
Proof.
  subst_intro_proof.
Qed.

Lemma subst_intro_f:
  forall (t : F), subst_intro_prop TauTermFLangFuns LcFJudgement t.
Proof.
  subst_intro_proof.
Qed.

Lemma subst_intro_tau:
  forall (t : Tau), subst_intro_prop TauTermTauLangFuns LcTauJudgement t.
Proof.
  subst_intro_proof.
Qed.

Lemma subst_intro :
  forall (t : Term), subst_intro_prop TauTermLangFuns LcTermJudgement t.
Proof.
  lets*: subst_intro_st.
  lets*: subst_intro_e.
  lets*: subst_intro_f.
  lets*: subst_intro_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** An alternative, longer proof, but with fewer hypotheses *)

Function subst_intro_alternative_prop (In : Type) (H: LangFuns Tau Tau In) :=
 fun (t : In) =>
   forall alpha  u n,
     alpha \notin (fv' t) ->
     open_rec' n u t = subst' u alpha (open_rec' n (ftvar alpha) t).
Hint Unfold subst_intro_alternative_prop.

Lemma subst_intro_alternative_v:
  forall (t : V), subst_intro_alternative_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac subst_intro_alternative_proof :=
  lets*: TP.subst_intro_alternative;
  simpl;
  intros;
  fequals~.

Lemma subst_intro_alternative_st:
  forall (t : St), subst_intro_alternative_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual subst_intro_alternative_prop;
  subst_intro_alternative_proof.
Qed.

Lemma subst_intro_alternative_e:
  forall (t : E), subst_intro_alternative_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual subst_intro_alternative_prop;
  subst_intro_alternative_proof.
Qed.

Lemma subst_intro_alternative_f:
  forall (t : F), subst_intro_alternative_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual subst_intro_alternative_prop;
  subst_intro_alternative_proof.
Qed.

Lemma subst_intro_alternative_tau:
  forall (t : Tau), subst_intro_alternative_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual subst_intro_alternative_prop;
  subst_intro_alternative_proof.
Qed.

Lemma subst_intro_alternative :
  forall (t : Term), subst_intro_alternative_prop TauTermLangFuns t.
Proof.
  lets*: subst_intro_alternative_st.
  lets*: subst_intro_alternative_e.
  lets*: subst_intro_alternative_f.
  lets*: subst_intro_alternative_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** Substitution can be introduced to decompose a variable
    closing in terms of another one using a different name *)

Function close_var_rename_prop (In : Type) (H: LangFuns Tau Tau In) :=
 fun (t : In) =>
  forall alpha beta n,
    alpha \notin fv' t ->
    close_rec' n beta t =
    close_rec' n alpha (subst' (ftvar alpha) beta t).
Hint Unfold close_var_rename_prop.

Lemma close_var_rename_v:
  forall (t : V), close_var_rename_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac close_var_rename_proof :=
  simpl;
  intros;
  fequals~;
  simpl;
  intros*;
  repeat (try case_var*; simpl).

Lemma close_var_rename_st:
  forall (t : St), close_var_rename_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual close_var_rename_prop;
  close_var_rename_proof.
Qed.

Lemma close_var_rename_e:
  forall (t : E), close_var_rename_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual close_var_rename_prop;
  close_var_rename_proof.
Qed.

Lemma close_var_rename_f:
  forall (t : F), close_var_rename_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual close_var_rename_prop;
  close_var_rename_proof.
Qed.

Lemma close_var_rename_tau:
  forall (t : Tau), close_var_rename_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual close_var_rename_prop;
  close_var_rename_proof.
Qed.

Lemma close_var_rename :
  forall (t : Term), close_var_rename_prop TauTermLangFuns t.
Proof.
  lets*: close_var_rename_st.
  lets*: close_var_rename_e.
  lets*: close_var_rename_f.
  lets*: close_var_rename_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(* ********************************************************************** *)
(** Preservation of local closure through substitution and opening *)

(** Substitution of a locally closed terms into another one produces
    a locally closed term *)

Function subst_lc_prop (In : Type) (H: LangFuns Tau Tau In) (L : LcJudgement In) :=
  fun (t : In) (_ : lc' t) =>
  forall alpha u,
    T.lc u -> lc' (subst' u alpha t).
Hint Unfold subst_lc_prop.

Lemma subst_lc_v:
 forall (t : V) (l : lc' t), subst_lc_prop TauTermVLangFuns LcVJudgement t l.
Proof.
  intros*.
Qed.

Ltac subst_lc_proof :=
  simpl;
  intros*;
  fequals~;
  lets: TP.subst_lc;
  constructor~.

Lemma subst_lc_st:
 forall (t : St) (l : lc' t), subst_lc_prop TauTermStLangFuns LcTauStJudgement t l.
Proof.
  LCSt_Tau_Induction lc_st_ind_mutual subst_lc_prop;
  subst_lc_proof.
Qed.

Lemma subst_lc_e:
 forall (t : E) (l : lc' t), subst_lc_prop TauTermELangFuns LcTauEJudgement t l.
Proof.
  LCSt_Tau_Induction lc_e_ind_mutual subst_lc_prop;
  subst_lc_proof.
Qed.

Lemma subst_lc_f:
 forall (t : F) (l : lc' t), subst_lc_prop TauTermFLangFuns LcTauFJudgement t l.
Proof.
  LCSt_Tau_Induction lc_f_ind_mutual subst_lc_prop;
  subst_lc_proof.
Qed.

Lemma subst_lc:
 forall (t : Term) (l : lc' t), subst_lc_prop TauTermLangFuns LcTauTermJudgement t l.
Proof.
  lets*: subst_lc_st.
  lets*: subst_lc_e.
  lets*: subst_lc_f.
  simpl;
  intros;
  destruct t;
  inversion_on_lc;
  constructor~.
Qed.

(** Substitution of a locally closed terms into a body one produces
    another body *)

(* We need a lemma that Arthur only proved for his alternate inductive lc. *)

Function lc_open_var_prop (In : Type) (H: LangFuns Tau Tau In) (L : LcJudgement In) :=
  fun (t : In) (_ : lc' t) =>
  forall alpha,
    lc' (open_rec' 0 (ftvar alpha) t).
Hint Unfold lc_open_var_prop.

Lemma lc_open_var_v:
 forall (t : V) (l : lc' t), lc_open_var_prop TauTermVLangFuns LcVJudgement t l.
Proof.
  intros*.
Qed.

Ltac inversion_on_lc_term :=
  match goal with
    | H : lc_st (_)    |- _ => inversions~ H
    | H : lc_st (_)     |- _ => inversions~ H
    | H : lc_e (_)     |- _ => inversions~ H
    | H : lc_f (_)     |- _ => inversions~ H
    | H : lc_f (_)      |- _=> inversions~ H
end.

Ltac lc_open_var_proof :=
  lets*: lc_open_var_v;
  simpl;
  intros*;
  simpl;
  constructor~;
  lets* M: TP.lc_open_var_rec.

Lemma lc_open_var_st:
 forall (t : St) (l : lc' t), lc_open_var_prop TauTermStLangFuns LcTauStJudgement t l.
Proof.
  LCSt_Tau_Induction lc_st_ind_mutual lc_open_var_prop;
  lc_open_var_proof.
Qed.

Lemma lc_open_var_e:
 forall (t : E) (l : lc' t), lc_open_var_prop TauTermELangFuns LcTauEJudgement t l.
Proof.
  LCSt_Tau_Induction lc_e_ind_mutual lc_open_var_prop;
  lc_open_var_proof.
Qed.

Lemma lc_open_var_f:
 forall (t : F) (l : lc' t), lc_open_var_prop TauTermFLangFuns LcTauFJudgement t l.
Proof.
  LCSt_Tau_Induction lc_f_ind_mutual lc_open_var_prop;
  lc_open_var_proof.
Qed.

Lemma lc_open_var:
 forall (t : Term) (l : lc' t), lc_open_var_prop TauTermLangFuns LcTauTermJudgement t l.
Proof.
  lets*: lc_open_var_st.
  lets*: lc_open_var_e.
  lets*: lc_open_var_f.
  simpl;
  intros;
  destruct t;
  inversion_on_lc;
  constructor~.
Qed.

Lemma subst_body :
  forall alpha t u,
    T.lc u -> body t -> body (subst u alpha t).
Proof.
  introv U [L H].
  exists_fresh.
  rewrite~ <- subst_open_var.
  apply~ subst_lc.
  assert(alpha <> y).
  auto.
  contradiction.
Qed.

(** Opening of a body with a locally closed terms produces a
    locally closed term *)

Lemma open_lc : forall t u,
  body t -> T.lc u -> lc (open_rec 0 u t).
Proof.
  introv [L H] U.
  pick_fresh alpha.
  rewrite~ (@subst_intro_alternative t alpha).
  apply~ subst_lc.
Qed.

(* ********************************************************************** *)
(** Properties of [body] *)

(** An abstraction is locally closed iff it satifies the predicate [body] *)

Lemma open_var_lc:
  forall t1 x,
    body t1 -> lc (open_rec 0 (ftvar x) t1).
Proof.
  lets* M: open_lc.
Qed.

(* This is a weakened version as body does not imply lc t0 and lc t1. *)
Lemma lc_dfun_iff_body :
  forall t0 t1 s,
    T.lc t0 ->
    T.lc t1 ->
    lc_st s ->
    lc (term_f (dfun t0 t1 s)) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  inversions~ H3.
  unfold body.
  exists ((T.fv t0 \u T.fv t1) \u TM.fv_st s \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_st.

  unfold body in A.
  simpl in A.
  constructor.
  constructor~.
Qed.

Lemma lc_open_iff_body:
  forall e s,
    lc_e e ->
    lc_st s ->
    lc_st (openx e s) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  unfold body.
  exists ((fv_e e) \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_st.

  unfold body in A.
  simpl in A.
  constructor.
  assumption.
  assumption.
Qed.

Lemma lc_openstar_iff_body :
  forall e s,
    lc_e e ->
    lc_st s ->
    lc_st (openstar e s) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  unfold body.
  exists ((fv_e e) \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_st.

  unfold body in A.
  simpl in A.
  constructor.
  assumption.
  assumption.
Qed.

Lemma lc_letx_iff_body :
  forall e s,
    lc_e e ->
    lc_st s ->
    lc_st (letx e s) <-> body (term_st s).
Proof.
  intros.
  iff A.
  inversions~ A.
  unfold body.
  exists ((fv_e e) \u (fv_st s)).
  intros.
  constructor.
  applys~ lc_open_var_st.

  unfold body in A.
  simpl in A.
  constructor.
  assumption.
  assumption.
Qed.

(* ====================================================================== *)
(** ** An induction principle for locally closed terms *)

(** Interaction of [size] with [open_var] *)

Function size_open_prop (In : Type) (H: LangFuns Tau Tau In) :=
 fun (t : In) =>
  forall alpha n,
    size' (open_rec' n (ftvar alpha) t) = size' t.
Hint Unfold size_open_prop.

Lemma size_open_v:
  forall (t : V), size_open_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac size_open_proof :=
  intros*;
  lets*: TP.size_open_var;
  lets*: TMP.size_open_rec;
  simpl;
  intros;
  fequals~;
  auto.

Lemma size_open_st:
  forall (t : St), size_open_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual size_open_prop;
  size_open_proof.
Qed.

Lemma size_open_e:
  forall (t : E), size_open_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual size_open_prop;
  size_open_proof.
Qed.

Lemma size_open_f:
  forall (t : F), size_open_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual size_open_prop;
  size_open_proof.
Qed.

Lemma size_open_tau:
  forall (t : Tau), size_open_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual size_open_prop;
  size_open_proof.
Qed.

Lemma size_open :
  forall (t : Term), size_open_prop TauTermLangFuns t.
Proof.
  lets*: size_open_st.
  lets*: size_open_e.
  lets*: size_open_f.
  lets*: size_open_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** Interaction of [size] with [close_var] *)

Function size_close_var_prop (In : Type) (H: LangFuns Tau Tau In) :=
 fun (t : In) =>
  forall alpha n,
  size' (close_rec' n alpha t) = size' t.
Hint Unfold size_close_var_prop.

Lemma size_close_var_v:
  forall (t : V), size_close_var_prop TauTermVLangFuns t.
Proof.
  intros*.
Qed.

Ltac size_close_var_proof :=
  intros*;
  lets*: TP.size_close_var;
  lets*: TMP.size_close_var;
  simpl;
  intros;
  fequals~;
  auto.

Lemma size_close_var_st:
  forall (t : St), size_close_var_prop TauTermStLangFuns t.
Proof.
  StEF_Tau_Induction Tau_St_ind_mutual size_close_var_prop;
  size_close_var_proof.
Qed.

Lemma size_close_var_e:
  forall (t : E), size_close_var_prop TauTermELangFuns t.
Proof.
  StEF_Tau_Induction Tau_E_ind_mutual size_close_var_prop;
  size_close_var_proof.
Qed.

Lemma size_close_var_f:
  forall (t : F), size_close_var_prop TauTermFLangFuns t.
Proof.
  StEF_Tau_Induction Tau_F_ind_mutual size_close_var_prop;
  size_close_var_proof.
Qed.

Lemma size_close_var_tau:
  forall (t : Tau), size_close_var_prop TauTermTauLangFuns t.
Proof.
  StEF_Tau_Induction Tau_Tau_ind_mutual size_close_var_prop;
  size_close_var_proof.
Qed.

Lemma size_close_var :
  forall (t : Term), size_close_var_prop TauTermLangFuns t.
Proof.
  lets*: size_close_var_st.
  lets*: size_close_var_e.
  lets*: size_close_var_f.
  lets*: size_close_var_tau.
  destruct t; simpl; intros; fequals~.
Qed.

(** The induction principle *)
(* This would be very large, three induction principles. *)
(* And the only thing Dan seems to induct on is the length of a context,
  not its full size. So unless I need this I won't make it. *)

End TTMP.


Require Import
  Coq.Program.Program
  Coq.Program.Tactics
  Coq.Lists.List
  Coq.omega.Omega
  Hask.Control.Monad.

Require Export
  Member
  Comp.

Import ListNotations.
Import EqNotations.

Generalizable All Variables.

Inductive Choice (A : Type) : Type :=
  | Pick : forall (P : A -> Prop), Choice A.

Arguments Pick {A} P.

(* A Choice "effect" may be refined so long as every value computable from the
   new choice was computable from the original choice. *)
Inductive refineChoice {a} : Choice a -> Choice a -> Prop :=
  RefineChoice : forall old new, (forall v, new ↝ v -> old ↝ v) ->
     refineChoice (Pick new) (Pick old).

Class Computes (s : Type) (eff : Type -> Type) := {
  computes : forall a, s -> eff a -> s -> a -> Prop
}.

Arguments computes {s eff _ a} _ _ _ _.

(* Given an interpreter that can run any effect down to its denotation in
   Gallina, we can interpret any action. *)
Inductive interpP {effs state a}
          (interpE : forall v, effs v -> v -> state -> state -> Prop) :
          Freer effs a -> a -> state -> state -> Prop :=
  | interpP_Impure :
      forall {t} (u : effs t) (r : t) (k : t -> Freer effs a)
             val pre mid post,
        interpE _ u r pre mid ->
        interpP interpE (k r) val mid post ->
        interpP interpE (Impure u k) val pre post
  | interpP_Pure : forall val pre post,
      interpP interpE (Pure val) val pre post.

Require Import
  RWS.

(* This theorem present the meaning of state, interpreted as an "effect" on an
   input state and resulting in a final value. *)
Theorem meaning_of_State {s v} (f : State s v) (x : v) (start : s) :
  interpP
    (fun v (st : State s v) (x : v) (pre : s) (post : s) =>
       match st in State _ v' return v' = v -> _ with
       | Get   => fun H => post = pre /\ x = rew H in post
       | Put p => fun H => post = p   /\ x = rew H in tt
       end eq_refl)
    (sendF f)
    (match f in State _ v' return v' = v -> _ with
     | Get   => fun H => start
     | Put p => fun H => tt
     end eq_refl)
    start
    (match f in State _ v' return v' = v -> _ with
     | Get   => fun H => start
     | Put p => fun H => p
     end eq_refl).
Proof.
  unfold sendF.
  induction f; simpl;
  eapply interpP_Impure; eauto;
  eapply interpP_Pure.
Qed.

Theorem final {a} {x : Eff [] a} {v state} {pre post : state} :
  run x = v ->
  interpP (fun _ u _ _ _ => False_rect _ (Union_empty _ u)) x v pre post.
Proof.
  simpl; intros; subst.
  induction x; simpl.
    now apply interpP_Pure.
  now inversion f.
Qed.


(* correct failure of injection/discriminate on types whose inductive
   status derives from the substitution of an argument *)

Unset Structural Injection.

Inductive t : nat -> Type :=
| M : forall n: nat, nat -> t n.

Lemma eq_t : forall n n' m m',
   existT (fun B : Type => B) (t n) (M n m) =
   existT (fun B : Type => B) (t n') (M n' m') -> True.
Proof.
  intros.
  injection H.
  intro Ht.
  exact I.
Qed.

Lemma eq_t' : forall n n' : nat,
   existT (fun B : Type => B) (t n) (M n 0) =
   existT (fun B : Type => B) (t n') (M n' 1) -> True.
Proof.
  intros.
  discriminate H || exact I.
Qed.


From iris.algebra Require Import auth frac gmap agree.
From iris.base_logic Require Import invariants.
From iris.program_logic Require Import weakestpre.
From iris.proofmode Require Import tactics.
From cap_machine Require Import monocmra.

(** An example of using the monotone monoid construction to create
    monotone refrences. *)

Section Resources.
  Context {A : ofeT} {R : relation A}.

  Class MonRefG Σ := monrefG {
    MonRefIG_monauth :> inG Σ (authUR (monotoneUR R));
  }.

  Definition MonRefΣ :=
    #[GFunctor (authUR (monotoneUR R))].

  Instance subG_MonRefIGΣ {Σ} : subG MonRefΣ Σ → MonRefG Σ.
  Proof. solve_inG. Qed.
End Resources.

Global Arguments MonRefG {_} _ _.

Section MonRef.
  Context {A : ofeT} (R : relation A) `{!ProperPreOrder R}.
  Context `{!MonRefG R Σ}.

  Definition Exact γ v :=
    (own γ (● (principal R v)))%I.

  Definition atleast_def γ v :=
    (own γ (◯ (principal R v)))%I.
  Definition atleast_aux γ v : seal (atleast_def γ v). by eexists. Qed.
  Definition atleast γ v : iProp Σ := (atleast_aux γ v).(unseal).
  Definition atleast_eq γ v : atleast γ v = atleast_def γ v :=
    (atleast_aux γ v).(seal_eq).

  Lemma MonRef_related γ v w :
    Exact γ v -∗ atleast γ w -∗ ⌜R w v⌝.
  Proof.
    rewrite atleast_eq /atleast_def /Exact.
    iIntros "HF Hf".
    iDestruct (own_valid_2 with "HF Hf") as %[Hv Hvl]%auth_valid_discrete;
      simpl in *.
    destruct Hvl as [a [Hag [Hvl Ha]]].
    iAssert ((principal R v) ≡ a)%I as %Heq.
    { iApply agree_equivI; auto. }
    iPureIntro.
    apply (principal_included w v).
    rewrite Heq.
    rewrite left_id_L in Hvl. auto.
  Qed.

  Global Instance atleas_presistent l v : Persistent (atleast l v).
  Proof. rewrite atleast_eq /atleast_def; apply _. Qed.

  Lemma MonRef_alloc v :
    (|==> ∃ γ, Exact γ v ∗ atleast γ v)%I.
  Proof.
    setoid_rewrite atleast_eq. rewrite /atleast_def /Exact.
    iMod (own_alloc (● (principal R v) ⋅ ◯ (principal R v))) as (γ) "[HF Hf]".
    { rewrite auth_valid_eq /=; split; first done. intros ?; rewrite left_id_L.
      exists (principal R v). repeat (split;auto). }
    iModIntro; iExists _; iSplitL "HF"; iFrame; eauto.
  Qed.

  Lemma MonRef_update γ v w :
    R v w →
    Exact γ v ==∗ Exact γ w ∗ atleast γ w.
  Proof.
    rewrite atleast_eq /atleast_def.
    iIntros (HR) "HF".
    iDestruct "HF" as "HF"; simplify_eq.
    iMod (own_update _ _ (● (principal R w) ⋅ ◯ (principal R w))
            with "HF") as "[HF Hf]".
    { apply auth_update_alloc.
      apply local_update_unital_discrete => mz _ HM.
      split; first done. rewrite left_id_L in HM.
      rewrite -HM (comm op) principal_R_op; eauto. }
    iModIntro; iSplitL "HF"; eauto.
  Qed.

  Lemma MonRef_update' γ v w :
    R v w →
    Exact γ v ==∗ Exact γ w ∗ atleast γ w.
  Proof.
    rewrite atleast_eq /atleast_def.
    iIntros (HR) "HF".
    iDestruct "HF" as "HF"; simplify_eq.
    iMod (own_update _ _ (● (principal R w) ⋅ ◯ (principal R w))
            with "HF") as "[HF Hf]".
    { apply auth_update_alloc.
      apply local_update_unital_discrete => mz _ HM.
      split; first done. rewrite left_id_L in HM.
      rewrite -HM (comm op) principal_R_op; eauto. }
    iModIntro; iSplitL "HF"; eauto.
  Qed.

End MonRef.


From Coq Require Import Recdef.

From MetaCoq.Template Require Import TemplateMonad Loader.
(* From MetaCoq.SafeChecker Require Import SafeTemplateChecker. *)
From MetaCoq.PCUIC Require Import PCUICEquality PCUICAst PCUICReflect PCUICSafeLemmata PCUICTyping PCUICNormal PCUICAstUtils PCUICSN.
From MetaCoq.TemplatePCUIC Require Import TemplateToPCUIC PCUICToTemplate.

From MetaCoq.ErasurePlugin Require Import Erasure.

From Coq Require Import String.
Local Open Scope string_scope.

From MetaCoq.Utils Require Import utils bytestring.
From MetaCoq.Common Require Import config.
Import MCMonadNotation.
Unset MetaCoq Debug.
(* We're doing erasure assuming no Prop <= Type rule and lets can appear in constructor types. *)
#[local] Existing Instance config.extraction_checker_flags.

Definition test (p : Ast.Env.program) : string :=
  erase_and_print_template_program p.

Definition test_fast (p : Ast.Env.program) : string :=
  erase_fast_and_print_template_program p.

MetaCoq Quote Recursively Definition zero := 0.

Definition zerocst := Eval lazy in test zero.

MetaCoq Quote Recursively Definition exproof := I.
Definition exprooftest := Eval lazy in test exproof.

MetaCoq Quote Recursively Definition exintro := (@exist _ _ 0 (@eq_refl _ 0) : {x : nat | x = 0}).
Definition exintrotest := Eval lazy in test exintro.

Definition idnat := ((fun (X : Set) (x : X) => x) nat).

MetaCoq Quote Recursively Definition idnatc := idnat.
Time Definition test_idnat := Eval lazy in test idnatc.

(** Check that optimization of singleton pattern-matchings work *)
Definition singlelim := ((fun (X : Set) (x : X) (e : x = x) =>
                  match e in eq _ x' return bool with
                  | eq_refl => true
                  end)).

Definition erase {A} (a : A) : TemplateMonad unit :=
  aq <- tmQuoteRec a ;;
  s <- tmEval lazy (erase_and_print_template_program aq) ;;
  tmMsg s.

Definition erase_fast {A} (a : A) : TemplateMonad unit :=
  aq <- tmQuoteRec a ;;
  s <- tmEval lazy (erase_fast_and_print_template_program aq) ;;
  tmMsg s.

MetaCoq Run (erase 0).
MetaCoq Run (tmEval hnf idnat >>= erase).
MetaCoq Run (tmEval hnf singlelim >>= erase).
MetaCoq Run (erase (plus 0 1)).

(** vector addition **)
Require Coq.Vectors.Vector.

Definition vplus {n:nat} :
  Vector.t nat n -> Vector.t nat n -> Vector.t nat n := (Vector.map2 plus).
Definition v01 : Vector.t nat 2 :=
  (Vector.cons nat 0 1 (Vector.cons nat 1 0 (Vector.nil nat))).
Definition v23 : Vector.t nat 2 :=
  (Vector.cons nat 2 1 (Vector.cons nat 3 0 (Vector.nil nat))).
Definition vplus0123 := (vplus v01 v23).

Set MetaCoq Timing.

Time MetaCoq Run (tmEval hnf vplus0123 >>= erase).
Time MetaCoq Run (tmEval hnf vplus0123 >>= erase_fast).

(** Ackermann **)
Fixpoint ack (n m:nat) {struct n} : nat :=
  match n with
    | 0 => S m
    | S p => let fix ackn (m:nat) {struct m} :=
                 match m with
                   | 0 => ack p 1
                   | S q => ack p (ackn q)
                 end
             in ackn m
  end.
Definition ack35 := (ack 3 5).
MetaCoq Quote Recursively Definition cbv_ack35 :=
  ltac:(let t:=(eval cbv delta [ack35] in ack35) in exact t).

Time Definition testack35 := Eval lazy in test cbv_ack35.

(* [program] of the program *)
MetaCoq Quote Recursively Definition p_ack35 := ack35.

Time Definition testack352 := Eval lazy in test p_ack35. (* 0.041 *)

(** mutual recursion **)
Inductive tree (A:Set) : Set :=
  node : A -> forest A -> tree A
with forest (A:Set) : Set :=
     | leaf : A -> forest A
     | fcons : tree A -> forest A -> forest A.
Arguments leaf {A}.
Arguments fcons {A}.
Arguments node {A}.
Definition sf: forest bool := (fcons (node true (leaf false)) (leaf true)).
MetaCoq Quote Recursively Definition p_sf := sf.
Time Definition testp_sf := Eval lazy in test p_sf.

Fixpoint tree_size (t:tree bool) : nat :=
  match t with
    | node a f => S (forest_size f)
  end
with forest_size (f:forest bool) : nat :=
       match f with
         | leaf b => 1
         | fcons t f1 => (tree_size t + forest_size f1)
       end.

Definition arden: forest bool :=
  fcons (node true (fcons (node true (leaf false)) (leaf true)))
        (fcons (node true (fcons (node true (leaf false)) (leaf true)))
               (leaf false)).
MetaCoq Quote Recursively Definition p_arden := arden.
Definition arden_size := (forest_size arden).
MetaCoq Quote Recursively Definition cbv_arden_size :=
  ltac:(let t:=(eval cbv in arden_size) in exact t).
Definition ans_arden_size :=
 Eval lazy in test cbv_arden_size.
(* [program] of the program *)
MetaCoq Quote Recursively Definition p_arden_size := arden_size.

Definition P_arden_size := Eval lazy in test p_arden_size.

(** SASL tautology function: variable arity **)
Require Import Bool.
Fixpoint tautArg (n:nat) : Type :=
  match n with
    | 0 => bool
    | S n => bool -> tautArg n
  end.
Fixpoint taut (n:nat) : tautArg n -> bool :=
  match n with
    | 0 => (fun x => x)
    | S n => fun x => taut n (x true) && taut n (x false)
  end.
(* Pierce *)
Definition pierce := taut 2 (fun x y => implb (implb (implb x y) x) x).
MetaCoq Quote Recursively Definition cbv_pierce :=
  ltac:(let t:=(eval cbv in pierce) in exact t).

Definition ans_pierce :=
  Eval lazy in (test cbv_pierce).

(* [program] of the program *)
MetaCoq Quote Recursively Definition p_pierce := pierce.

Definition P_pierce := Eval lazy in test p_pierce.

(* Goal
  let env := (env P_pierce) in
  let main := (main P_pierce) in
  wcbvEval (env) 200 (main) = Ret ans_pierce.
  vm_compute. reflexivity.
Qed.
 *)(* S combinator *)
Definition Scomb := taut 3
         (fun x y z => implb (implb x (implb y z))
                             (implb (implb x y) (implb x z))).
MetaCoq Quote Recursively Definition cbv_Scomb :=
  ltac:(let t:=(eval cbv in Scomb) in exact t).

Definition ans_Scomb :=
  Eval lazy in (test cbv_Scomb).

(* [program] of the program *)
MetaCoq Quote Recursively Definition p_Scomb := Scomb.

Definition P_Scomb := Eval lazy in (test p_Scomb).

(* Goal
  let env := (env P_Scomb) in
  let main := (main P_Scomb) in
  wcbvEval (env) 200 (main) = Ret ans_pierce.
  vm_compute. reflexivity.
Qed.
 *)
(** Fibonacci **)
Fixpoint slowFib (n:nat) : nat :=
  match n with
    | 0 => 0
    | S m => match m with
               | 0 => 1
               | S p => slowFib p + slowFib m
             end
  end.
Definition slowFib3 := (slowFib 3).
MetaCoq Quote Recursively Definition cbv_slowFib3 :=
  ltac:(let t:=(eval cbv in slowFib3) in exact t).
Definition ans_slowFib3 :=
 Eval lazy in (test cbv_slowFib3).
(* [program] of the program *)
MetaCoq Quote Recursively Definition p_slowFib3 := slowFib3.
Definition P_slowFib3 := Eval lazy in (test p_slowFib3).
(* Goal
  let env := (env P_slowFib3) in
  let main := (main P_slowFib3) in
  wcbvEval (env) 30 (main) = Ret ans_slowFib3.
  vm_compute. reflexivity.
Qed.
 *)
(* fast Fib *)
Fixpoint fibrec (n:nat) (fs:nat * nat) {struct n} : nat :=
  match n with
    | 0 => fst fs
    | (S n) => fibrec n (pair ((fst fs) + (snd fs)) (fst fs))
  end.
Definition fib : nat -> nat := fun n => fibrec n (pair 0 1).
Definition fib9 := fib 9.
MetaCoq Quote Recursively Definition cbv_fib9 :=
  ltac:(let t:=(eval cbv in fib9) in exact t).
Time Definition ans_fib9 :=
  Eval lazy in (test cbv_fib9).
(* [program] of the program *)
MetaCoq Quote Recursively Definition p_fib9 := fib9.
Definition P_fib9 := Eval lazy in (test p_fib9).
(*
Goal
  let env := (env P_fib9) in
  let main := (main P_fib9) in
  wcbvEval (env) 1000 (main) = Ret ans_fib9.
  vm_compute. reflexivity.
Qed.
 *)

Module HetList.
(** Heterogenous datatypes, a la Matthes **)
Inductive PList : Set->Type:=  (* powerlists *)
| zero : forall A:Set, A -> PList A
| succ : forall A:Set, PList (A * A)%type -> PList A.
Arguments zero {A}.
Arguments succ {A}.
Definition myPList : PList nat :=
  succ (succ (succ (zero (((1,2),(3,4)),((5,6),(7,8)))))).
Unset Asymmetric Patterns.
Fixpoint unzip {A:Set} (l:list (A*A)) {struct l} : list A :=
  match l return list A with
    | nil => nil
    | cons (a1,a2) l' => cons a1 (cons a2 (unzip l'))
  end.
Fixpoint PListToList {A:Set} (l:PList A) {struct l} : list A :=
  match l in PList A return list A with
    | zero a => cons a (nil )
    | succ l' => unzip (PListToList l')
  end.

Time Definition test_myPList := Eval compute in PListToList myPList.

Fixpoint gen_sumPList {A:Set} (l:PList A) {struct l} : (A->nat)->nat :=
  match l in PList A return (A->nat)->nat with
    | zero a => fun f => f a
    | succ l' =>
      fun f => gen_sumPList l' (fun a => let (a1,a2) := a in f a1 + f a2)
  end.
Definition sumPList l := gen_sumPList l (fun x => x).
Definition sumPL_myPL := (sumPList myPList).
MetaCoq Quote Recursively Definition cbv_sumPL_myPL :=
  ltac:(let t:=(eval cbv in sumPL_myPL) in exact t).
Definition ans_sumPL_myPL :=
  Eval lazy in (test cbv_sumPL_myPL).
(* [program] of the program *)
MetaCoq Quote Recursively Definition p_sumPL_myPL := sumPL_myPL.
Definition P_sumPL_myPL := Eval lazy in (test p_sumPL_myPL).
(* Goal
  let env := (env P_sumPL_myPL) in
  let main := (main P_sumPL_myPL) in
  wcbvEval (env) 1000 (main) = Ret ans_sumPL_myPL.
  vm_compute. reflexivity.
Qed.
 *)

Set Implicit Arguments.
Section List.
Variables X Y : Type.
Variable f : X -> Y -> Y.
Fixpoint fold (y : Y) (xs : list X) : Y :=
  match xs with
    | nil => y
    | cons x xr => fold (f x y) xr
  end.
End List.
Inductive Tree := T : list Tree -> Tree.
Fixpoint size (t : Tree) : nat :=
  match t with
    | T ts => S (fold (fun t a => size t + a) 0 ts)
  end.
  Definition unit {A} (a : A) : list A := cons a nil.
  Definition myTree :=
  (T (cons (T (unit (T nil))) (cons (T (unit (T nil))) nil))).

Definition size_myTree := size myTree.
MetaCoq Quote Recursively Definition cbv_size_myTree :=
  ltac:(let t:=(eval cbv in size_myTree) in exact t).
Definition ans_size_myTree :=
  Eval lazy in (test cbv_size_myTree).
(* [program] of the program *)
MetaCoq Quote Recursively Definition p_size_myTree := size_myTree.
Definition P_size_myTree := Eval lazy in (test p_size_myTree).
(* Goal
  let env := (env P_size_myTree) in
  let main := (main P_size_myTree) in
  wcbvEval (env) 100 (main) = Ret ans_size_myTree.
  vm_compute. reflexivity.
Qed.
 *)
End HetList.

Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Arith Init.Wf.
Program Fixpoint provedCopy (n:nat) {wf lt n} : nat :=
  match n with 0 => 0 | S k => S (provedCopy k) end.
Print Assumptions provedCopy.
(* MetaCoq Quote Recursively Definition pCopy := provedCopy. program *)

Definition x := 3.
Definition provedCopyx := provedCopy x.
(* Compute provedCopyx.  * evals correctly in Coq * *)
MetaCoq Quote Recursively Definition cbv_provedCopyx :=
  ltac:(let t:=(eval cbv delta [provedCopyx provedCopy] in provedCopyx) in exact t).
Definition ans_provedCopyx :=
  Eval lazy in (test cbv_provedCopyx).
MetaCoq Quote Recursively Definition p_provedCopyx := provedCopyx. (* program *)
Time Definition P_provedCopyx := Eval lazy in (test_fast cbv_provedCopyx).
(* We don't run this one every time as it is really expensive *)
(*Time Definition P_provedCopyxvm := Eval vm_compute in (test p_provedCopyx).*)

From MetaCoq.ErasurePlugin Require Import Loader.

MetaCoq Erase provedCopyx.
(* 0.2s purely in the bytecode VM *)
(*Time Definition P_provedCopyxvm' := Eval vm_compute in (test p_provedCopyx). *)
(* Goal
  let env := (env P_provedCopyx) in
  let main := (main P_provedCopyx) in
  wcbvEval (env) 100 (main) = Ret ans_provedCopyx.
  vm_compute. reflexivity.
Qed.
 *)

 (* debug code in case something is stuck *)
 (*
 From MetaCoq.SafeChecker Require Import PCUICSafeChecker.

Definition fold_matchdecl {A B} (e : EnvCheck A) (b : A -> B) (c : PCUICAst.global_env_ext -> env_error -> B) :=
    match e with
    |CorrectDecl a => b a
    |EnvError g a => c g a
    end.

Ltac fold_matchdecls' := repeat
    match goal with
    |- context C [?x] =>
    match x with
    | match ?l with CorrectDecl a => @?b a | EnvError g a' => @?c g a' end =>
    change x with (fold_matchdecl l b c)
    end
    end.

    Set Printing Depth 20.

Ltac eval_first :=
match goal with
|- context C [fold_matchdecl ?l ?p ?g] =>
  match l with
  (* | fold_matchdecl _ _ _ => fail 1
   *)| _ =>
    idtac "evaluating" l;
    let l' := eval lazy in l in
    let C' := context C [ fold_matchdecl l' p g] in
    convert_concl_no_check C'
  end
end.

Ltac show_match :=
  match goal with
  |- context [match ?x with _ => _ end] =>
    match x with
    | match _ with _ => _ end => fail 1
    | fold_matchdecl _ _ _ => fail 1
    | _ => idtac x
    end
  end.

Goal exists  r, test plusr = r.
Proof.
  eexists.
  unfold  test.
  unfold erase_and_print_template_program.
  unfold erase_template_program.
  unfold bind.
  unfold PCUICSafeChecker.envcheck_monad.
  fold_matchdecls'.
  eval_first.
  show_match.

*)


(* Constructor inteligente *)
Definition smartTrie1 (t1 t2: binTrie1) : binTrie1 :=
match t1, t2 with
| empty1, empty1 => empty1
| _, _ => trie1 t1 t2
end.


(* * A New Logic  for the specification of Turing Machines, Based on Hoare Logic *)

From Undecidability.TM.Hoare Require Export HoareLogic. (** Abstract definition of Hoare triples *)
From Undecidability.TM.Hoare Require Export HoareCombinators. (** Rules for the combinators *)
From Undecidability.TM.Hoare Require Export HoareRegister. (** Definition of a specification language for Register machines; rules for lifts *)
From Undecidability.TM.Hoare Require Export HoareTactics HoareTacticsView. (** Verification step tactics *)
From Undecidability.TM.Hoare Require Export HoareStdLib. (** Hoare rules for standard machine *)
From Undecidability.TM.Hoare Require Export HoareLegacy. (** generating Legacy Lemmas for Realise/Terminates *)

(* TODO:
- Prefix "_size" or "_space"?
- Univ
*)