(* Rappel syntaxe Coq : les commentaires s'écrivent entre (* et *). *)

(* TAPFA - Partie Coq - TP 1 *)

(* Rappel de l'URL des supports de Cours :

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

(* Le sujet des 2 TP TAPFA se présentent sous la forme d'un fichier .v
   à compléter. Vous pouvez coder vos réponses :
   - dans Emacs+ProofGeneral (environnement de TP recommandé :

     https://moodle.univ-tlse3.fr/course/view.php?id=183#env-tp ;
     https://github.com/erikmd/tapfa-init.el )

   - ou dans JsCoq (éditeur en ligne, pratique mais moins performant :
     https://jscoq.github.io/scratchpad.html )
 *)

(* N'hésitez pas à solliciter votre encadrant de TP sur Discord
   pour toute question. *)

(* Pour évaluer les phrases dans Emacs+ProofGeneral :
   - aller jusqu'au curseur en faisant "C-c RET" (<=> Ctrl+C Entrée)
     ou "C-c C-RET"
   - avancer/reculer d'un cran avec "C-c C-n" et "C-c C-u"
   - et pour aller à la fin de la zone validée, faire "C-c C-."

  Pour évaluer les phrases dans l'éditeur en ligne,
  utiliser les trois boutons adéquats (ou Alt+N, Alt+P, Alt+Entrée) *)

(*********************************************************)
(* D'abord un petit peu de programmation (fonctionnelle) *)
(*********************************************************)

(* Définissons la fonction qui à n, associe n + 1. *)

(* En OCaml, on aurait écrit :

   let f = fun n -> n + 1;;
 *)

(* En Coq, on écrit : *)

Definition f := fun n => n + 1.

(* En maths, on écrirait :

   f : N ⟶ N
       n ↦ n+1

   "↦" ("\mapsto" en LaTeX) s'écrira "fun … => …" en Coq.

   La partie "N ⟶ N" existe aussi en Coq et est appelée «type» de la fonction.

   Ici Coq l'a automatiquement inféré, on peut l'afficher avec : *)

Check f.

Print f.

(* On aurait aussi pu le donner explicitement *)
Definition f2 : nat -> nat := fun n => n + 1.

(* Contrairement à OCaml, il est impossible de définir en Coq deux
   fonctions (ou types) ayant le même nom dans le même fichier ;
   ainsi, cela permet d'éviter des confusions. *)
Fail Definition f2 := fun n => n + 2.
(* La commande "Fail" vérifie que la phrase qui suit donne une erreur,
   ignore celle-ci et permet de continuer tout de même.
   Cette commande a donc essentiellement un but de «documentation». *)

(* De manière générale, "t : T" se lit «t est de type T».
   On peut mettre de telles «annotations de type» un peu partout et
   t n'est pas nécessairement une fonction. *)
Definition f3 := fun (n : nat) => n + 1.

(* Autre syntaxe : pour éviter d'avoir à écrire fun, on peut également
   écrire le nom de l'argument après celui de la fonction, avant ":="
   (et c'est dorénavant ce que l'on fera). *)
Definition f4 n := n + 1.

(* La syntaxe change mais c'est exactement la même fonction, comme la
   montre la commande Print. *)
Print f4.
Print f.  (* même résultat *)

(* Comme avec tout langage de programmation, on peut évaluer les fonctions *)
Eval compute in f 2.
(* Tout comme en OCaml, on pourrait écrire "f(2)", mais les parenthèses
   ne servent à rien s'il n'y a pas de sous-expression à regrouper ;
   on utilise donc généralement simplement un espace : "f 2" *)

(* On peut aussi demander le type de f 2 *)
Check f 2.
(* Bien sûr, il faut que le terme soit bien typé. Ceci échoue : *)
Fail Check f f.
(* Commentez la ligne précédente (ou ajoutez la commande "Fail" devant)
pour pouvoir continuer *)

(****************************************************)
(* Petit rappel sur les fonctions d'ordre supérieur *)
(****************************************************)

(* Comme en OCaml, on peut définir des fonctions curryfiées
(c.-à-d. prenant deux arguments ou plus) : *)
Definition g x y := x + 2 * y.
Print g.

(* syntaxes équivalentes *)
Definition g2 := fun x y => x + 2 * y.
Definition g3 := fun x => (fun y => x + 2 * y).

(* Regardons le type de g *)
Check g.
(* on obtient «nat -> nat -> nat» qui se lit «nat -> (nat -> nat)»
   c.-à-d. la fonction g est une fonction à un argument (x), qui
   renvoie une fonction prenant un argument (y) et retournant x+2y. *)
Check g 1.

(* pour l'évaluation, on peut donc écrire *)
Eval compute in (g 1) 3.
(* ou plus simplement *)
Eval compute in g 1 3.

(* On peut aussi définir des fonctionnelles, c.-à-d. des fonctions
prenant des fonctions en argument : *)
Definition repeat_twice f (x : nat) := f (f x).

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

Check rtwice.
Check repeat_twice.
(* repeat_twice *)
(*      : (nat -> nat) -> nat -> nat *)

Print f.
Eval compute in repeat_twice f 2.

(******************************************************************)
(* Encore un peu de programmation, quelques structures de données *)
(******************************************************************)

(* un des types les plus simples : les booléens *)
Check true.
Check false.

(* Les booléens sont définis dans la bibliothèque standard de Coq
comme un type utilisateur à 2 constructeurs :

un booléen est soit true, soit false (et rien d'autre) *)
Print bool.

(* true et false sont ainsi des constructeurs. Notez au passage qu'il
n'y a pas de contrainte sur la «casse» des constructeurs dans Coq :
pas besoin qu'ils commencent par une majuscule. *)

(* on peut examiner la valeur d'un booléen avec un match *)

Definition et a b :=
  match a with
  | true => b
  | false => false
  end.

(* L'écriture "if b then ct else cf" est juste du sucre syntaxique
pour le match ci-dessus et c'est l'écriture simplifiée par défaut : *)

Print et.

(* Mais on peut passer en mode "affichage bas-niveau" pour désactiver
cette écriture simplifiée : *)

Set Printing All.

Print et.

Unset Printing All.

Eval compute in et true false.

Eval compute in et true true.

(* Similairement à OCaml, on est obligé de définir tous les cas, mais
   le «filtrage non-exhaustif» est une erreur, pas un warning
   (commenter pour pouvoir continuer) *)
Fail Definition et_non_exhaustif a b :=
  match a with
  | true => b
  end.

(* La bibliothèque standard de Coq fournit des notations "&&", "||"
associée aux définitions "andb" (identique à notre définition "et"
donc dans la suite on utilisera donc "andb" plutôt que "et"), "orb",
et "negb" : *)

Check andb false true.
Check (false && true)%bool.

Check orb false true.
Check (false || true)%bool.

Check negb false.

Eval compute in negb false.

(* Une invocation possible pour avoir des notations plus légères : *)
Open Scope bool_scope.

Check andb false true.
Check orb false true.

(* un type un peu plus complexe : les entiers naturels.

Ils sont définis dans la bibliothèque standard de Coq comme un type
utilisateur à 2 constructeurs :

un entier est soit O, soit le successeur d'un entier. *)
Print nat.

(* Notez que la syntaxe affichée par Coq est équivalente à la syntaxe
suivante, vue en cours :

Inductive nat :=
  | O
  | S (_ : nat). *)

(* Au moment où ce type nat est défini dans la bibliothèque standard,
   Coq génère automatiquement le principe d'induction "nat_ind", qui
   coïncide naturellement avec le schéma de "preuve par récurrence",
   que l'on (re)verra lors du TP2. *)
Check nat_ind.

(* À noter, la représentation des entiers sous cette forme correspond
   à une "représentation en base 1", c'est-à-dire que le nombre entier
   16, même si Coq le "lit" et "l'écrit" en base 10 avec les options
   d'affichage par défaut, en interne, il est stocké sous la forme
   d'une expression inductive impliquant 17 constructeurs ! *)

Set Printing All.
Check 16.
Unset Printing All.
Check 17.

(* Bien entendu, d'autres représentations plus compactes des entiers
   naturels (en binaire…) et des entiers relatifs, sont disponibles
   dans la bibliothèque standard de Coq, mais nous n'approfondirons
   pas cet aspect durant ce TP TAPFA. *)

(* Nous avons rappelé précédemment (fonction "et") la syntaxe de Coq
   pour effectuer un filtrage (syntaxe très proche de celle d'OCaml !)

   Quant à l'équivalent du "let rec" en Coq, il s'agit d'utiliser
   la commande "Fixpoint".
   En revanche, nous n'utiliserons pas l'équivalent Coq de la syntaxe
   "let rec … in", puisqu'en pratique cela rendrait plus compliqué les
   preuves de propriétés de la fonction définie localement... *)

(* Définir la fonction "factorielle" de type "nat -> nat".
   Puis calculer "factorielle 3".

   Rappel sur la récursion : il faut que vous veilliez à ce que vos
   définitions de fonctions récursives aient des appels récursifs dont
   l'argument principal soit décroissant structurellement (pour
   garantir la terminaison. Sinon, Coq refusera votre définition ! *)

Fixpoint factorielle (n : nat) :=
  match n with
  | 0 => 1
  | S p => factorielle p * n
  end.

Eval compute in factorielle 8.

(* Définir le prédicat booléen "pair" de type "nat -> bool".
   Puis calculer "pair 6". *)

Fixpoint pair n :=
  match n with
  | 0 => true
  | S 0 => false
  | S (S p) => pair p
  end.

Eval compute in pair 6.

(* Pour conclure sur cette revue du filtrage et de la récursion en Coq
   voici un exemple de définition d'un prédicat booléen "inf",
   testant si un entier n est plus petit ou égal à un autre entier m.
   Pouvez-vous expliquer avec vos propres mots chacune des branches du
   match ? (qui correspond ici à un filtrage simultané !) *)
Fixpoint inf n m :=
  match n,m with
  | O, _ => true            (* si n=0, alors ∀m, n<=m *)
  | S n1, O => false        (* si n>0 et m=0, alors n>m *)
  | S n1, S m1 => inf n1 m1 (* si n>0 et m>0, alors vérifier avec les préds de n et m *)
  end.

Require Extraction.

Recursive Extraction inf.

Check inf.
Eval compute in inf 2 3.
Eval compute in inf 1 0.

(* Remarque : ne pas confondre les opérations booléennes «calculables»
&&, || et negb, avec les connecteurs logiques /\, \/ et ~, qui ne
prennent pas en argument des booléens mais des Propositions : *)

Check 0 = 0.
(* 0 = 0 *)
(*      : Prop *)

Check (0 = 0) /\ (0 = 0).

Check 0 < 1 \/ 0 = 1 \/ 0 > 1.

(* "/\" est ainsi une notation pour and,
   "\/" pour or,
   "~" pour not *)

Check and (0 = 0) (0 = 0).
Check or (0 < 1) (or (0 = 1) (0 > 1)).

(* Q1. Qu'est-ce qu'une proposition dans Coq ?
   Q2. comment montrer qu'une proposition est vraie ?

Avant de faire des exercices spécifiques pour prouver des propositions
simples de 3 façons différentes (à la main, de façon semi-automatique
ou complètement automatique), deux réponses rapides :

R1. Une proposition est une formule logique, et dans Coq c'est à la
fois un objet de type Prop, et un type de données dont les expressions
de ce type sont les preuves de la formule en question.

Cela correspond à la notion de «correspondance de Curry-Howard» vue en
cours.

Par exemple, on aura  (preuve que 0=0) : 0 = 0 : Prop

Ainsi, Prop est un "type de type", au même titre que le mot-clé Type
vu en cours.

Il y a quelques différences de sémantique entre Prop et Type que nous
ne détaillerons pas ici. (La principale idée étant que Type correspond
au type des «types de données informatifs» (entiers,listes,fonctions),
Prop correspond au type des «formules purement logiques».)

R2. Pour montrer qu'une proposition P est vraie, il s'agit d'exhiber
une preuve, c'est-à-dire une expression p qui a le bon type (p : P).

Le but de l'assistant de preuves Coq est de faciliter la construction
de ces termes de preuve (p), puis au moment du "Qed.", de vérifier
automatiquement que le type du terme de preuve coïncide avec l'énoncé
de la formule que l'on veut prouver.

Maintenant, des exercices. *)

(**************************************************************)
(* Premières preuves "à la main", en logique propositionnelle *)
(**************************************************************)

Section PremieresPreuves.

(* Dans cette section, supposons trois propositions A, B et C *)
Variables A B C : Prop.

(* une fonction est une preuve : par exemple, la fonction identité
   "prouve" que A implique A *)
Definition identite : A -> A := fun a => a.

(* prouver les propriétés suivantes *)

Definition ex0 : B -> B := fun b => b.

Definition ex1 : A -> B -> A := fun a => fun b => a.

Definition ex2 : A -> B -> B := fun a b => b.

Definition ex3 : A -> (A -> B) -> B := fun a ab => ab a.

Definition ex4 : (A -> B) -> (B -> C) -> A -> C := fun ab bc a => bc (ab a).

Definition ex5 : (A -> B) -> (A -> B -> C) -> A -> C := fun ab abc a => (abc a) (ab a).

Theorem cinQ : (A -> B) -> (A -> B -> C) -> A -> C.
intros H1.
intros H2.
intros H3.
apply H2.
exact H3.
apply H1.
exact H3.
Qed.
(* auto. *)

(*
Theorem distr_and_or : (A /\ B) \/ (A /\ C) -> A /\ (B \/ C).
intros H.
destruct H as [H1 | H2].
split.*)


From sortalgs Require Export order.
Require Export Sorting.Permutation.

Import List.ListNotations.
Open Scope list_scope.

Inductive Sorted {A} `{DecTotalOrder A} : list A -> Prop :=
| Sorted_0 : Sorted []
| Sorted_1 : forall x, Sorted [x]
| Sorted_2 : forall x y l, Sorted (y :: l) -> leb x y ->
                           Sorted (x :: y :: l).

Lemma lem_sorted_tail `{DecTotalOrder} :
  forall l x, Sorted (x :: l) -> Sorted l.
Proof.
  sauto.
Qed.

(*********************************************************************)

Fixpoint sortedb {A} `{DecTotalOrder A} (l : list A) : bool :=
  match l with
  | [] => true
  | [x] => true
  | x :: (y :: l') as t => leb x y && sortedb t
  end.

Lemma lem_sortedb_iff_sorted `{DecTotalOrder} :
  forall l : list A, sortedb l <-> Sorted l.
Proof.
  induction l; sauto brefl: on inv: Sorted.
Qed.

(*********************************************************************)

Definition LeLst `{DecTotalOrder} x :=
  List.Forall (leb x).

Lemma lem_lelst_nil `{DecTotalOrder} : forall x, LeLst x [].
Proof.
  sauto.
Qed.

Lemma lem_lelst_cons `{DecTotalOrder} :
  forall x y l, LeLst x l -> leb x y -> LeLst x (y :: l).
Proof.
  sauto.
Qed.

Global Hint Resolve lem_lelst_nil lem_lelst_cons : lelst.

Lemma lem_lelst_trans `{DecTotalOrder} :
  forall l x y, LeLst y l -> leb x y -> LeLst x l.
Proof.
  induction 1; sauto.
Qed.

Lemma lem_lelst_perm `{DecTotalOrder} :
  forall l1 l2 x, Permutation l1 l2 -> LeLst x l1 -> LeLst x l2.
Proof.
  induction 1; sauto lq: on.
Qed.

Lemma lem_lelst_perm_rev `{DecTotalOrder} :
  forall l1 l2 x, Permutation l1 l2 -> LeLst x l2 -> LeLst x l1.
Proof.
  induction 1; sauto lq: on.
Qed.

Lemma lem_lelst_app `{DecTotalOrder} :
  forall l1 l2 x, LeLst x l1 -> LeLst x l2 -> LeLst x (l1 ++ l2).
Proof.
  induction 1; sauto lq: on.
Qed.

Global Hint Resolve lem_lelst_trans lem_lelst_perm lem_lelst_perm_rev
       lem_lelst_app : lelst.

Lemma lem_lelst_sorted `{DecTotalOrder} :
  forall l x, Sorted (x :: l) <-> LeLst x l /\ Sorted l.
Proof.
  induction l; sauto l: on use: lem_lelst_trans
                     inv: Sorted, List.Forall ctrs: Sorted.
Qed.

(*********************************************************************)

Definition GeLst `{DecTotalOrder} x l :=
  List.Forall (fun y => leb y x) l.

Lemma lem_gelst_nil `{DecTotalOrder} : forall x, GeLst x [].
Proof.
  sauto.
Qed.

Lemma lem_gelst_cons `{DecTotalOrder} :
  forall x y l, GeLst x l -> leb y x -> GeLst x (y :: l).
Proof.
  sauto.
Qed.

Global Hint Resolve lem_gelst_nil lem_gelst_cons : gelst.

Lemma lem_gelst_trans `{DecTotalOrder} :
  forall l x y, GeLst y l -> leb y x -> GeLst x l.
Proof.
  induction 1; sauto.
Qed.

Lemma lem_gelst_perm `{DecTotalOrder} :
  forall x l1 l2, Permutation l1 l2 -> GeLst x l1 -> GeLst x l2.
Proof.
  induction 1; sauto lq: on.
Qed.

Lemma lem_gelst_perm_rev `{DecTotalOrder} :
  forall l1 l2 x, Permutation l1 l2 -> GeLst x l2 -> GeLst x l1.
Proof.
  induction 1; sauto lq: on.
Qed.

Lemma lem_gelst_app `{DecTotalOrder} :
  forall l1 l2 x, GeLst x l1 -> GeLst x l2 -> GeLst x (l1 ++ l2).
Proof.
  induction 1; sauto lq: on.
Qed.

Global Hint Resolve lem_gelst_trans lem_gelst_perm lem_gelst_perm_rev
     lem_gelst_app : gelst.


(* Copyright (c) 2008-2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Arith List.

Require Import CpdtTactics.

Set Implicit Arguments.
(* end hide *)

(** %\chapter{Dependent Data Structures}% *)

(** Our red-black tree example from the last chapter illustrated how dependent types enable static enforcement of data structure invariants.  To find interesting uses of dependent data structures, however, we need not look to the favorite examples of data structures and algorithms textbooks.  More basic examples like length-indexed and heterogeneous lists come up again and again as the building blocks of dependent programs.  There is a surprisingly large design space for this class of data structure, and we will spend this chapter exploring it. *)

(** * More Length-Indexed Lists *)

(** We begin with a deeper look at the length-indexed lists that began the last chapter.%\index{Gallina terms!ilist}% *)

Section ilist.
  Variable A : Set.

  Inductive ilist : nat -> Set :=
  | Nil : ilist O
  | Cons : forall n, A -> ilist n -> ilist (S n).

  (** We might like to have a certified function for selecting an element of an [ilist] by position.  We could do this using subset types and explicit manipulation of proofs, but dependent types let us do it more directly.  It is helpful to define a type family %\index{Gallina terms!fin}%[fin], where [fin n] is isomorphic to [{m : nat | m < n}].  The type family name stands for "finite." *)

  (* EX: Define a function [get] for extracting an [ilist] element by position. *)

(* begin thide *)
  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  (** An instance of [fin] is essentially a more richly typed copy of a prefix of the natural numbers.  Every element is a [First] iterated through applying [Next] a number of times that indicates which number is being selected.  For instance, the three values of type [fin 3] are [First 2], [Next (First 1)], and [Next (Next (First 0))].

     Now it is easy to pick a [Prop]-free type for a selection function.  As usual, our first implementation attempt will not convince the type checker, and we will attack the deficiencies one at a time.
     [[
  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx => ?
      | Cons _ x ls' => fun idx =>
        match idx with
          | First _ => x
          | Next _ idx' => get ls' idx'
        end
    end.
    ]]
    %\vspace{-.15in}%We apply the usual wisdom of delaying arguments in [Fixpoint]s so that they may be included in [return] clauses.  This still leaves us with a quandary in each of the [match] cases.  First, we need to figure out how to take advantage of the contradiction in the [Nil] case.  Every [fin] has a type of the form [S n], which cannot unify with the [O] value that we learn for [n] in the [Nil] case.  The solution we adopt is another case of [match]-within-[return], with the [return] clause chosen carefully so that it returns the proper type [A] in case the [fin] index is [O], which we know is true here; and so that it returns an easy-to-inhabit type [unit] in the remaining, impossible cases, which nonetheless appear explicitly in the body of the [match].
    [[
  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | Cons _ x ls' => fun idx =>
        match idx with
          | First _ => x
          | Next _ idx' => get ls' idx'
        end
    end.
    ]]
    %\vspace{-.15in}%Now the first [match] case type-checks, and we see that the problem with the [Cons] case is that the pattern-bound variable [idx'] does not have an apparent type compatible with [ls'].  In fact, the error message Coq gives for this exact code can be confusing, thanks to an overenthusiastic type inference heuristic.  We are told that the [Nil] case body has type [match X with | O => A | S _ => unit end] for a unification variable [X], while it is expected to have type [A].  We can see that setting [X] to [O] resolves the conflict, but Coq is not yet smart enough to do this unification automatically.  Repeating the function's type in a [return] annotation, used with an [in] annotation, leads us to a more informative error message, saying that [idx'] has type [fin n1] while it is expected to have type [fin n0], where [n0] is bound by the [Cons] pattern and [n1] by the [Next] pattern.  As the code is written above, nothing forces these two natural numbers to be equal, though we know intuitively that they must be.

    We need to use [match] annotations to make the relationship explicit.  Unfortunately, the usual trick of postponing argument binding will not help us here.  We need to match on both [ls] and [idx]; one or the other must be matched first.  To get around this, we apply the convoy pattern that we met last chapter.  This application is a little more clever than those we saw before; we use the natural number predecessor function [pred] to express the relationship between the types of these variables.
    [[
  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | Cons _ x ls' => fun idx =>
        match idx in fin n' return ilist (pred n') -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun ls' => get ls' idx'
        end ls'
    end.
    ]]
    %\vspace{-.15in}%There is just one problem left with this implementation.  Though we know that the local [ls'] in the [Next] case is equal to the original [ls'], the type-checker is not satisfied that the recursive call to [get] does not introduce non-termination.  We solve the problem by convoy-binding the partial application of [get] to [ls'], rather than [ls'] by itself. *)

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | Cons _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.
(* end thide *)
End ilist.

Implicit Arguments Nil [A].
Implicit Arguments First [n].

(** A few examples show how to make use of these definitions. *)

Check Cons 0 (Cons 1 (Cons 2 Nil)).
(** %\vspace{-.15in}% [[
  Cons 0 (Cons 1 (Cons 2 Nil))
     : ilist nat 3
]]
*)

(* begin thide *)
Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) First.
(** %\vspace{-.15in}% [[
     = 0
     : nat
]]
*)

Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) (Next First).
(** %\vspace{-.15in}% [[
     = 1
     : nat
]]
*)

Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) (Next (Next First)).
(** %\vspace{-.15in}% [[
     = 2
     : nat
]]
*)
(* end thide *)

(* begin hide *)
(* begin thide *)
Definition map' := map.
(* end thide *)
(* end hide *)

(** Our [get] function is also quite easy to reason about.  We show how with a short example about an analogue to the list [map] function. *)

Section ilist_map.
  Variables A B : Set.
  Variable f : A -> B.

  Fixpoint imap n (ls : ilist A n) : ilist B n :=
    match ls with
      | Nil => Nil
      | Cons _ x ls' => Cons (f x) (imap ls')
    end.

  (** It is easy to prove that [get] "distributes over" [imap] calls. *)

(* EX: Prove that [get] distributes over [imap]. *)

(* begin thide *)
  Theorem get_imap : forall n (idx : fin n) (ls : ilist A n),
    get (imap ls) idx = f (get ls idx).
    induction ls; dep_destruct idx; crush.
  Qed.
(* end thide *)
End ilist_map.

(** The only tricky bit is remembering to use our [dep_destruct] tactic in place of plain [destruct] when faced with a baffling tactic error message. *)

(** * Heterogeneous Lists *)

(** Programmers who move to statically typed functional languages from scripting languages often complain about the requirement that every element of a list have the same type.  With fancy type systems, we can partially lift this requirement.  We can index a list type with a "type-level" list that explains what type each element of the list should have.  This has been done in a variety of ways in Haskell using type classes, and we can do it much more cleanly and directly in Coq. *)

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  (* EX: Define a type [hlist] indexed by a [list A], where the type of each element is determined by running [B] on the corresponding element of the index list. *)

  (** We parameterize our heterogeneous lists by a type [A] and an [A]-indexed type [B].%\index{Gallina terms!hlist}% *)

(* begin thide *)
  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  (** We can implement a variant of the last section's [get] function for [hlist]s.  To get the dependent typing to work out, we will need to index our element selectors (in type family [member]) by the types of data that they point to.%\index{Gallina terms!member}% *)

(* end thide *)
  (* EX: Define an analogue to [get] for [hlist]s. *)

(* begin thide *)
  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  (** Because the element [elm] that we are "searching for" in a list does not change across the constructors of [member], we simplify our definitions by making [elm] a local variable.  In the definition of [member], we say that [elm] is found in any list that begins with [elm], and, if removing the first element of a list leaves [elm] present, then [elm] is present in the original list, too.  The form looks much like a predicate for list membership, but we purposely define [member] in [Type] so that we may decompose its values to guide computations.

     We can use [member] to adapt our definition of [get] to [hlist]s.  The same basic [match] tricks apply.  In the [HCons] case, we form a two-element convoy, passing both the data element [x] and the recursor for the sublist [mls'] to the result of the inner [match].  We did not need to do that in [get]'s definition because the types of list elements were not dependent there. *)

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => B elm
                                          | _ :: _ => unit
                                        end) with
          | HFirst _ => tt
          | HNext _ _ _ => tt
        end
      | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => Empty_set
                                          | x' :: ls'' =>
                                            B x' -> (member ls'' -> B elm)
                                            -> B elm
                                        end) with
          | HFirst _ => fun x _ => x
          | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.
(* end thide *)
End hlist.

(* begin thide *)
Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].

Implicit Arguments HFirst [A elm ls].
Implicit Arguments HNext [A elm x ls].
(* end thide *)

(** By putting the parameters [A] and [B] in [Type], we enable fancier kinds of polymorphism than in mainstream functional languages.  For instance, one use of [hlist] is for the simple heterogeneous lists that we referred to earlier. *)

Definition someTypes : list Set := nat :: bool :: nil.

(* begin thide *)

Example someValues : hlist (fun T : Set => T) someTypes :=
  HCons 5 (HCons true HNil).

Eval simpl in hget someValues HFirst.
(** %\vspace{-.15in}% [[
     = 5
     : (fun T : Set => T) nat
]]
*)

Eval simpl in hget someValues (HNext HFirst).
(** %\vspace{-.15in}% [[
     = true
     : (fun T : Set => T) bool
]]
*)

(** We can also build indexed lists of pairs in this way. *)

Example somePairs : hlist (fun T : Set => T * T)%type someTypes :=
  HCons (1, 2) (HCons (true, false) HNil).

(** There are many other useful applications of heterogeneous lists, based on different choices of the first argument to [hlist]. *)

(* end thide *)

(** ** A Lambda Calculus Interpreter *)

(** Heterogeneous lists are very useful in implementing %\index{interpreters}%interpreters for functional programming languages.  Using the types and operations we have already defined, it is trivial to write an interpreter for simply typed lambda calculus%\index{lambda calculus}%.  Our interpreter can alternatively be thought of as a denotational semantics (but worry not if you are not familiar with such terminology from semantics).

   We start with an algebraic datatype for types. *)

Inductive type : Set :=
| Unit : type
| Arrow : type -> type -> type.

(** Now we can define a type family for expressions.  An [exp ts t] will stand for an expression that has type [t] and whose free variables have types in the list [ts].  We effectively use the de Bruijn index variable representation%~\cite{DeBruijn}%.  Variables are represented as [member] values; that is, a variable is more or less a constructive proof that a particular type is found in the type environment. *)

Inductive exp : list type -> type -> Set :=
| Const : forall ts, exp ts Unit
(* begin thide *)
| Var : forall ts t, member t ts -> exp ts t
| App : forall ts dom ran, exp ts (Arrow dom ran) -> exp ts dom -> exp ts ran
| Abs : forall ts dom ran, exp (dom :: ts) ran -> exp ts (Arrow dom ran).
(* end thide *)

Implicit Arguments Const [ts].

(** We write a simple recursive function to translate [type]s into [Set]s. *)

Fixpoint typeDenote (t : type) : Set :=
  match t with
    | Unit => unit
    | Arrow t1 t2 => typeDenote t1 -> typeDenote t2
  end.

(** Now it is straightforward to write an expression interpreter.  The type of the function, [expDenote], tells us that we translate expressions into functions from properly typed environments to final values.  An environment for a free variable list [ts] is simply an [hlist typeDenote ts].  That is, for each free variable, the heterogeneous list that is the environment must have a value of the variable's associated type.  We use [hget] to implement the [Var] case, and we use [HCons] to extend the environment in the [Abs] case. *)

(* EX: Define an interpreter for [exp]s. *)

(* begin thide *)
Fixpoint expDenote ts t (e : exp ts t) : hlist typeDenote ts -> typeDenote t :=
  match e with
    | Const _ => fun _ => tt

    | Var _ _ mem => fun s => hget s mem
    | App _ _ _ e1 e2 => fun s => (expDenote e1 s) (expDenote e2 s)
    | Abs _ _ _ e' => fun s => fun x => expDenote e' (HCons x s)
  end.

(** Like for previous examples, our interpreter is easy to run with [simpl]. *)

Eval simpl in expDenote Const HNil.
(** %\vspace{-.15in}% [[
    = tt
     : typeDenote Unit
]]
*)

Eval simpl in expDenote (Abs (dom := Unit) (Var HFirst)) HNil.
(** %\vspace{-.15in}% [[
     = fun x : unit => x
     : typeDenote (Arrow Unit Unit)
]]
*)

Eval simpl in expDenote (Abs (dom := Unit)
  (Abs (dom := Unit) (Var (HNext HFirst)))) HNil.
(** %\vspace{-.15in}% [[
     = fun x _ : unit => x
     : typeDenote (Arrow Unit (Arrow Unit Unit))
]]
*)

Eval simpl in expDenote (Abs (dom := Unit) (Abs (dom := Unit) (Var HFirst))) HNil.
(** %\vspace{-.15in}% [[
     = fun _ x0 : unit => x0
     : typeDenote (Arrow Unit (Arrow Unit Unit))
]]
*)

Eval simpl in expDenote (App (Abs (Var HFirst)) Const) HNil.
(** %\vspace{-.15in}% [[
     = tt
     : typeDenote Unit
]]
*)

(* end thide *)

(** We are starting to develop the tools behind dependent typing's amazing advantage over alternative approaches in several important areas.  Here, we have implemented complete syntax, typing rules, and evaluation semantics for simply typed lambda calculus without even needing to define a syntactic substitution operation.  We did it all without a single line of proof, and our implementation is manifestly executable.  Other, more common approaches to language formalization often state and prove explicit theorems about type safety of languages.  In the above example, we got type safety, termination, and other meta-theorems for free, by reduction to CIC, which we know has those properties. *)

(** * Recursive Type Definitions *)

(** %\index{recursive type definition}%There is another style of datatype definition that leads to much simpler definitions of the [get] and [hget] definitions above.  Because Coq supports "type-level computation," we can redo our inductive definitions as _recursive_ definitions.  Here we will preface type names with the letter [f] to indicate that they are based on explicit recursive _function_ definitions. *)

(* EX: Come up with an alternate [ilist] definition that makes it easier to write [get]. *)

Section filist.
  Variable A : Set.

(* begin thide *)
  Fixpoint filist (n : nat) : Set :=
    match n with
      | O => unit
      | S n' => A * filist n'
    end%type.

  (** We say that a list of length 0 has no contents, and a list of length [S n'] is a pair of a data value and a list of length [n']. *)

  Fixpoint ffin (n : nat) : Set :=
    match n with
      | O => Empty_set
      | S n' => option (ffin n')
    end.

  (** We express that there are no index values when [n = O], by defining such indices as type [Empty_set]; and we express that, at [n = S n'], there is a choice between picking the first element of the list (represented as [None]) or choosing a later element (represented by [Some idx], where [idx] is an index into the list tail).  For instance, the three values of type [ffin 3] are [None], [Some None], and [Some (Some None)]. *)

  Fixpoint fget (n : nat) : filist n -> ffin n -> A :=
    match n with
      | O => fun _ idx => match idx with end
      | S n' => fun ls idx =>
        match idx with
          | None => fst ls
          | Some idx' => fget n' (snd ls) idx'
        end
    end.

  (** Our new [get] implementation needs only one dependent [match], and its annotation is inferred for us.  Our choices of data structure implementations lead to just the right typing behavior for this new definition to work out. *)
(* end thide *)

End filist.

(** Heterogeneous lists are a little trickier to define with recursion, but we then reap similar benefits in simplicity of use. *)

(* EX: Come up with an alternate [hlist] definition that makes it easier to write [hget]. *)

Section fhlist.
  Variable A : Type.
  Variable B : A -> Type.

(* begin thide *)
  Fixpoint fhlist (ls : list A) : Type :=
    match ls with
      | nil => unit
      | x :: ls' => B x * fhlist ls'
    end%type.

  (** The definition of [fhlist] follows the definition of [filist], with the added wrinkle of dependently typed data elements. *)

  Variable elm : A.

  Fixpoint fmember (ls : list A) : Type :=
    match ls with
      | nil => Empty_set
      | x :: ls' => (x = elm) + fmember ls'
    end%type.

  (** The definition of [fmember] follows the definition of [ffin].  Empty lists have no members, and member types for nonempty lists are built by adding one new option to the type of members of the list tail.  While for [ffin] we needed no new information associated with the option that we add, here we need to know that the head of the list equals the element we are searching for.  We express that idea with a sum type whose left branch is the appropriate equality proposition.  Since we define [fmember] to live in [Type], we can insert [Prop] types as needed, because [Prop] is a subtype of [Type].

     We know all of the tricks needed to write a first attempt at a [get] function for [fhlist]s.
     [[
  Fixpoint fhget (ls : list A) : fhlist ls -> fmember ls -> B elm :=
    match ls with
      | nil => fun _ idx => match idx with end
      | _ :: ls' => fun mls idx =>
        match idx with
          | inl _ => fst mls
          | inr idx' => fhget ls' (snd mls) idx'
        end
    end.
    ]]
    %\vspace{-.15in}%Only one problem remains.  The expression [fst mls] is not known to have the proper type.  To demonstrate that it does, we need to use the proof available in the [inl] case of the inner [match]. *)

  Fixpoint fhget (ls : list A) : fhlist ls -> fmember ls -> B elm :=
    match ls with
      | nil => fun _ idx => match idx with end
      | _ :: ls' => fun mls idx =>
        match idx with
          | inl pf => match pf with
                        | eq_refl => fst mls
                      end
          | inr idx' => fhget ls' (snd mls) idx'
        end
    end.

  (** By pattern-matching on the equality proof [pf], we make that equality known to the type-checker.  Exactly why this works can be seen by studying the definition of equality. *)

  (* begin hide *)
  (* begin thide *)
  Definition foo := @eq_refl.
  (* end thide *)
  (* end hide *)

  Print eq.
  (** %\vspace{-.15in}% [[
Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
]]

In a proposition [x = y], we see that [x] is a parameter and [y] is a regular argument.  The type of the constructor [eq_refl] shows that [y] can only ever be instantiated to [x].  Thus, within a pattern-match with [eq_refl], occurrences of [y] can be replaced with occurrences of [x] for typing purposes. *)
(* end thide *)

End fhlist.

Implicit Arguments fhget [A B elm ls].

(** How does one choose between the two data structure encoding strategies we have presented so far?  Before answering that question in this chapter's final section, we introduce one further approach. *)

(** * Data Structures as Index Functions *)

(** %\index{index function}%Indexed lists can be useful in defining other inductive types with constructors that take variable numbers of arguments.  In this section, we consider parameterized trees with arbitrary branching factor. *)

Section tree.
  Variable A : Set.

  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, ilist tree n -> tree.
End tree.

(** Every [Node] of a [tree] has a natural number argument, which gives the number of child trees in the second argument, typed with [ilist].  We can define two operations on trees of naturals: summing their elements and incrementing their elements.  It is useful to define a generic fold function on [ilist]s first. *)

Section ifoldr.
  Variables A B : Set.
  Variable f : A -> B -> B.
  Variable i : B.

  Fixpoint ifoldr n (ls : ilist A n) : B :=
    match ls with
      | Nil => i
      | Cons _ x ls' => f x (ifoldr ls')
    end.
End ifoldr.

Fixpoint sum (t : tree nat) : nat :=
  match t with
    | Leaf n => n
    | Node _ ls => ifoldr (fun t' n => sum t' + n) O ls
  end.

Fixpoint inc (t : tree nat) : tree nat :=
  match t with
    | Leaf n => Leaf (S n)
    | Node _ ls => Node (imap inc ls)
  end.

(** Now we might like to prove that [inc] does not decrease a tree's [sum]. *)

Theorem sum_inc : forall t, sum (inc t) >= sum t.
(* begin thide *)
  induction t; crush.
  (** [[
  n : nat
  i : ilist (tree nat) n
  ============================
   ifoldr (fun (t' : tree nat) (n0 : nat) => sum t' + n0) 0 (imap inc i) >=
   ifoldr (fun (t' : tree nat) (n0 : nat) => sum t' + n0) 0 i

   ]]

   We are left with a single subgoal which does not seem provable directly.  This is the same problem that we met in Chapter 3 with other %\index{nested inductive type}%nested inductive types. *)

  Check tree_ind.
  (** %\vspace{-.15in}% [[
  tree_ind
     : forall (A : Set) (P : tree A -> Prop),
       (forall a : A, P (Leaf a)) ->
       (forall (n : nat) (i : ilist (tree A) n), P (Node i)) ->
       forall t : tree A, P t
]]

The automatically generated induction principle is too weak.  For the [Node] case, it gives us no inductive hypothesis.  We could write our own induction principle, as we did in Chapter 3, but there is an easier way, if we are willing to alter the definition of [tree]. *)

Abort.

Reset tree.

(** First, let us try using our recursive definition of [ilist]s instead of the inductive version. *)

Section tree.
  Variable A : Set.

  (** %\vspace{-.15in}% [[
  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, filist tree n -> tree.
]]

<<
Error: Non strictly positive occurrence of "tree" in
 "forall n : nat, filist tree n -> tree"
>>

  The special-case rule for nested datatypes only works with nested uses of other inductive types, which could be replaced with uses of new mutually inductive types.  We defined [filist] recursively, so it may not be used in nested inductive definitions.

  Our final solution uses yet another of the inductive definition techniques introduced in Chapter 3, %\index{reflexive inductive type}%reflexive types.  Instead of merely using [fin] to get elements out of [ilist], we can _define_ [ilist] in terms of [fin].  For the reasons outlined above, it turns out to be easier to work with [ffin] in place of [fin]. *)

  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, (ffin n -> tree) -> tree.

  (** A [Node] is indexed by a natural number [n], and the node's [n] children are represented as a function from [ffin n] to trees, which is isomorphic to the [ilist]-based representation that we used above. *)

End tree.

Implicit Arguments Node [A n].

(** We can redefine [sum] and [inc] for our new [tree] type.  Again, it is useful to define a generic fold function first.  This time, it takes in a function whose domain is some [ffin] type, and it folds another function over the results of calling the first function at every possible [ffin] value. *)

Section rifoldr.
  Variables A B : Set.
  Variable f : A -> B -> B.
  Variable i : B.

  Fixpoint rifoldr (n : nat) : (ffin n -> A) -> B :=
    match n with
      | O => fun _ => i
      | S n' => fun get => f (get None) (rifoldr n' (fun idx => get (Some idx)))
    end.
End rifoldr.

Implicit Arguments rifoldr [A B n].

Fixpoint sum (t : tree nat) : nat :=
  match t with
    | Leaf n => n
    | Node _ f => rifoldr plus O (fun idx => sum (f idx))
  end.

Fixpoint inc (t : tree nat) : tree nat :=
  match t with
    | Leaf n => Leaf (S n)
    | Node _ f => Node (fun idx => inc (f idx))
  end.

(** Now we are ready to prove the theorem where we got stuck before.  We will not need to define any new induction principle, but it _will_ be helpful to prove some lemmas. *)

Lemma plus_ge : forall x1 y1 x2 y2,
  x1 >= x2
  -> y1 >= y2
  -> x1 + y1 >= x2 + y2.
  crush.
Qed.

Lemma sum_inc' : forall n (f1 f2 : ffin n -> nat),
  (forall idx, f1 idx >= f2 idx)
  -> rifoldr plus O f1 >= rifoldr plus O f2.
  Hint Resolve plus_ge.

  induction n; crush.
Qed.

Theorem sum_inc : forall t, sum (inc t) >= sum t.
  Hint Resolve sum_inc'.

  induction t; crush.
Qed.

(* end thide *)

(** Even if Coq would generate complete induction principles automatically for nested inductive definitions like the one we started with, there would still be advantages to using this style of reflexive encoding.  We see one of those advantages in the definition of [inc], where we did not need to use any kind of auxiliary function.  In general, reflexive encodings often admit direct implementations of operations that would require recursion if performed with more traditional inductive data structures. *)

(** ** Another Interpreter Example *)

(** We develop another example of variable-arity constructors, in the form of optimization of a small expression language with a construct like Scheme's <<cond>>.  Each of our conditional expressions takes a list of pairs of boolean tests and bodies.  The value of the conditional comes from the body of the first test in the list to evaluate to [true].  To simplify the %\index{interpreters}%interpreter we will write, we force each conditional to include a final, default case. *)

Inductive type' : Type := Nat | Bool.

Inductive exp' : type' -> Type :=
| NConst : nat -> exp' Nat
| Plus : exp' Nat -> exp' Nat -> exp' Nat
| Eq : exp' Nat -> exp' Nat -> exp' Bool

| BConst : bool -> exp' Bool
(* begin thide *)
| Cond : forall n t, (ffin n -> exp' Bool)
  -> (ffin n -> exp' t) -> exp' t -> exp' t.
(* end thide *)

(** A [Cond] is parameterized by a natural [n], which tells us how many cases this conditional has.  The test expressions are represented with a function of type [ffin n -> exp' Bool], and the bodies are represented with a function of type [ffin n -> exp' t], where [t] is the overall type.  The final [exp' t] argument is the default case.  For example, here is an expression that successively checks whether [2 + 2 = 5] (returning 0 if so) or if [1 + 1 = 2] (returning 1 if so), returning 2 otherwise. *)

Example ex1 := Cond 2
  (fun f => match f with
              | None => Eq (Plus (NConst 2) (NConst 2)) (NConst 5)
              | Some None => Eq (Plus (NConst 1) (NConst 1)) (NConst 2)
              | Some (Some v) => match v with end
            end)
  (fun f => match f with
              | None => NConst 0
              | Some None => NConst 1
              | Some (Some v) => match v with end
            end)
  (NConst 2).

(** We start implementing our interpreter with a standard type denotation function. *)

Definition type'Denote (t : type') : Set :=
  match t with
    | Nat => nat
    | Bool => bool
  end.

(** To implement the expression interpreter, it is useful to have the following function that implements the functionality of [Cond] without involving any syntax. *)

(* begin thide *)
Section cond.
  Variable A : Set.
  Variable default : A.

  Fixpoint cond (n : nat) : (ffin n -> bool) -> (ffin n -> A) -> A :=
    match n with
      | O => fun _ _ => default
      | S n' => fun tests bodies =>
        if tests None
          then bodies None
          else cond n'
            (fun idx => tests (Some idx))
            (fun idx => bodies (Some idx))
    end.
End cond.

Implicit Arguments cond [A n].
(* end thide *)

(** Now the expression interpreter is straightforward to write. *)

(* begin thide *)
Fixpoint exp'Denote t (e : exp' t) : type'Denote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => exp'Denote e1 + exp'Denote e2
    | Eq e1 e2 =>
      if eq_nat_dec (exp'Denote e1) (exp'Denote e2) then true else false

    | BConst b => b
    | Cond _ _ tests bodies default =>
      cond
      (exp'Denote default)
      (fun idx => exp'Denote (tests idx))
      (fun idx => exp'Denote (bodies idx))
  end.
(* begin hide *)
Reset exp'Denote.
(* end hide *)
(* end thide *)

(* begin hide *)
Fixpoint exp'Denote t (e : exp' t) : type'Denote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => exp'Denote e1 + exp'Denote e2
    | Eq e1 e2 =>
      if eq_nat_dec (exp'Denote e1) (exp'Denote e2) then true else false

    | BConst b => b
    | Cond _ _ tests bodies default =>
(* begin thide *)
      cond
      (exp'Denote default)
      (fun idx => exp'Denote (tests idx))
      (fun idx => exp'Denote (bodies idx))
(* end thide *)
  end.
(* end hide *)

(** We will implement a constant-folding function that optimizes conditionals, removing cases with known-[false] tests and cases that come after known-[true] tests.  A function [cfoldCond] implements the heart of this logic.  The convoy pattern is used again near the end of the implementation. *)

(* begin thide *)
Section cfoldCond.
  Variable t : type'.
  Variable default : exp' t.

  Fixpoint cfoldCond (n : nat)
    : (ffin n -> exp' Bool) -> (ffin n -> exp' t) -> exp' t :=
    match n with
      | O => fun _ _ => default
      | S n' => fun tests bodies =>
        match tests None return _ with
          | BConst true => bodies None
          | BConst false => cfoldCond n'
            (fun idx => tests (Some idx))
            (fun idx => bodies (Some idx))
          | _ =>
            let e := cfoldCond n'
              (fun idx => tests (Some idx))
              (fun idx => bodies (Some idx)) in
            match e in exp' t return exp' t -> exp' t with
              | Cond n _ tests' bodies' default' => fun body =>
                Cond
                (S n)
                (fun idx => match idx with
                              | None => tests None
                              | Some idx => tests' idx
                            end)
                (fun idx => match idx with
                              | None => body
                              | Some idx => bodies' idx
                            end)
                default'
              | e => fun body =>
                Cond
                1
                (fun _ => tests None)
                (fun _ => body)
                e
            end (bodies None)
        end
    end.
End cfoldCond.

Implicit Arguments cfoldCond [t n].
(* end thide *)

(** Like for the interpreters, most of the action was in this helper function, and [cfold] itself is easy to write. *)

(* begin thide *)
Fixpoint cfold t (e : exp' t) : exp' t :=
  match e with
    | NConst n => NConst n
    | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp' Nat with
        | NConst n1, NConst n2 => NConst (n1 + n2)
        | _, _ => Plus e1' e2'
      end
    | Eq e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp' Bool with
        | NConst n1, NConst n2 => BConst (if eq_nat_dec n1 n2 then true else false)
        | _, _ => Eq e1' e2'
      end

    | BConst b => BConst b
    | Cond _ _ tests bodies default =>
      cfoldCond
      (cfold default)
      (fun idx => cfold (tests idx))
      (fun idx => cfold (bodies idx))
  end.
(* end thide *)

(* begin thide *)
(** To prove our final correctness theorem, it is useful to know that [cfoldCond] preserves expression meanings.  The following lemma formalizes that property.  The proof is a standard mostly automated one, with the only wrinkle being a guided instantiation of the quantifiers in the induction hypothesis. *)

Lemma cfoldCond_correct : forall t (default : exp' t)
  n (tests : ffin n -> exp' Bool) (bodies : ffin n -> exp' t),
  exp'Denote (cfoldCond default tests bodies)
  = exp'Denote (Cond n tests bodies default).
  induction n; crush;
    match goal with
      | [ IHn : forall tests bodies, _, tests : _ -> _, bodies : _ -> _ |- _ ] =>
        specialize (IHn (fun idx => tests (Some idx)) (fun idx => bodies (Some idx)))
    end;
    repeat (match goal with
              | [ |- context[match ?E with NConst _ => _ | _ => _ end] ] =>
                dep_destruct E
              | [ |- context[if ?B then _ else _] ] => destruct B
            end; crush).
Qed.

(** It is also useful to know that the result of a call to [cond] is not changed by substituting new tests and bodies functions, so long as the new functions have the same input-output behavior as the old.  It turns out that, in Coq, it is not possible to prove in general that functions related in this way are equal.  We treat this issue with our discussion of axioms in a later chapter.  For now, it suffices to prove that the particular function [cond] is _extensional_; that is, it is unaffected by substitution of functions with input-output equivalents. *)

Lemma cond_ext : forall (A : Set) (default : A) n (tests tests' : ffin n -> bool)
  (bodies bodies' : ffin n -> A),
  (forall idx, tests idx = tests' idx)
  -> (forall idx, bodies idx = bodies' idx)
  -> cond default tests bodies
  = cond default tests' bodies'.
  induction n; crush;
    match goal with
      | [ |- context[if ?E then _ else _] ] => destruct E
    end; crush.
Qed.

(** Now the final theorem is easy to prove. *)
(* end thide *)

Theorem cfold_correct : forall t (e : exp' t),
  exp'Denote (cfold e) = exp'Denote e.
(* begin thide *)
  Hint Rewrite cfoldCond_correct.
  Hint Resolve cond_ext.

  induction e; crush;
    repeat (match goal with
              | [ |- context[cfold ?E] ] => dep_destruct (cfold E)
            end; crush).
Qed.
(* end thide *)

(** We add our two lemmas as hints and perform standard automation with pattern-matching of subterms to destruct. *)

(** * Choosing Between Representations *)

(** It is not always clear which of these representation techniques to apply in a particular situation, but I will try to summarize the pros and cons of each.

   Inductive types are often the most pleasant to work with, after someone has spent the time implementing some basic library functions for them, using fancy [match] annotations.  Many aspects of Coq's logic and tactic support are specialized to deal with inductive types, and you may miss out if you use alternate encodings.

   Recursive types usually involve much less initial effort, but they can be less convenient to use with proof automation.  For instance, the [simpl] tactic (which is among the ingredients in [crush]) will sometimes be overzealous in simplifying uses of functions over recursive types.  Consider a call [get l f], where variable [l] has type [filist A (S n)].  The type of [l] would be simplified to an explicit pair type.  In a proof involving many recursive types, this kind of unhelpful "simplification" can lead to rapid bloat in the sizes of subgoals.  Even worse, it can prevent syntactic pattern-matching, like in cases where [filist] is expected but a pair type is found in the "simplified" version.  The same problem applies to applications of recursive functions to values in recursive types: the recursive function call may "simplify" when the top-level structure of the type index but not the recursive value is known, because such functions are generally defined by recursion on the index, not the value.

   Another disadvantage of recursive types is that they only apply to type families whose indices determine their "skeletons."  This is not true for all data structures; a good counterexample comes from the richly typed programming language syntax types we have used several times so far.  The fact that a piece of syntax has type [Nat] tells us nothing about the tree structure of that syntax.

   Finally, Coq type inference can be more helpful in constructing values in inductive types.  Application of a particular constructor of that type tells Coq what to expect from the arguments, while, for instance, forming a generic pair does not make clear an intention to interpret the value as belonging to a particular recursive type.  This downside can be mitigated to an extent by writing "constructor" functions for a recursive type, mirroring the definition of the corresponding inductive type.

   Reflexive encodings of data types are seen relatively rarely.  As our examples demonstrated, manipulating index values manually can lead to hard-to-read code.  A normal inductive type is generally easier to work with, once someone has gone through the trouble of implementing an induction principle manually with the techniques we studied in Chapter 3.  For small developments, avoiding that kind of coding can justify the use of reflexive data structures.  There are also some useful instances of %\index{co-inductive types}%co-inductive definitions with nested data structures (e.g., lists of values in the co-inductive type) that can only be deconstructed effectively with reflexive encoding of the nested structures. *)


(* infotheo: information theory and error-correcting codes in Coq               *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later              *)
From mathcomp Require Import all_ssreflect.
Require Import Reals Lra.
Require Import ssrR Reals_ext Ranalysis_ext logb.

(******************************************************************************)
(*                    The natural entropy function                            *)
(*                                                                            *)
(* Definitions:                                                               *)
(*   H2ln p == the binary entropy function except that we replace the         *)
(*             logarithm in base 2 by its natural version                     *)
(*   H2 p == the binary entropy function                                      *)
(*                                                                            *)
(* Lemmas:                                                                    *)
(*   H2ln_max == H2ln is upper bounded by ln 2                                *)
(*   H2_max   == the binary entropy function is bounded by 1                  *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.

Definition H2ln := fun p => - p * ln p - (1 - p) * ln (1 - p).

Lemma derivable_pt_ln_Rminus x : x < 1 -> derivable_pt ln (1 - x).
Proof.
move=> Hx.
exists (/ (1 - x)).
apply derivable_pt_lim_ln, subR_gt0.
assumption.
Defined.

Lemma pderivable_H2ln : pderivable H2ln (fun x => 0 < x <= 1/2).
Proof.
move=> x /= [Hx0 Hx1].
apply derivable_pt_minus.
apply derivable_pt_mult.
apply derivable_pt_Ropp.
apply derivable_pt_ln.
assumption.
apply derivable_pt_mult.
apply derivable_pt_Rminus.
apply derivable_pt_comp.
apply derivable_pt_Rminus.
apply derivable_pt_ln_Rminus.
lra.
Defined.

(* NB: on peut pas utiliser derivable_pt_Ropp2? *)
Lemma pderivable_Ropp_H2ln : pderivable (fun x => - H2ln x) (fun x => 1/2 <= x < 1).
Proof.
rewrite /H2ln /pderivable => x [Hx0 Hx1].
apply derivable_pt_comp.
apply derivable_pt_minus.
apply derivable_pt_mult.
apply derivable_pt_Ropp.
apply derivable_pt_ln.
lra.
apply derivable_pt_mult.
apply derivable_pt_Rminus.
apply derivable_pt_comp.
apply derivable_pt_Rminus.
apply derivable_pt_ln_Rminus.
assumption.
apply derivable_pt_Ropp.
Defined.

Lemma increasing_on_0_to_half : forall x y,
  0 < x <= 1/2 -> 0 < y <= 1/2 -> x <= y -> H2ln x <= H2ln y.
Proof.
apply pderive_increasing_open_closed with (pr := pderivable_H2ln); first lra.
move=> t [Ht1 Ht2].
rewrite /H2ln /pderivable_H2ln derive_pt_minus 2!derive_pt_mult /=.
destruct (Rlt_le_dec 0 t) => /=; last by exfalso; lra.
rewrite derive_pt_comp /= mulRA.
apply (@leR_trans (- ln t + ln (1 - t))); last first.
  apply Req_le; field.
  by split=> ?; lra.
rewrite -ln_Rinv // -ln_mult; last 2 first.
  exact/invR_gt0.
  lra.
rewrite -ln_1.
apply ln_increasing_le; first lra.
apply (@leR_pmul2l t) => //.
by rewrite mulRA mulRV ?gtR_eqF // mulR1 mul1R; lra.
Qed.

Lemma decreasing_on_half_to_1 (x y : R) :
  1/2 <= x < 1 -> 1/2 <= y < 1 -> x <= y -> H2ln y <= H2ln x.
Proof.
move=> Hx Hy xy.
rewrite -[X in _ <= X]oppRK leR_oppr.
move: x y Hx Hy xy.
apply pderive_increasing_closed_open with (pr := pderivable_Ropp_H2ln); first lra.
move=> t [Ht1 Ht2].
rewrite /H2ln /pderivable_Ropp_H2ln derive_pt_comp derive_pt_minus 2!derive_pt_mult /=.
destruct (Rlt_le_dec 0 t) => /=; last first.
  by exfalso; lra.
rewrite derive_pt_comp /= mulRA.
apply (@leR_trans (ln t - ln (1 - t))); last first.
  apply Req_le; field.
  by split => ?; lra.
suff : ln ( 1 - t) <= ln t by move=> ?; lra.
by apply ln_increasing_le; lra.
Qed.

Lemma H2ln_max (q : R) : 0 < q < 1 -> - q * ln q - (1 - q) * ln (1 - q) <= ln 2.
Proof.
move=> [Hq0 Hq1].
apply (@leR_trans (H2ln (1/2))); last first.
  apply Req_le.
  rewrite /H2ln (_ : 1 - 1/2 = 1/2); last by field.
  rewrite -mulRBl (_ : - _ - _ = - 1); last by field.
  rewrite div1R ln_Rinv; [by field | lra].
rewrite -/(H2ln q).
case: (Rlt_le_dec q (1/2)) => [H1|].
- by apply increasing_on_0_to_half => //; lra.
- case/Rle_lt_or_eq_dec => [H1|<-]; last exact: leRR.
  by apply decreasing_on_half_to_1 => //; lra.
Qed.

Definition H2 p := - (p * log p) + - ((1 - p) * log (1 - p)).

Lemma bin_ent_0eq0 : H2 0 = 0.
Proof.
rewrite /H2 /log.
by rewrite !(Log_1, mulR0, mul0R, oppR0, mul1R, mulR1, add0R, addR0, subR0).
Qed.

Lemma bin_ent_1eq0 : H2 1 = 0.
Proof.
rewrite /H2 /log.
by rewrite !(Log_1, mulR0, mul0R, oppR0, mul1R, mulR1,
                       add0R, addR0, subR0, subRR).
Qed.

Lemma H2_max : forall p, 0 < p < 1 -> H2 p <= 1.
Proof.
move=> p [Hp0 Hp1].
rewrite /H2.
apply (@leR_pmul2l (ln 2)) => //.
rewrite mulR1 mulRDr /log -!mulNR !(mulRC (ln 2)) -!mulRA.
rewrite (mulVR _ ln2_neq0) !mulR1 (mulNR (1 - p)); exact/H2ln_max.
Qed.

Lemma H2_max' (x : R): 0 <= x <= 1 -> H2 x <= 1.
Proof.
move=> [x_0 x_1].
case: x_0 => [?|<-]; last by rewrite bin_ent_0eq0.
case: x_1 => [?|->]; last by rewrite bin_ent_1eq0.
exact: H2_max.
Qed.


Require Import Logic.Rel.R.
Require Import Logic.Rel.Include.
Require Import Logic.Rel.Properties.

Require Import Logic.Lam.Syntax.
Require Import Logic.Lam.Functor.

Definition congruent (v:Type) (r:Rel (T v)) : Prop :=
    (forall (s1 s2 t1 t2:T v), r s1 t1 -> r s2 t2 -> r (App s1 s2) (App t1 t2)) /\
    (forall (x:v) (s1 t1:T v), r s1 t1 -> r (Lam x s1) (Lam x t1)).

Arguments congruent {v} _.

Definition congruence (v:Type) (r:Rel (T v)) : Prop :=
   equivalence r /\ congruent r.

Arguments congruence {v} _.

Lemma fmap_congruence : forall (v w:Type) (f:v -> w) (r:Rel (T w)),
    congruence r -> congruence (fun (s t:T v) => r (fmap f s) (fmap f t)).
Proof.
    intros v w f r [H1 [HApp HLam]].
    unfold equivalence in H1. destruct H1 as [Refl [Symm Tran]].
    unfold reflexive in Refl.
    unfold symmetric in Symm.
    unfold transitive in Tran.
    split.
    - split.
        + unfold reflexive. intros x. apply Refl.
        + split.
            { unfold symmetric. intros x y. apply Symm. }
            { unfold transitive.  intros x y z. apply Tran. }
    - split.
        + intros s1 s2 t1 t2. apply HApp.
        + intros x s1 t1. apply HLam.
Qed.

(* Congruence relation generated by a given relation on T v.                    *)
Inductive Cong (v:Type) (r:Rel (T v)) : Rel (T v) :=
| CongBase  : forall (p q:T v), r p q -> Cong v r p q
| CongRefl  : forall (p:T v), Cong v r p p
| CongSym   : forall (p q:T v), Cong v r p q -> Cong v r q p
| CongTrans : forall (p q t:T v), Cong v r p q -> Cong v r q t -> Cong v r p t
| CongApp   : forall (p1 p2 q1 q2:T v),
    Cong v r p1 q1 ->
    Cong v r p2 q2 ->
    Cong v r (App p1 p2) (App q1 q2)
| CongLam   : forall (x:v) (p1 q1:T v),
    Cong v r p1 q1 ->
    Cong v r (Lam x p1 )(Lam x q1)
.

Arguments Cong      {v}.
Arguments CongBase  {v}.
Arguments CongRefl  {v}.
Arguments CongSym   {v}.
Arguments CongTrans {v}.
Arguments CongApp   {v}.
Arguments CongLam   {v}.

(* The congruence relation generated by a given relation is reflexive.          *)
Lemma Cong_reflexive : forall (v:Type) (r:Rel (T v)), reflexive (Cong r).
Proof.
    intros v r. unfold reflexive. intros x. apply CongRefl.
Qed.

(* The congruence relation generated by a given relation is symmetric.          *)
Lemma Cong_symmetric : forall (v:Type) (r:Rel (T v)), symmetric (Cong r).
Proof.
    intros v r. unfold symmetric. intros x y. apply CongSym.
Qed.

(* The congruence relation generated by a given relation is transitive.         *)
Lemma Cong_transitive : forall (v:Type) (r:Rel (T v)), transitive (Cong r).
Proof.
    intros v r. unfold transitive. intros x y. apply CongTrans.
Qed.

(* The congruence relation generated by a given relation is an equivalence.     *)
Lemma Cong_equivalence : forall (v:Type) (r:Rel (T v)), equivalence (Cong r).
Proof.
    intros v r. unfold equivalence. split.
    - apply Cong_reflexive.
    - split.
        + apply Cong_symmetric.
        + apply Cong_transitive.
Qed.

(* The congruence relation generated by a given relation is congruent.         *)
Lemma Cong_congruent : forall (v:Type) (r:Rel (T v)), congruent (Cong r).
Proof.
    intros v r. unfold congruent. split.
    - apply CongApp.
    - apply CongLam.
Qed.

(* The congruence relation generated by a given relation is a congruence.       *)
Lemma Cong_congruence : forall (v:Type) (r:Rel (T v)), congruence (Cong r).
Proof.
    intros v r. unfold congruence. split.
    - apply Cong_equivalence.
    - apply Cong_congruent.
Qed.

(* The congruence relation generated by a given relation contains it.           *)
Lemma Cong_super : forall (v:Type) (r:Rel (T v)), r <= Cong r.
Proof.
    intros v r. apply incl_charac. intros x y. apply CongBase.
Qed.

(* The congruence relation generated by a given relation is the smallest.       *)
Lemma Cong_smallest : forall (v:Type) (r s:Rel (T v)),
    congruence s -> r <= s -> Cong r <= s.
Proof.
    intros v r s [[H1 [H2 H3]] [H4 H5]] H6. apply incl_charac. intros x y H7.
    induction H7 as [p q H7|p|p q H7 IH|p q t H7 H8 H9 IH
                    |p1 p2 q1 q2 H7 IH1 H8 IH2|x p1 q1 H7 IH].
    - apply incl_charac_to with r; assumption.
    - apply H1.
    - apply H2. assumption.
    - apply H3 with q; assumption.
    - apply H4; assumption.
    - apply H5. assumption.
Qed.


Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Fixpoint app (l : lst) (m : lst) : lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l : lst) : lst :=
  match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
  end.

Lemma app_nil : forall x : lst, app x Nil = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma app_assoc : forall x y z : lst, app x (app y z) = app (app x y) z.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem rev_append: forall x y : lst,
  (eq (rev (app x y)) (app (rev y) (rev x))).
Proof.
  intros.
  induction x.
  - simpl. rewrite app_nil. reflexivity.
  - simpl. rewrite IHx. rewrite app_assoc. reflexivity.
Qed.


Require Import Recdef.

Inductive Z : Type :=
| Zero : Z
| MinusOne : Z
| Next : Z -> Z.

Function abs (k : Z) : Z :=
match k with
| Zero => Zero
| MinusOne => Next Zero
| Next k' => Next (abs k')
end.

Function succ (k : Z) : Z :=
match k with
| Zero => Next Zero
| MinusOne => Zero
| Next Zero => Next (Next Zero)
| Next MinusOne => MinusOne
| Next k' => Next (succ k')
end.

Function pred (k : Z) : Z :=
match k with
| Zero => MinusOne
| MinusOne => Next MinusOne
| Next Zero => Zero
| Next MinusOne => Next (Next MinusOne)
| Next k' => Next (pred k')
end.

Function neg' (k : Z) : Z :=
match k with
| Zero => MinusOne
| MinusOne => Zero
| Next k' => Next (neg' k')
end.

Definition neg (k : Z) : Z :=
  succ (neg' k).

Function isNegative (k : Z) : bool :=
match k with
| Zero     => false
| MinusOne => true
| Next k'  => isNegative k'
end.

Definition isZero (k : Z) : bool :=
match k with
| Zero => true
| _    => false
end.

Function add (k1 k2 : Z) : Z :=
match k1 with
| Zero => k2
| MinusOne => pred k2
| Next k1' => if isNegative k1' then pred (add k1' k2) else succ (add k1' k2)
end.

Function abs' (k : Z) : nat :=
match k with
| Zero     => 0
| MinusOne => 1
| Next k'  => S (abs' k')
end.

Function add' (k1 k2 : Z) : Z :=
  if isNegative k1 then iter _ (abs' k1) pred k2 else iter _ (abs' k1) succ k2.

Lemma abs_abs :
  forall k : Z, abs (abs k) = abs k.
Proof.
  intros k; functional induction (abs k)
  ; cbn; rewrite ?IHz; reflexivity.
Qed.

Lemma succ_pred :
  forall k : Z,
    succ (pred k) = k.
Proof.
  intros k; functional induction (pred k); cbn.
  1-4: reflexivity.
  rewrite IHz; clear IHz.
  functional induction (pred k'); cbn in *.
  1-2: contradiction.
  1-3: reflexivity.
Qed.

Lemma pred_succ :
  forall k : Z,
    pred (succ k) = k.
Proof.
  intros k; functional induction (succ k); cbn.
  1-4: reflexivity.
  rewrite IHz; clear IHz.
  functional induction (succ k'); cbn in *.
  1-2: contradiction.
  1-3: reflexivity.
Qed.

Lemma neg'_succ :
  forall k : Z, neg' (succ k) = pred (neg' k).
Proof.
  intros k; functional induction (succ k); cbn.
  1-4: reflexivity.
  rewrite IHz; clear IHz.
  functional induction (neg' k'); cbn.
  1-2: contradiction.
  reflexivity.
Qed.

Lemma pred_neg' :
  forall k : Z, pred (neg' k) = neg' (succ k).
Proof.
  intros k; rewrite neg'_succ; reflexivity.
Qed.

Lemma neg_succ :
  forall k : Z, neg (succ k) = pred (neg k).
Proof.
  intros k; unfold neg.
  rewrite neg'_succ, succ_pred, pred_succ.
  reflexivity.
Qed.

Lemma pred_neg :
  forall k : Z, pred (neg k) = neg (succ k).
Proof.
  intros k; rewrite neg_succ; reflexivity.
Qed.

Lemma neg'_pred :
  forall k : Z, neg' (pred k) = succ (neg' k).
Proof.
  intros k; functional induction (pred k); cbn.
  1-4: reflexivity.
  rewrite IHz; clear IHz.
  functional induction (neg' k'); cbn.
  1-2: contradiction.
  reflexivity.
Qed.

Lemma succ_neg' :
  forall k : Z, succ (neg' k) = neg' (pred k).
Proof.
  intros k; rewrite neg'_pred; reflexivity.
Qed.

Lemma neg_pred :
  forall k : Z, neg (pred k) = succ (neg k).
Proof.
  intros k; unfold neg.
  rewrite neg'_pred.
  reflexivity.
Qed.

Lemma neg'_neg' :
  forall k : Z, neg' (neg' k) = k.
Proof.
  intros k; functional induction (neg' k)
  ; cbn; rewrite ?IHz; reflexivity.
Qed.

Lemma neg_neg :
  forall k : Z, neg (neg k) = k.
Proof.
  intros k; unfold neg.
  rewrite neg'_succ, succ_pred, neg'_neg'.
  reflexivity.
Qed.

Lemma abs_neg :
  forall k : Z,
    abs (neg k) = abs k.
Proof.
  unfold neg; intros k.
  functional induction (neg' k); cbn.
  1-2: reflexivity.
  destruct (neg' k'); cbn in *; rewrite IHz; reflexivity.
Qed.

Lemma isNegative_abs :
  forall k : Z,
    isNegative (abs k) = false.
Proof.
  intros k; functional induction (abs k)
  ; cbn; rewrite ?IHz; reflexivity.
Qed.

Lemma isNegative_neg' :
  forall k : Z,
    isNegative (neg' k) = negb (isNegative k).
Proof.
  intros k; functional induction (neg' k); cbn; auto.
Qed.

Lemma isNegative_pred :
  forall k : Z,
    isNegative (pred k) = orb (isNegative k) (isZero k).
Proof.
  intros k; functional induction (pred k); cbn.
  1-4: reflexivity.
  destruct k'; cbn in *; try contradiction.
  assumption.
Qed.

Lemma isNegative_succ :
  forall k : Z,
    isNegative (succ k) =
    match k with
    | MinusOne => false
    | _ => isNegative k
    end.
Proof.
  intros k; functional induction (pred k); cbn.
  1-4: reflexivity.
  destruct k'; cbn in *; try contradiction.
  assumption.
Qed.

Lemma abs_spec :
  forall k : Z,
    abs k = if isNegative k then neg k else k.
Proof.
  intros k; functional induction (isNegative k); cbn.
  1-2: reflexivity.
  rewrite IHb.
  destruct (isNegative k') eqn: Heq; [| reflexivity].
  unfold neg; destruct (neg' k') eqn: Hneg.
  all: try reflexivity.
  functional inversion Hneg; subst.
  inversion Heq.
Qed.

Lemma Next_spec :
  forall k : Z,
    Next k = if isNegative k then pred k else succ k.
Proof.
  intros k; functional induction (isNegative k); cbn.
  1-2: reflexivity.
  rewrite IHb.
  destruct (isNegative k') eqn: Hneg.
  - functional inversion Hneg; cbn in *; reflexivity.
  - functional inversion Hneg; cbn in *; reflexivity.
Qed.

Lemma add_Zero_r :
  forall k : Z,
    add k Zero = k.
Proof.
  induction k as [| | k']; cbn.
  1-2: reflexivity.
  rewrite IHk', Next_spec.
  reflexivity.
Qed.

Lemma add_MinusOne_r :
  forall k : Z,
    add k MinusOne = pred k.
Proof.
  intros k; functional induction (pred k); cbn.
  1-4: reflexivity.
  destruct k'; cbn in *; try contradiction.
  destruct (isNegative k') eqn: Hneg.
  - functional inversion Hneg; subst.
    + cbn. reflexivity.
    + admit.
Admitted.

Lemma add_Next_r :
  forall k1 k2 : Z,
    add k1 (Next k2) = if isNegative k2 then pred (add k1 k2) else succ (add k1 k2).
Proof.
  intros k1 k2.
  rewrite Next_spec.
  destruct (isNegative k2).
  -
Admitted.

Lemma add_comm :
  forall k1 k2 : Z,
    add k1 k2 = add k2 k1.
Proof.
  intros k1 k2; functional induction (add k1 k2); cbn.
  - rewrite add_Zero_r; reflexivity.
  - rewrite add_MinusOne_r; reflexivity.
  - rewrite add_Next_r, e0, IHz; reflexivity.
  - rewrite add_Next_r, e0, IHz; reflexivity.
Qed.

Lemma add_pred_l :
  forall k1 k2 : Z,
    add (pred k1) k2 = pred (add k1 k2).
Proof.
  intros k1 k2; functional induction (pred k1); cbn.
  1-2, 4: reflexivity.
  - rewrite pred_succ; reflexivity.
  - rewrite isNegative_pred, IHz, succ_pred.
    destruct k'; try contradiction; cbn [isZero]; rewrite Bool.orb_false_r.
    destruct (isNegative (Next k')).
    + reflexivity.
    + rewrite pred_succ. reflexivity.
Qed.

Lemma add_pred_r :
  forall k1 k2 : Z,
    add k1 (pred k2) = pred (add k1 k2).
Proof.
  intros k1 k2.
  rewrite add_comm, add_pred_l, add_comm.
  reflexivity.
Qed.

Lemma add_succ_l :
  forall k1 k2 : Z,
    add (succ k1) k2 = succ (add k1 k2).
Proof.
  intros k1 k2.
  assert (H : add (pred (succ k1)) k2 = pred (succ (add k1 k2)))
      by (rewrite !pred_succ; reflexivity).
  apply (f_equal succ) in H.
  rewrite add_pred_l, !succ_pred in H.
  assumption.
Qed.

Lemma add_succ_r :
  forall k1 k2 : Z,
    add k1 (succ k2) = succ (add k1 k2).
Proof.
  intros k1 k2.
  rewrite add_comm, add_succ_l, add_comm.
  reflexivity.
Qed.

Lemma add_assoc :
  forall k1 k2 k3 : Z,
    add (add k1 k2) k3 = add k1 (add k2 k3).
Proof.
  intros k1 k2 k3.
  functional induction (add k1 k2); cbn.
  - reflexivity.
  - rewrite add_pred_l; reflexivity.
  - rewrite add_pred_l, e0, IHz; reflexivity.
  - rewrite add_succ_l, e0, IHz; reflexivity.
Qed.

Lemma neg'_add :
  forall k1 k2 : Z,
    neg' (add k1 k2) = succ (add (neg' k1) (neg' k2)).
Proof.
  intros k1 k2.
  functional induction (add k1 k2); cbn.
  - rewrite succ_pred. reflexivity.
  - rewrite neg'_pred. reflexivity.
  - rewrite neg'_pred, IHz, isNegative_neg', e0; cbn. reflexivity.
  - rewrite neg'_succ, IHz, isNegative_neg', e0; cbn.
    rewrite pred_succ, succ_pred. reflexivity.
Qed.

Lemma neg_add :
  forall k1 k2 : Z,
    neg (add k1 k2) = add (neg k1) (neg k2).
Proof.
  intros k1 k2. unfold neg.
  rewrite add_succ_l, add_succ_r, neg'_add.
  reflexivity.
Qed.

Lemma add'_Zero_r :
  forall k : Z,
    add' k Zero = k.
Proof.
  unfold add'; intros k.
  functional induction (isNegative k); cbn.
  1-2: reflexivity.
  rewrite Next_spec.
  destruct (isNegative k'); rewrite IHb; reflexivity.
Qed.


(* * Tarski Semantics *)

Require Import Undecidability.FOL.Syntax.Facts.
Require Export Undecidability.FOL.Semantics.Tarski.FullCore.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Vector Lia.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Notation vec := Vector.t.

(* Tarski Semantics ***)

Section Tarski.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  (* Semantic notions *)

  Section Substs.

    Variable D : Type.
    Variable I : interp D.

    Lemma eval_ext rho xi t :
      (forall x, rho x = xi x) -> eval rho t = eval xi t.
    Proof.
      intros H. induction t; cbn.
      - now apply H.
      - f_equal. apply map_ext_in. now apply IH.
    Qed.

    Lemma eval_comp rho xi t :
      eval rho (subst_term xi t) = eval (xi >> eval rho) t.
    Proof.
      induction t; cbn.
      - reflexivity.
      - f_equal. rewrite map_map. apply map_ext_in, IH.
    Qed.
    Lemma eval_up ρ s t :
      eval (s .: ρ) t`[↑] = eval ρ t.
    Proof.
      rewrite eval_comp. apply eval_ext. reflexivity.
    Qed.

    Lemma sat_ext {ff : falsity_flag} rho xi phi :
      (forall x, rho x = xi x) -> rho ⊨ phi <-> xi ⊨ phi.
    Proof.
      induction phi  as [ | b P v | | ] in rho, xi |- *; cbn; intros H.
      - reflexivity.
      - erewrite map_ext; try reflexivity. intros t. now apply eval_ext.
      - specialize (IHphi1 rho xi). specialize (IHphi2 rho xi). destruct b0; intuition.
      - destruct q.
        + split; intros H' d; eapply IHphi; try apply (H' d). 1,2: intros []; cbn; intuition.
        + split; intros [d H']; exists d; eapply IHphi; try apply H'. 1,2: intros []; cbn; intuition.
    Qed.

    Lemma sat_ext' {ff : falsity_flag} rho xi phi :
      (forall x, rho x = xi x) -> rho ⊨ phi -> xi ⊨ phi.
    Proof.
      intros Hext H. rewrite sat_ext. exact H.
      intros x. now rewrite (Hext x).
    Qed.

    Lemma sat_comp {ff : falsity_flag} rho xi phi :
      rho ⊨ (subst_form xi phi) <-> (xi >> eval rho) ⊨ phi.
    Proof.
      induction phi as [ | b P v | | ] in rho, xi |- *; cbn.
      - reflexivity.
      - erewrite map_map, map_ext; try reflexivity. intros t. apply eval_comp.
      - specialize (IHphi1 rho xi). specialize (IHphi2 rho xi). destruct b0; intuition.
      - destruct q.
        + setoid_rewrite IHphi. split; intros H d; eapply sat_ext. 2, 4: apply (H d).
          all: intros []; cbn; trivial; now setoid_rewrite eval_comp.
        + setoid_rewrite IHphi. split; intros [d H]; exists d; eapply sat_ext. 2, 4: apply H.
          all: intros []; cbn; trivial; now setoid_rewrite eval_comp.
    Qed.

    Lemma sat_subst {ff : falsity_flag} rho sigma phi :
      (forall x, eval rho (sigma x) = rho x) -> rho ⊨ phi <-> rho ⊨ (subst_form sigma phi).
    Proof.
      intros H. rewrite sat_comp. apply sat_ext. intros x. now rewrite <- H.
    Qed.

    Lemma sat_single {ff : falsity_flag} (rho : nat -> D) (Phi : form) (t : term) :
      (eval rho t .: rho) ⊨ Phi <-> rho ⊨ subst_form (t..) Phi.
    Proof.
      rewrite sat_comp. apply sat_ext. now intros [].
    Qed.

    Lemma impl_sat {ff : falsity_flag} A rho phi :
      sat rho (A ==> phi) <-> ((forall psi, psi el A -> sat rho psi) -> sat rho phi).
    Proof.
      induction A; cbn; firstorder congruence.
    Qed.

    Lemma impl_sat' {ff : falsity_flag} A rho phi :
      sat rho (A ==> phi) -> ((forall psi, psi el A -> sat rho psi) -> sat rho phi).
    Proof.
      eapply impl_sat.
    Qed.

    Lemma bounded_eval_t n t sigma tau :
      (forall k, n > k -> sigma k = tau k) -> bounded_t n t -> eval sigma t = eval tau t.
    Proof.
      intros H. induction 1; cbn; auto.
      f_equal. now apply Vector.map_ext_in.
    Qed.

    Lemma bound_ext {ff : falsity_flag} N phi rho sigma :
      bounded N phi -> (forall n, n < N -> rho n = sigma n) -> (rho ⊨ phi <-> sigma ⊨ phi).
    Proof.
      induction 1 in sigma, rho |- *; cbn; intros HN; try tauto.
      - enough (map (eval rho) v = map (eval sigma) v) as E. now setoid_rewrite E.
        apply Vector.map_ext_in. intros t Ht.
        eapply bounded_eval_t; try apply HN. now apply H.
      - destruct binop; now rewrite (IHbounded1 rho sigma), (IHbounded2 rho sigma).
      - destruct quantop.
        + split; intros Hd d; eapply IHbounded.
          all : try apply (Hd d); intros [] Hk; cbn; auto.
          symmetry. all: apply HN; lia.
        + split; intros [d Hd]; exists d; eapply IHbounded.
          all : try apply Hd; intros [] Hk; cbn; auto.
          symmetry. all: apply HN; lia.
    Qed.

    Corollary sat_closed {ff : falsity_flag} rho sigma phi :
      bounded 0 phi -> rho ⊨ phi <-> sigma ⊨ phi.
    Proof.
      intros H. eapply bound_ext. apply H. lia.
    Qed.

    Lemma subst_exist_sat {ff : falsity_flag} rho phi N :
      rho ⊨ phi -> bounded N phi -> forall rho, rho ⊨ (exist_times N phi).
    Proof.
      induction N in phi, rho |-*; intros.
      - cbn. eapply sat_closed; eassumption.
      - cbn -[sat]. rewrite iter_switch. apply (IHN (S >> rho)).
        exists (rho 0). eapply sat_ext. 2: apply H.
        now intros [].
        now apply bounded_S_quant.
    Qed.

    Fact subst_exist_sat2 {ff : falsity_flag} N :
      forall rho phi, rho ⊨ (exist_times N phi) -> (exists sigma, sigma ⊨ phi).
    Proof.
      induction N.
      - eauto.
      - intros rho phi [? H]. now apply IHN in H.
    Qed.

    Lemma exists_close_form {ff : falsity_flag} N phi :
      bounded 0 (exist_times N phi) <-> bounded N phi.
    Proof.
      induction N in phi |- *.
      - reflexivity.
      - cbn. rewrite iter_switch.
        change (iter _ _ _) with (exist_times N (∃ phi)).
        setoid_rewrite IHN. symmetry.
        now apply bounded_S_quant.
    Qed.

  End Substs.

End Tarski.

(* Trivial Model *)

Section TM.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Instance TM : interp unit :=
    {| i_func := fun _ _ => tt; i_atom := fun _ _ => True; |}.

  Fact TM_sat (rho : nat -> unit) (phi : form falsity_off) :
    rho ⊨ phi.
  Proof.
    revert rho. remember falsity_off as ff. induction phi; cbn; trivial.
    - discriminate.
    - destruct b0; auto.
    - destruct q; firstorder. exact tt.
  Qed.

  Fact TM_sat_decidable {ff} (rho : nat -> unit) (phi : form ff) :
    rho ⊨ phi \/ ~(rho ⊨ phi).
  Proof.
    revert rho. induction phi as [|? ? ?|ff [| |] phi IHphi psi IHpsi|ff [|] phi IHphi]; cbn; intros rho; eauto; try tauto.
    - destruct (IHphi rho), (IHpsi rho); tauto.
    - destruct (IHphi rho), (IHpsi rho); tauto.
    - destruct (IHphi rho), (IHpsi rho); tauto.
    - destruct (IHphi (tt .: rho)).
      + left; now intros [].
      + right; intros Hcc. apply H, Hcc.
    - destruct (IHphi (tt .: rho)).
      + left; now exists tt.
      + right; now intros [[] Hx].
  Qed.

End TM.


(* Exercise 109 *)

Require Import BenB.

Variables A B C D : Prop.

(* de Morgans' disjunction law variant *)

Theorem exercise_109 : ~(~A \/ ~B) -> (A /\ B).
Proof.
imp_i a1.
con_i.
neg_e' (~A \/ ~B) a2.
hyp a1.
dis_i1.
hyp a2.
neg_e' (~A \/ ~B) a2.
hyp a1.
dis_i2.
hyp a2.
Qed.


(* Reversing lists, abstractly. *)

Require Import List.
Import ListNotations.

Section rev_abstract.

  Variables
    (T: Type)
    (f: list T -> list T).

  Lemma app_tail_nil:
    forall (xs ys: list T), xs = xs ++ ys -> ys = [].
  Proof.

  Qed.

  Hypothesis app_rev: forall xs ys, f (xs ++ ys) = f ys ++ f xs.

  (* Hint: `assert` something which allows you to
     use a specialisation of app_rev, and then
     use app_tail_nil. *)
  Lemma nil_id: f [] = [].
  Proof.

  Qed.

  Hypothesis single_id: forall x, f [x] = [x].

  Lemma rev_spec_complete:
    forall xs, f xs = rev xs.
  Proof.

  Qed.

End rev_abstract.