(* Universidade de Brasília
    Instituto de Ciências Exatas
    Departamento de Ciência da Computação
    Lógica Computacional 1 - turma B - 2020/2
    Professor: Flávio L. C. de Moura
    Estagiário de docência: Gabriel Ferreira Silva *)

Require Import Arith List Recdef.
Require Import Coq.Program.Wf.

Inductive sorted :list nat -> Prop :=
  | nil_sorted : sorted nil
  | one_sorted: forall n:nat, sorted (n :: nil)
  | all_sorted : forall (x y: nat) (l:list nat), sorted (y :: l) -> x <= y -> sorted (x :: y :: l).

Definition le_all x l := forall y, In y l -> x <= y.
Infix "<=*" := le_all (at level 70, no associativity).

Lemma tail_sorted: forall l a, sorted (a :: l) -> sorted l.
Proof.
  intro l.
  case l.
  - intros a H.
    apply nil_sorted.
  - intros n l' a H.
    inversion H; subst.
    assumption.
Qed.

(** *** Questão 1: 😎**)
(** A primeira questão consiste em provar que se [a] é menor ou igual a todo elemento de [l], e [l] é uma lista ordenada então a lista (a :: l) também está ordenada: *)

Lemma le_all_sorted: forall l a, a <=* l -> sorted l -> sorted (a :: l).
Proof.
  intro l.
  case l.
  - intros a menor ordenado_nulo.
    apply one_sorted.
  - intros n l0 a menor ordenado.
    apply all_sorted.
    + assumption.
    + unfold le_all in menor.
      apply menor.
      apply in_eq. (** pesquisamos a estrutura do In**)
Qed.

(** O lema a seguir é bem parecido com o lema [tail_sorted] visto anteriormente, mas ao invés de remover o primeiro elemento de uma lista ordenada, este lema remove o segundo elemento de uma lista ordenada (com pelo menos dois elementos), e após esta remoção a lista resultante ainda está ordenada. Veja que a prova é por análise de casos. *)

Lemma remove_sorted: forall l a1 a2, sorted (a1 :: a2 :: l) -> sorted (a1 :: l).
(* begin hide *)
Proof.
  intro l; case l.
  - intros a1 a2 H.
    apply one_sorted.
  - intros n l' a1 a2 H.
    inversion H; subst.
    inversion H2; subst.
    apply all_sorted.
    + assumption.
    + apply Nat.le_trans with a2; assumption.
Qed.
(* end hide *)

(** *** Questão 2 😏*)
(** A segunda questão consiste em provar que, se a lista [(a :: l)] está ordenada então [a] é menor ou igual a todo elemento de [l]. A dica é fazer indução na estrutura da lista [l]. *)

Lemma sorted_le_all: forall l a, sorted(a :: l) -> a <=* l.
Proof.
  induction l.
  - intros a ordenada n ta_dentro.
    (*caso seja difícil explicar o destruct, usar contradiction.*)
    destruct ta_dentro.
  - intros num ordenada. (** refatorar esta prova **)
    unfold le_all.
    intros y H0.
    inversion ordenada.
    subst.
    inversion H0.
    subst.
    assumption.
    apply IHl in H2.
    unfold le_all in H2.
    specialize(H2 y H). (** aplica a hipótese e substitui o resultado **)
    apply Nat.le_trans with (m := a); assumption.

Qed.

(** ** Segunda parte: *)
(** Agora definiremos a noção de permutação e apresentaremos
alguns lemas relacionados. A noção de permutação que será utilizada
neste projeto é baseada no número de ocorrências de um elemento.
 A função recursiva [num_oc n l] retorna o número de ocorrências do
natural [n] na lista [l]. A palavra reservada [Fixpoint] é usada para
definir funções recursivas, enquanto que [Definition] é usada para funções
 não-recursivas como foi o caso do predicado [le_all] visto anteriormente. *)

Fixpoint num_oc n l  :=
  match l with
    | nil => 0
    | h :: tl =>
      if n =? h then S(num_oc n tl) else  num_oc n tl
  end.

(** Dizemos então que duas listas [l] e [l'] são permutações uma da outra
 se qualquer natural [n] possui o mesmo número de ocorrências em ambas as
listas. *)

Definition perm l l' := forall n:nat, num_oc n l = num_oc n l'.

(** A reflexividade é uma propriedade que pode ser obtida a partir
desta definição: uma lista é sempre permutação dela mesma. *)

Lemma perm_refl: forall l, perm l l.
(* begin hide *)
Proof.
intro l. unfold perm. intro. reflexivity.
Qed.
(* end hide *)

(** O lema a seguir é um resultado técnico,
mas que pode ser utilizado em provas futuras.
Ele diz que o número de ocorrências de um natural [n]
no append das listas [l1] e [l2] (notação [l1 ++ l2]) é igual
 à soma das ocorrências de [n] em [l1] com as ocorrências de [n] em [l2]: *)

Lemma num_oc_append: forall n l1 l2, num_oc n l1 + num_oc n l2 = num_oc n (l1 ++ l2).
Proof.
  intros. induction l1.
  - simpl num_oc. trivial.
  - simpl. destruct (n =? a).
    + rewrite <- IHl1. apply Peano.plus_Sn_m.
    + assumption.
Qed.

(** *** Terceira parte: *)
(** Nesta parte definiremos o algoritmo mergesort.
Iniciaremos pela função [merge] que faz a etapa de combinação
descrita anteriormente. A função [merge] recebe como argumento
um par de listas de naturais ordenadas e gera uma nova lista ordenada
 contendo exatamente os elementos das duas listas recebidas como argumento.
 Iniciamos então com a definição do predicado [sorted_pair_lst] que recebe
um par de listas e retorna a conjunção expressando o fato de que cada lista
que compõe o par está ordenada: *)

Definition sorted_pair_lst (p: list nat * list nat) :=
sorted (fst p) /\ sorted (snd p).

(** Agora necessitamos de uma métrica para definirmos a função [merge].
Esta métrica consiste no tamanho do par que contém duas listas e é
definido como sendo a soma do comprimento de cada uma das listas: *)

Definition len (p: list nat * list nat) :=
   length (fst p) + length (snd p).

(** Agora podemos definir a função recursiva [merge].
Dado um par [p] de listas de naturais, se alguma das listas
 que compõem este par é a lista vazia então a função simplesmente
 retorna o outro elemento do par. Quando ambas as listas que compõem o
 par são não-vazias então os primeiros elementos de cada lista são
comparados e o menor deles será o colocado na lista final, e o processo
 se repete recursivamente para o par sem este menor elemento. Para
 garantirmos que esta função está bem definida, precisamos que as
chamadas recursivas se aproximem do ponto de parada (chamadas sem recursão)
 que ocorre quando alguma das listas do par é a lista vazia. Esta garantia
é dada pelo medida (ou métrica) definida anteriormente: o comprimento do par
que [merge] recebe como argumento: *)
(* printing *)
(** printing <=? $\leq ?$ *)

Function merge (p: list nat * list nat) {measure len p} :=
match p with
  | (nil, l2) => l2
  | (l1, nil) => l1
  | ((hd1 :: tl1) as l1, (hd2 :: tl2) as l2) =>
if hd1 <=? hd2 then hd1 :: merge (tl1, l2)
      else hd2 :: merge (l1, tl2)
   end.

(** A palavra reservada [Function] é utilizada para definir funções
recursivas mais sofisticadas, ou seja, para funções recursivas cuja
boa definição não pode ser inferida automaticamente pelo Coq. Neste caso,
 precisamos provar que nossa medida realmente decresce nas chamadas recursivas. *)
(* begin hide *)
Proof.
  - intros. unfold len. unfold fst. unfold snd. simpl length.
    apply plus_lt_compat_r. auto.
  - intros. unfold len. unfold fst. unfold snd. simpl length.
    apply plus_lt_compat_l. auto.
Qed.
(* end hide *)

(** O lema [merge_in] a seguir será bastante útil em provas futuras.
Ele estabelece que se [y] é um elemento da lista [merge p] então [y]
está em alguma das listas que compõem o par [p]. *)

Lemma merge_in: forall y p, In y (merge p) -> In y (fst p) \/ In y (snd p).
(* begin hide *)
Proof.
intros. functional induction (merge p).
  - right. unfold snd. assumption.
    - left. unfold fst. assumption.
    - simpl in H. destruct H as [H1 | H2].
    + left. unfold fst. unfold In. left. assumption.
        + destruct IHl.
        * assumption.
          * left. unfold fst. unfold fst in H. simpl In. right. assumption.
          * right. simpl. simpl in H. assumption.
    - simpl in H. destruct H as [H1 | H2].
    + right. simpl snd. simpl In. left. assumption.
        + destruct IHl.
        * assumption.
          * left. unfold fst. unfold fst in H. assumption.
          * right. simpl. simpl in H. right. assumption.
Qed.
(* end hide *)

(** *** Questão 3 *)
(** Esta questão é a mais importante do projeto.🤣 Ela estabelece que se as
 listas que compõem o par [p] estão ordenadas então [merge p] também está
ordenada. Como [merge] é uma função recursiva mais sofisticada, as
propriedades envolvendo esta função também terão provas mais complexas.
Como você pode ver, esta prova é composta de quatro casos, dos quais dois
estão provados, e dois fazem parte do exercício. Cada caso deixado como
exercício é semelhante ao caso anterior, então use estas subprovas que estão
 feitas como ideias para completar a prova deste teorema. Os lemas anteriores
 também podem ser úteis! *)

Theorem merge_sorts: forall p, sorted_pair_lst p -> sorted (merge p).
(* begin hide *)
Proof.
  intro p. functional induction (merge p).
  - unfold sorted_pair_lst. intro. destruct H.
    unfold snd in H0. assumption.
  - unfold sorted_pair_lst. intro. destruct H.
    assumption.
  - intro. apply le_all_sorted.
    + unfold le_all. intro. intro. apply merge_in in H0.
      destruct H0 as [H1 | H2].
      * simpl fst in H1. unfold sorted_pair_lst in H. destruct H as [H2 H3].
        simpl fst in H2. apply sorted_le_all in H2. unfold le_all in H2.
        apply H2. assumption.
      * simpl snd in H2. apply Nat.le_trans with hd2.
        -- apply Nat.leb_le. assumption.
        -- unfold sorted_pair_lst in H. destruct H as [H3 H4]. simpl snd in H4.
           apply sorted_le_all in H4. simpl In in H2. destruct H2 as [H5 | H6].
           ** rewrite H5. trivial.
           ** unfold le_all in H4. apply H4. assumption.
    + apply IHl. unfold sorted_pair_lst. split.
      * simpl fst. unfold sorted_pair_lst in H. destruct H as [H1 H2].
        simpl fst in H1. apply tail_sorted in H1. assumption.
      * simpl snd. unfold sorted_pair_lst in H. destruct H as [H1 H2].
        simpl snd in H2. assumption.
  - intro.
    apply le_all_sorted.
    + unfold le_all.
      intro. intro.
      apply merge_in in H0.
      destruct H0 as [H1 | H2].
      apply leb_complete_conv in e0.
      * simpl fst in H1. unfold sorted_pair_lst in H. destruct H as [H2 H3].
        simpl fst in H2. apply sorted_le_all in H2. unfold le_all in H2.
        simpl snd in H3.
        Search(In _ (_ :: _)).
        apply in_inv in H1.
        destruct H1.
        -- subst.
           Search(_ < _ -> _ <= _).
           apply Nat.lt_le_incl.
           assumption.
        --  apply H2 in H.
            Search(le_trans).
            apply Nat.le_trans with (m := hd1).
            *** apply Nat.lt_le_incl.
                assumption.
            *** assumption.
     * apply leb_complete_conv in e0.
       simpl snd in H2. unfold sorted_pair_lst in H. destruct H as [H22 H33].
       simpl snd in H33. apply sorted_le_all in H33. unfold le_all in H33.
       apply H33 in H2.
       assumption.
   + destruct H.
     simpl snd in H0.
     apply tail_sorted in H0.
     apply IHl.
     simpl fst in H.
     unfold sorted_pair_lst.
     simpl fst.
     simpl snd.
     split.
     * assumption.
     * assumption.
Qed.

(** Agora vamos definir a função [mergesort] que recebe uma lista [l] como
argumento. Se esta lista for vazia ou unitária, o algoritmo não faz nada.
Caso contrário, a lista é dividida ao meio, cada sublista é ordenada
recursivamente, e no final as sublistas ordenadas são fundidas com a função
 [merge]. *)

Function mergesort (l: list nat) {measure length l}:=
  match l with
  | nil => nil
  | hd :: nil => l
  | hd :: tail =>
     let n := length(l) / 2 in
     let l1 := firstn n l in
     let l2 := skipn n l in
     let sorted_l1 := mergesort(l1) in
     let sorted_l2 := mergesort(l2) in
     merge (sorted_l1, sorted_l2)
  end.

(** Analogamente à definição da função [merge], precisamos
provar que [mergesort] está bem definida. *)
(* begin hide *)
Proof.
- intros. rewrite skipn_length. apply Nat.sub_lt.
  + apply Nat.lt_le_incl. apply Nat.div_lt.
    * simpl. apply Nat.lt_0_succ.
      * apply Nat.lt_1_2.
    + apply Nat.div_str_pos. simpl. split.
    * apply Nat.lt_0_2.
      * apply Peano.le_n_S. apply Peano.le_n_S. apply Peano.le_0_n.
  - intros. rewrite firstn_length. rewrite min_l.
  + apply Nat.div_lt.
    * simpl. apply Nat.lt_0_succ.
      * apply Nat.lt_1_2.
    + apply Nat.lt_le_incl. apply Nat.div_lt.
    * simpl. apply Nat.lt_0_succ.
      * apply Nat.lt_1_2.
Defined.
(* end hide *)

(** *** Questão 4 *)
(** Agora prove que a função [mergesort] realmente ordena a lista recebida
como argumento. *)

Theorem mergesort_sorts: forall l, sorted (mergesort l).
Proof.
  intros.
  functional induction (mergesort l).
  - apply nil_sorted.
  - apply one_sorted.
  - destruct IHl0.
    * apply merge_sorts.
      unfold sorted_pair_lst.
      simpl.
      split.
      ** apply nil_sorted.
      ** assumption.
    * apply merge_sorts.
      unfold sorted_pair_lst.
      simpl.
      split.
      ** apply one_sorted.
      ** assumption.
    * apply merge_sorts.
      unfold sorted_pair_lst.
      simpl.
      split.
      ** apply all_sorted; assumption.
      ** assumption.
Qed.

(** O lema a seguir é um lema técnico que pode ser usado nas questões
seguintes. Este lema estabelece que o número de ocorrências de um elemento
[n] no par de listas [p] é igual à soma das ocorrências de [n] em cada lista
do par. *)

Lemma merge_num_oc: forall n p, num_oc n (merge p) = num_oc n (fst p) + num_oc n (snd p).
(* begin hide *)
Proof.
intros. functional induction (merge p).
  - simpl fst. simpl snd. simpl num_oc. trivial.
  - simpl fst. simpl snd. simpl num_oc. trivial.
  - simpl fst. simpl snd. simpl num_oc at 1 2. destruct (n =? hd1).
    + rewrite IHl. apply Peano.plus_Sn_m.
    + rewrite IHl. simpl fst. simpl snd. trivial.
  - simpl fst. simpl snd. simpl num_oc at 1 3. (destruct (n =? hd2)).
      + rewrite IHl. simpl fst. simpl snd. apply Peano.plus_n_Sm.
      + rewrite IHl. simpl fst. simpl snd. trivial.
Qed.
(* end hide *)

(** *** Questão 5 *)
(** Prove que [mergesort] gera uma permutação da lista recebida como argumento. *)

(**
intro.
  functional induction (mergesort l).
  - apply perm_refl.
  - apply perm_refl.
  - intros n.
    unfold merge.
    destruct mergesort.
    destruct merge_terminate.
    rewrite merge_num_oc.
**)

Theorem mergesort_is_perm: forall l, perm l (mergesort l).
Proof.
  intro.
  functional induction (mergesort l).
  - apply perm_refl.
  - apply perm_refl.
  - unfold perm. intros n.
    rewrite merge_num_oc.
    unfold fst. unfold snd.
    replace (num_oc n (mergesort (firstn (length (hd :: tail) / 2) (hd :: tail)))) with (num_oc n (firstn (length (hd :: tail) / 2) (hd :: tail))) .
    replace (num_oc n (mergesort (skipn (length (hd :: tail) / 2) (hd :: tail)))) with (num_oc n (skipn (length (hd :: tail) / 2) (hd :: tail))) .
    + rewrite num_oc_append.
      Search firstn.
      rewrite firstn_skipn.
      reflexivity.
    + destruct mergesort.
      * unfold perm in IHl1.
        rewrite -> IHl1.
        reflexivity.
      * unfold perm in IHl1.
        rewrite -> IHl1.
        reflexivity.
    + unfold perm in IHl0.
      rewrite -> IHl0.
      reflexivity.
Qed.

(** *** Questão 6 *)
(** Por fim, prove que [mergesort] é correto. *)

Theorem mergesort_is_correct: forall l, perm l (mergesort l) /\ sorted (mergesort l).
Proof.
  intros.
  split.
  - apply mergesort_is_perm.
  - apply mergesort_sorts.
Qed.

(** ESSE TRABALHO VALE 10 HEIN? 😏😈🔥🔥🔥🔥🔥😎*)

(** ** Extração de código *)
(** Uma das vantagens de formalizar um algoritmo é que você pode extrair o código certificado do algoritmo. O algoritmo de extração garante que o código extraído satisfaz todas as propriedades provadas. Vamos extrair automaticamente o código do algoritmo mergesort? *)

Require Extraction.

(** As opções de linguagens fornecidas pelo Coq são: OCaml, Haskell, Scheme e JSON. *)

Extraction Language OCaml.

(** Extração apenas da função [mergesort]: *)

Extraction mergesort.

(** Extração do programa inteiro: *)

Recursive Extraction mergesort.

(** Extração para um arquivo: *)

Extraction "mergesort" mergesort.


Inductive Nat : Type :=
  | O : Nat
  | S : Nat -> Nat.

Inductive BinaryTree : Type :=
| Leaf (n : Nat)
| Node (l r : BinaryTree).

Fixpoint plus (n m : Nat) : Nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Notation "x + y" := (plus x y)
  (at level 50, left associativity).

Fixpoint sum1 (t : BinaryTree) : Nat :=
match t with
| Leaf n => n
| Node l r => sum1 l + sum1 r
end.

Fixpoint sum2 (t : BinaryTree) : Nat :=
match t with
| Leaf n => n
| Node l r => sum2 r + sum2 l
end.

Lemma rightid (x : Nat) : x + O = x.
Proof.
  induction x.
  - simpl. reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_r_S : forall (a b : Nat), a + S b = S (a + b).
Proof.
  intros.
  induction a.
  - simpl. reflexivity.
  - simpl. rewrite IHa. reflexivity.
Qed.

Lemma plus_comm (x y : Nat) : x + y = y + x.
Proof.
  induction x.
  - simpl. rewrite (rightid). reflexivity.
  - simpl. rewrite (plus_r_S). rewrite IHx. reflexivity.
Qed.

Lemma sum1_2_eq : forall t : BinaryTree, sum1 t = sum2 t.
Proof.
  intros.
  induction t.
  - simpl.  reflexivity.
  - simpl. rewrite <- (IHt2). rewrite (IHt1). rewrite (plus_comm). reflexivity.
Qed.

From Coq Require Import Init.Nat.
From Coq Require Import Arith.PeanoNat.

Check nat.

(* InnentĹl kezdve hasznĂĄljuk az STDLB NAT-jĂĄt *)
(* Aritmetikai nyelv formalizĂĄlĂĄsa, BNF: *)
(*a ::= n | a1 + a2 | a1 - a2*)
(*a ::= alit(n) | plus(a1,a2) | sub(a1,a2)*)
Inductive AExp : Type :=
 | ALit (n : nat)
 | APlus (n m : AExp)
 | ASub ( n m : AExp)
.

(* Checkek *)

(* Hogyan tudunk kiĂŠrtĂŠkelni aritmetikai kifejezĂŠseket --> denotĂĄciĂłs szemantika *)
Fixpoint aeval (a : AExp) : nat :=
  match a with
  | ALit n => n
  | APlus n m => (aeval n) + (aeval m)
  | ASub n m => (aeval n) - (aeval m)
  end.

Fixpoint leaves_count (a : AExp) : nat :=
  match a with
  | ALit _ => 1
  | APlus n m => (leaves_count n) + (leaves_count m)
  | ASub n m => (leaves_count n) + (leaves_count m)
  end.

Definition myA1 := (APlus (ALit 1) (ALit 2)).
Definition myA2 := (ASub (APlus (ALit 5) (ALit 7)) (ALit 42)).

Eval compute in leaves_count(myA1).
Eval compute in leaves_count(myA2).

Lemma leaf_l_r: forall (a1 a2 : AExp), leaves_count (APlus a1 a2) = leaves_count (APlus a2 a1).
Proof.
 intros.
 simpl.
 Search Nat.
 rewrite (Nat.add_comm).
 reflexivity.
Qed.

Lemma leaf_l_r_ind: forall (a1 a2 : AExp), leaves_count (APlus a1 a2) = leaves_count (APlus a2 a1).
Proof.
  intros.
  induction a1.
  - simpl. Search "+" S. rewrite (Nat.add_1_r). reflexivity.
  - simpl. rewrite (Nat.add_comm). reflexivity.
  - simpl. rewrite (Nat.add_comm). reflexivity.
Qed.


Module NatPlayground.
Inductive nat : Set :=
  | O : nat
  | S : nat -> nat.

Print nat.
Eval compute in O.
Eval compute in (S O).
Eval compute in S(S O).

Fixpoint add (a b : nat) : nat :=
  match a with
  | O => b
  | S n => S (add n b)
  end.

Theorem add_assoc : forall (a b c : nat),
  (add a( add b c)) = (add (add a b) c).
Proof.
intros a b c.
induction a. simpl. reflexivity.
simpl. rewrite -> IHa. reflexivity.
Qed.

Print add_assoc.

Definition pred (n : nat) : nat :=
  match n with
    | O => O
    | S n' => n'
  end.

Definition succ (n : nat) : nat :=
  match n with
  | O => (S O)
  | s => (S s)
end.

Check (S (S (S (S O)))).

Fixpoint plus (n : nat) (m : nat) :=
  match n with
  | O => m
  | S n' => plus n' (succ m)
end.
Compute plus (S (S (S O))) (S (S O)).

(*  plus (S (S (S O))) (S (S O))
==> S (plus (S (S O)) (S (S O)))
      by the second clause of the match
==> S (S (plus (S O) (S (S O))))
      by the second clause of the match
==> S (S (S (plus O (S (S O)))))
      by the second clause of the match
==> S (S (S (S (S O))))
      by the first clause of the match
*)

End NatPlayground.

Compute (NatPlayground.succ NatPlayground.O).
Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.
Compute (minustwo 4).

Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
end.

Definition oddb (n : nat) : bool := negb (evenb n).

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Compute (oddb 4).
Example test_oddb2: (oddb 4) = false.
Proof. simpl. reflexivity. Qed.

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

Compute (plus 3 2).

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => plus m (mult n' m)
  end.
Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minux (n m : nat) : nat :=
  match n, m with
  | O, _ => O
  | S _, O => n
  | S n', S m' => minus n' m'
end.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
end.

(* Exercise: 1 star (factorial) *)
Fixpoint factorial (n:nat) : nat :=
  match n with
  | O   => S O
  | S p => mult n (factorial p)
end.
Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.
Check ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.
Example test_leb1: (leb 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: (leb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: (leb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Definition blt_nat (n m : nat) : bool :=
  match (beq_nat n m) with
  | true => false
  | false => leb n m
end.

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. simpl. reflexivity. Qed.
Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. simpl. reflexivity. Qed.

(* Proof by Rewriting *)
Theorem plus_id_example : forall n m:nat,
  n = m -> n + n = m + m.

Proof.
  (* move both quantifiers into the context: *)
  intros n m.
  (* move the hypothesis into the context: *)
  intros H.
  (* rewrite the goal using the hypothesis: *)
  rewrite <- H.
  reflexivity. Qed.

(* Exercise: 1 star (plus_id_exercise) *)
Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros Hnm.
  rewrite <- Hnm.
  intros Hno.
  rewrite Hno.
  reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite plus_O_n.
  reflexivity.
Qed.

(*Exercise: 2 stars (mult_S_1) *)

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
 intros m n.
 simpl.
 intros H.
 rewrite <- H.
 reflexivity.
Qed.

(*----------------------------------------------------------*)
(* Proof by Case Analysis *)

Theorem plus_1_neq_0 : forall n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
  - reflexivity.
  - reflexivity.
Qed.

(*Lemma induction_test : forall n:nat, n = n -> n <= n.*)

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b.
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
Qed.

(*Exercise: 2 stars (andb_true_elim2) *)

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct b.
  - destruct c.
      + simpl. reflexivity.
      + simpl.  intros J. rewrite J. reflexivity.
  - destruct c.
      + simpl. intros T. reflexivity.
      + simpl. intros T. rewrite T. reflexivity.
Qed.

(* Exercise: 1 star (zero_nbeq_plus_1) *)
Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n. destruct n as [ | n'].
    - simpl. reflexivity.
    - simpl. reflexivity.
Qed.

(* More on Notation (Optional) *)

(* More Exercises *)
(* Exercise: 2 stars (boolean_functions) *)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f. destruct b.
  - rewrite H. rewrite H. reflexivity.
  - rewrite H. rewrite H. reflexivity.
Qed.

(* FILL IN HERE *)
(* The Import statement on the next line tells Coq to use the
   standard library String module.  We'll use strings more in later
   chapters, but for the moment we just need syntax for literal
   strings for the grader comments. *)
From Coq Require Export String.
(* Do not modify the following line: *)
Definition manual_grade_for_negation_fn_applied_twice : option (prod nat string) := None.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f. destruct b.
    - rewrite H. rewrite H. simpl. reflexivity.
    - rewrite H. rewrite H. simpl. reflexivity.
Qed.

(* Exercise: 3 stars, optional (andb_eq_orb) *)

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->  b = c.
Proof.
  intros c. destruct c.
    -intros b. simpl. intros H. rewrite H. reflexivity.
    - intros b. simpl. intros H. rewrite <- H. reflexivity.
Qed.

(* Exercise: 3 stars (binary) *)
(*
http://staff.ustc.edu.cn/~bjhua/courses/theory/2014/slides/lec1notes.html
http://kyledef.org/inzamam/2015/07/07/a-binary-number-system-in-coq/
https://www.cs.cmu.edu/~emc/15414-s14/assignment/hw2/Basics_w_ans.v
*)

Inductive bin : Type :=
           | Z  : bin
           | T  : bin -> bin
           | T' : bin -> bin.

Fixpoint inc (n : bin) : bin :=
  match n with
    | Z => T' Z
    | T t => T' t
    | T' n' => T (inc n')
  end.

Fixpoint bin_to_nat (n : bin) : nat :=
  match n with
  | Z => 0
  | T t => 2 *(bin_to_nat t)
  | T' t => 2 *(bin_to_nat t) + 1
  end.

Compute bin_to_nat (inc (inc Z)).

Example test_bin_incr1: bin_to_nat (inc (inc (inc Z))) = 3.
Proof. simpl. reflexivity. Qed.
(*
Fixpoint Simple_Collatz (b : bin) : bin :=
  match b with
    | Z => Z
    | T b' => Simple_Collatz b'
    | T' b' =>
      match b' with
        | Z => b
        | T b'' => Simple_Collatz (inc(b))
        | T' b'' => Simple_Collatz(inc(b))
      end
  end.
*)


(*Require Import untypedLC.*)

Section type_booleen.

Variable T : Set.
Variable N: Set.

(* Declaration de cbool *)
Definition cbool:= T -> T -> T.

Definition ctr: cbool := fun x y => x. (* true (church) *)
Definition cfa: cbool := fun x y => y. (* false (church) *)

Definition cif: cbool->T->T->T := fun b u v => b u v. (* IF b THEN u ELSE v *)

Variable E:T.
Variable F:T.
Definition TestConditionnelle0:= cif ctr E F. (* IF ctr THEN E ELSE F *)
Compute  TestConditionnelle0. (* = E *)
Definition TestConditionnelle1:= cif cfa E F. (* IF cfa THEN E ELSE F *)
Compute  TestConditionnelle1.  (* = F *)

(* si b est cfa sortie ctr, si ctr sortie cfa *)
Definition neg: cbool->cbool := fun b => fun x y =>b y x .
Definition testNeg:= neg ctr.  (* not true==false*)
Compute testNeg. (* => x0 *)

(* AND *)
Definition cand: cbool->cbool->cbool := fun a b => fun x y=> a( b x y) y.
Definition testCand:= cand ctr cfa. (* true and  false== false*)
Compute testCand. (* => x0 *)

(* or *)
Definition cor:cbool->cbool->cbool:= fun a b => fun x y => a x (b x y).
Definition testCor:= cor cfa cfa. (* false or  false== false*)
Compute testCor.  (* => x0 *)

(* 1.2.2 *)

(* declaration de type cnat *)
Definition cnat:= (T->T)->(T->T).
(* codage des 5 premiers entiers de churche *)
Definition c0:cnat :=fun f x =>x .
Definition c1:cnat:=fun f x=>f x.
Definition c2:cnat:=fun f x => f(f x).
Definition c3:cnat:=fun f x => f(f(f x)).
Definition c4:cnat:=fun f x => f(f(f(f x))).

(* fonction successeur *)
(* n avec une fois de ++ *)
Definition csucc:cnat->cnat := fun n => fun f x => f(n f x).
Definition TestCsucc:= csucc c1.
Compute  TestCsucc. (* 1++ ==2*)

(* fonction addition *)
(* m avec n fois de ++ *)
Definition cplus:cnat->cnat->cnat := fun n m => fun f x => n f (m f x).
Definition TestCplus:= cplus c2 c3.
Compute  TestCplus. (* 2+3==5*)

(* fonction multiplication *)
(*m avec n fois de +m *)
Definition cmul:cnat->cnat->cnat := fun n m=> fun f => n (m f).
Definition TestCmul := cmul c2 c3.
Compute  TestCmul. (*2*3==6*)

(* fonction egale 0 *)
(* utilise n pour choisir x ou y sur (\z~y)x *)
Definition ceq0:cnat->cbool :=fun n => fun x y => n( fun z=> y) x.
Definition TestCeq0tr := ceq0 c0.
Compute  TestCeq0tr.  (* 0==0 -> ctr*)
Definition TestCeq0fa := ceq0 c1.
Compute  TestCeq0fa. (* 1!=0 -> cfa*)


Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Import ListNotations.

(** Dans cet exercice, nous étudions la question de l'égalité dans les
    monoïdes. En mathématique (et donc en informatique), un monoïde
    est un ensemble [M] muni d'un élément unité [unit : M] et d'une
    opération de séquence [seq : M -> M -> M] vérifiant les équations
    suivantes:

    [[
       (unité à gauche:)
           forall m: M, seq unit m = m

       (unité à droite:)
           forall m: M, seq m unit = m

       (associativité:)
           forall m n o: M,
               seq m (seq n o) = seq (seq m n) o
    ]]

    Par exemple, les entiers naturels [nat] forment un monoïde
    (commutatif, de surcroît) pour l'unité [0 : nat] et l'addition
    [+ : nat -> nat -> nat]. *)

Lemma nat_left_unit: forall n: nat, 0 + n = n.
Proof. trivial. Qed.

Lemma nat_right_unit: forall n: nat, n + 0 = n.
Proof. now induction n. Qed.

Lemma nat_assoc: forall m n o: nat, m + (n + o) = (m + n) + o.
Proof. now induction m; auto; simpl; intros; rewrite IHm. Qed.

(** QUESTION [difficulté [*] / longueur [*]]

    Montrer que les listes forment également un monoïde (non
    commutatif) pour l'unité [nil : list A] et la concaténation
    [++ : list A -> list A -> list A]. *)

Lemma list_left_unit {A}: forall l: list A, [] ++ l = l.
Proof.
  intro.
  induction l; simpl; auto.
Qed.

Lemma list_right_unit {A}: forall l: list A, l ++ [] = l.
Proof.
  apply app_nil_r.
Qed.

Lemma list_assoc {A}: forall (l m n: list A), (l ++ m) ++ n = l ++ (m ++ n).
Proof.
  apply app_assoc_reverse.
Qed.

(** Dans ce sujet, on s'intéresse à la question de savoir si deux
    expressions [e1] et [e2] de type [M] sont égales. *)

(** QUESTION  [difficulté [*] / longueur [***]]

    Prouver que les deux expressions suivantes, écrites
    dans le monoïde des listes, sont égales: *)
SearchAbout "++".

Example list_eq {A}: forall (x y z: list A),
    (x ++ (y ++ [])) ++ (z ++ [])
        =
    (x ++ []) ++ ([] ++ y) ++ z.
Proof.
  intros.
  induction x.
   + simpl.
     induction y.
     * simpl. apply list_right_unit.
     * simpl. rewrite IHy. reflexivity.
   + simpl. rewrite IHx. simpl. reflexivity.

Qed.

(** Plutôt que de faire une telle preuve à chaque problème, nous
    allons construire une _procédure de décision_ résolvant le
    problème de l'égalité pour n'importe quelle équation et sur
    n'importe quel monoïde. *)

(** * Expressions *)

(** Pour cela, la première étape consiste à décrire, dans Coq, la
    syntaxe de telles équations. Pour représenter les variables de ces
    équations, nous utilisons des identifiants : *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id x1 x2 :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

(** Par exemple, on défini (arbitrairement) les variables [U] à [Z] de
    la façon suivante: *)

Definition U : id := Id 0.
Definition V : id := Id 1.
Definition W : id := Id 2.
Definition X : id := Id 3.
Definition Y : id := Id 4.
Definition Z : id := Id 5.

(** On peut associer des valeurs Coq à des identifiants par le moyen
    d'un _environnement_ : *)

Definition env (A: Type) := id -> A.

Definition update {A}(e: env A)(x: id)(v: A): env A :=
  fun y => if beq_id x y then v else e y.

Notation "m [ x |-> v ]" := (update m x v)
                              (at level 10, x, v at next level).

(** Une expression dans un monoïde correspond alors à une variable
    [AId], à l'unité [Unit] du monoïde ou à la séquence [Seq] du
    monoïde. *)

Inductive exp: Type :=
| AId: id -> exp
| Unit: exp
| Seq: exp -> exp -> exp.

(** On note [e1 # e2] la séquence [Seq e1 e2] et [`X] le terme [AId X]. *)

Infix "#" := Seq
               (right associativity, at level 60, only parsing).
Notation "` X" := (AId X)
               (at level 5, only parsing).

Reserved Notation "e1 '~' e2" (at level 65).

(** Deux expressions [e1] et [e2] sont égales, suivant les équations
du monoïde, si et seulement ils satisfont la relation d'équivalence
suivante, ie. si l'on peut construire une preuve de [e1 ~ e2]: *)

Inductive eq: exp -> exp -> Prop :=
| mon_left_id: forall e, Unit # e ~ e
| mon_right_id: forall e, e # Unit ~ e
| mon_assoc: forall e f g, (e # f) # g ~ e # (f # g)

| mon_refl: forall e, e ~ e
| mon_sym: forall e f, e ~ f -> f ~ e
| mon_trans: forall e f g, e ~ f -> f ~ g -> e ~ g
| mon_congr: forall e f g h, e ~ g -> f ~ h -> e # f ~ g # h

where "e1 '~' e2" := (eq e1 e2).

(** QUESTION  [difficulté [*] / longueur [***]]

    Prouver l'équivalence suivante: *)

Example mon_exp_eq:
    (`X # (`Y # Unit)) # (`Z # Unit)
        ~
    (`X # Unit) # (Unit # `Y) # `Z.
Proof.
  assert (((`X # (`Y # Unit)) # (`Z # Unit)) ~
  (`X # ((`Y # Unit) # (`Z # Unit)))).
  - apply mon_assoc.
  - admit.
Qed.

(** Le type [exp] nous permet ainsi de représenter une expression
    quelconque d'un monoïde tandis que [~] capture précisement les
    équations que vérifie ce monoïde. La preuve [mon_exp_eq] ci-dessus
    s'applique ainsi à _tous_ les monoïdes concevables: il s'agit
    d'une preuve "générique".  *)

(** Cependant, la preuve en elle-même consiste à créer un témoin de
    l'équivalence par le truchement des constructeurs du type [~]:
    pour des preuves non-triviales, cela nécessitera de construire des
    témoins de preuves en mémoire, ralentissant voir rendant
    impossible l'effort de preuve. *)

(** * Normalisation par évaluation *)

(** Nous allons remplacer la construction manuelle de ces témoins de
    preuves par un _programme_ calculant ces témoins. En prouvant la
    correction de ce programme, on obtient alors la correction de
    notre procédure de décision. *)

(** On remarque que nos expressions s'interprètent naturellement dans
    le monoïde des fonctions de domaine [exp] et de co-domaine [exp],
    où l'unité correspond à la fonction identité et où la séquence
    correspond à la composition de fonctions: *)

Definition sem_exp := exp -> exp.

Notation sem_exp_unit := (fun x => x)
                           (only parsing).
Notation sem_exp_seq e1 e2 := (fun x => e1 (e2 x))
                           (only parsing).

Fixpoint eval (c: exp): sem_exp :=
  match c with
  | Unit => sem_exp_unit
  | Seq e1 e2 => sem_exp_seq (eval e1) (eval e2)
  | AId i => fun e => `i # e
  end.

(** Étant donné un [sem_exp], on obtient une expression [exp] par
    application à l'unité. Par composition de l'évaluation et de la
    réification, on obtient une procédure de normalisation des
    expressions. *)

Definition reify (f: sem_exp): exp := f Unit.

Definition norm (e: exp): exp := reify (eval e).

(** Il s'agit de prouver que les termes ainsi obtenus sont
    effectivement des formes normales. Formellement, il s'agit de
    prouver la correction de notre procédure, ie. si deux expressions
    sont identifiées par [norm] alors elles sont équivalentes par
    l'équivalence [~]:

    [[
    Lemma soundness:
          forall e1 e2, norm e1 = norm e2 -> e1 ~ e2.
    ]]

    et, inversement, il s'agit aussi de prouver la complétude de notre
    procédure, ie. si deux expressions sont équivalentes par [~] alors
    elles sont identifiées par [norm]:

    [[
    Lemma completeness:
          forall e1 e2, e1 ~ e2 -> norm e1 = norm e2.
    ]]
    *)

(** QUESTION  [difficulté [**] / longueur [**]]

    À cette fin, prouvez les trois lemmes techniques suivants: *)

Print eq.

Lemma yoneda:
  forall e e', e # e' ~ eval e e'.
Proof.
  intros.
  induction e.
  + simpl. apply mon_refl.
  + simpl. apply mon_left_id.
  + simpl.
    inversion IHe1.
    - simpl. replace (Seq (Seq Unit e2) e') with (Seq e2 e').
      assumption.
      admit.
    - admit.
    - admit.
    - admit.
    - admit.
    - admit.
    - admit.
Qed.

Lemma pre_soundness:
  forall e, e ~ norm e.
Proof.
  intro e.
  eapply mon_trans.
  eapply mon_sym. eapply mon_right_id.
  unfold norm, reify.
  apply yoneda.
Qed.

Lemma pre_completeness:
  forall e1 e2, e1 ~ e2 -> forall e', eval e1 e' = eval e2 e'.
Proof.
  intros e1 e2 H e'.
  induction H; try easy.
  rewrite IHeq1. rewrite IHeq2.
  reflexivity. simpl.
  SearchPattern ( _ = _).
  rewrite IHeq2.
  (* f_equal. *)
  admit.
Qed.

(** QUESTION [difficulté [***] / longueur [*]]

    À partir des résultats techniques ci-dessus, complétez
    les théorèmes suivants: *)

Theorem soundness:
  forall e1 e2, norm e1 = norm e2 -> e1 ~ e2.
Proof.
  intros.
  unfold norm, reify in H.
  (** AAAAAAAAAAAAHHHHH **)
  (* apply pre_completeness in H.*)

 (* induction e1.
  - simpl in H. apply mon_sym. *)
    admit.
Qed.

Theorem completeness:
  forall e1 e2, e1 ~ e2 -> norm e1 = norm e2.
Proof.
  intros. apply pre_completeness. assumption.
Qed.

(** QUESTION [difficulté [***] / longueur [*]]

    Ces résultats ne servent pas seulement à s'assurer de la validité
    de notre programme, ils nous permettent de donner une preuve
    triviale à des problèmes d'égalité. Par exemple, prouvez le lemme
    suivant de façon concise: *)

Example non_trivial_equality:
  Seq (`U # Unit)
       (Seq (Unit # `V)
            (`W #
                 (Seq (`X # `Y)
                      (`Z # Unit))))
    ~
  (Seq (AId U)
       (Seq (Seq (Seq (AId V) Unit)
                 (Seq (AId W) Unit))
            (Seq (AId X) (Seq (AId Y) (AId Z))))).
Proof.
  apply soundness.
  unfold norm, reify. simpl. reflexivity.
Qed.

(** * Preuve par réflection *)

Variable A : Type.

(** Dans la section précédente, nous avons développé une procédure de
    décision vérifiée pour décider l'égalité d'expressions sur un
    monoïde quelconque. Nous allons désormais exploiter cet outil pour
    décider de l'égalité dans le cas particulier du monoïde des
    listes. *)

(** À cette fin, nous donnons une interprétation des expressions vers
    les listes, où l'unité est traduite vers [nil], la séquence est
    traduite vers la concaténation [++] et l'interprétation des
    variables est donnée par l'environnement. *)

Fixpoint interp (m: env (list A))(e: exp): list A :=
  match e with
  | Unit => []
  | Seq a b => interp m a ++ interp m b
  | AId x => m x
  end.

(** Cette fonction d'interprétation nous permet de remplacer (de façon
    calculatoirement transparente) des expressions Coq portant sur le
    monoïde des listes vers des expressions [exp] portant sur un
    monoïde quelconque. *)

Definition empty: env (list A) := fun _ => [].

Remark trivial_eq: forall (x y z: list A),
    let m := empty [ X |-> x ][ Y |-> y ][ Z |-> z ] in

    (x ++ (y ++ [])) ++ (z ++ [])
       =
    interp m ((`X # (`Y # Unit)) # (`Z # Unit)).

Proof. reflexivity. Qed.

(** QUESTION [difficulté [**] / longueur [**]]

    L'interprétation [interp] est _correcte_ si elle respecte les
    égalités des monoïdes. Prouvez que c'est effectivement le cas. *)

Lemma interp_proper: forall m e e', e ~ e' -> interp m e = interp m e'.
Proof.
  intros.
  induction H; try auto.
  - simpl. SearchAbout "app_". apply app_nil_r.
  - simpl. apply app_assoc_reverse.
  - simpl. rewrite IHeq1. rewrite IHeq2. auto.
  - simpl. rewrite IHeq1. rewrite IHeq2. auto.
Qed.

(** QUESTION [difficulté [***] / longueur [**]]

    En exploitant le lemme [interp_proper] et la correction de la
    procédure de décision, donnez des preuves concises des égalités
    suivantes. *)

Example list_eq2: forall (x y z: list A),
    (x ++ (y ++ [])) ++ (z ++ [])
        =
    (x ++ []) ++ ([] ++ y) ++ z.
Proof.
  intros.
  set (m := empty [ X |-> x ][ Y |-> y ][ Z |-> z]).
  change ((x ++ (y ++ [])) ++ (z ++ []))
  with (interp m ((`X # (`Y # Unit)) # (`Z # Unit))).
  change ((x ++ []) ++ ([] ++ y) ++ z)
  with (interp m ((`X # Unit) # (Unit # `Y) # `Z)).
  apply interp_proper.
  apply soundness. compute. reflexivity.
Qed.

Example list_eq3 : forall (u: list A) v w x y z,
    u ++ ([] ++ v ++ []) ++ w ++ x ++ (y ++ []) ++ z
      =
    u ++ ((v ++ [] ++ w) ++ x ++ y) ++ (z ++ []) ++ [].
Proof.
  intros.
  set (m := empty [ U |-> u ][ V |-> v ][ W |-> w] [X |-> x ][ Y |-> y ][ Z |-> z]).
  change (u ++ ([] ++ v ++ []) ++ w ++ x ++ (y ++ []) ++ z)
  with (interp m (`U # (Unit # (AId V)# Unit) # (AId W) # (AId X) #
                   ((AId Y) # Unit) # (AId Z))).
  change (u ++ ((v ++ [] ++ w) ++ x ++ y) ++ (z ++ []) ++ [])
  with (interp m (`U # (((AId V) # Unit # (AId W)) # (AId X) # (AId Y))
                   # ((AId Z) # Unit) # Unit)).
  apply interp_proper.
  apply soundness. reflexivity.
Qed.


Require Import ZArith List.
Open Scope Z_scope.

(* Define a datatype of binary trees where non-atomic nodes have only two
  components which are binary trees, and only atomic nodes carry an integer
  value.  Include a case for empty trees. *)

Inductive bt : Type :=  E | L (x : Z) | N (t1 t2 : bt).

(* Define a function that takes a list as input and constructs a balanced
  binary tree carrying the same values.  The trick is to interchange the
  the two components of each node after inserting an integer into the first
  node -- beware that you have to define two recursive functions for this
  question. *)

Fixpoint insert_bt (x : Z) (t : bt) : bt :=
  match t with
    E => L x
  | L y => N (L x) (L y)
  | N t1 t2 =>  N t2 (insert_bt x t1)
  end.

Definition bt_of_l : list Z -> bt := fold_right insert_bt E.

(* Define a function with three arguments: a natural number and two
  lists, which builds a new list by always taking the least element
  of the heads of the two lists.  The length of the resulting list should
  be the natural number given as first input (if the two lists are long enough).

  This is a merge function as in the "merge sort" algorithm, except that the
  natural number argument should be the sum of the lengths of the two input
  lists.
*)

Fixpoint merge' (n:nat)(l1 l2 : list Z) : list Z :=
  match n with
    O => nil
  | S p =>
    match l1, l2 with
      (a::l1), (b::l2) =>
         if Zle_bool a b then
            a::merge' p l1 (b::l2)
         else
            b::merge' p (a::l1) l2
    | (a::l1), nil => a::merge' p l1 nil
    | nil, (b::l2) => b::merge' p nil l2
    | nil, nil => nil
    end
  end.

(* Define a function that merges two lists bu first computing the sum of their
  lengths and then calling the previous function. *)

Definition merge (l1 l2 : list Z) : list Z :=
  merge' (length l1 + length l2) l1 l2.

(* Define a recursive function on binary trees which returns a sorted list:
  - on empty trees it returns the empty list
  - on leaf treeas carrying one value, it returns a singleton list
  - on binary nodes, it returns the merge of the two sorted lists obtained
    from the sub-components. *)

Fixpoint sl_of_bt (t : bt) : list Z :=
  match t with
    E => nil
  | L x => x::nil
  | N t1 t2 => merge (sl_of_bt t1) (sl_of_bt t2)
  end.

(* Define a function that sorts a list by first constructing a balanced binary
  tree and then by calling the function above. *)

Definition merge_sort (l:list Z) := sl_of_bt (bt_of_l l).

(* Define a function that takes three integers a, b, and n and constructs the
  list a^n mod b, a^(n-1) mod b, ....  a mod b -- use the iter function
  as in the previous class.  Use this function to generate large lists of
  pseudo-random numbers.  Test your sorting function on these inputs. *)

Definition pseudo_rand a b n :=
  let (_, l) := iter n (Z*list Z) (fun p =>
                     let (v,l) := p in
                     let v' := Zmod (a * v) b in
                          (v', v'::l)) (1, nil) in
  l.

Definition l1 := Eval vm_compute in pseudo_rand 1789 100003 500.

Eval vm_compute in length l1.
Time Eval vm_compute in (merge_sort l1).

Fixpoint sorted_bool (l:list Z) : bool :=
 match l with nil => true
            | a::nil => true
            | a::((b::l) as l1)  => if Zle_bool a b
                                    then sorted_bool l1
                                    else false
 end.

Eval compute in sorted_bool (merge_sort l1).
Eval vm_compute in sorted_bool l1.


Require Export Arith List.

Section DivConq.

Variable A : Type.
Implicit Type l : list A.

(* (Ordering) lengthOrder ls1 ls2 :=
 * length ls1 < length ls2
 *)

Definition lengthOrder (ls1 ls2 : list A) := length ls1 < length ls2.

Lemma lengthOrder_wf' : forall len, forall ls,
  length ls <= len -> Acc lengthOrder ls.
Proof.
unfold lengthOrder; induction len.
- intros; rewrite Nat.le_0_r,length_zero_iff_nil in H; rewrite H; constructor;
  intros; inversion H0.
- destruct ls; constructor; simpl; intros.
  + inversion H0.
  + simpl in H; apply le_S_n in H; apply lt_n_Sm_le in H0; apply IHlen;
    eapply Nat.le_trans; eassumption.
Defined.

(* lengthOrder_wf:
 * states that the ordering, lengthOrder, is well founded.
 *)

Lemma lengthOrder_wf : well_founded lengthOrder.
Proof.
red; intro; eapply lengthOrder_wf'; eauto.
Defined.

(* div_conq:
 * Suppose for some arbitrary split function, splitF, with the condition that
 * for any list l, if the length of l is at least 2, then both the sublists
 * generated have length less than the input list. To prove some proposition P
 * holds for all lists ls, one needs to prove the following:
 * 1. P holds for empty list, nil.
 * 2. P holds for one-element list, (a :: nil).
 * 3. If P hold fst(splitF ls) and snd(splitF ls), then P must also hold for ls.
 *)

Lemma div_conq :
  forall (P : list A -> Type)
  (splitF : list A -> list A * list A)
  (splitF_wf1 : forall ls, 2 <= length ls -> lengthOrder (fst (splitF ls)) ls)
  (splitF_wf2 : forall ls, 2 <= length ls -> lengthOrder (snd (splitF ls)) ls),
    P nil -> (forall a, P (a :: nil))
    -> (forall ls, (P (fst (splitF ls)) -> P (snd (splitF ls)) -> P ls))
    -> forall ls, P ls.
Proof.
intros; apply (well_founded_induction_type lengthOrder_wf); intros.
destruct (le_lt_dec 2 (length x)).
- apply X1; apply X2.
  + apply splitF_wf1; auto.
  + apply splitF_wf2; auto.
- destruct x; auto. simpl in l;
  apply le_S_n, le_S_n, Nat.le_0_r,length_zero_iff_nil  in l; rewrite l; auto.
Defined.

(* split:=
 * split an input list ls into two sublists where the first sublist contains all
 * the odd indexed element/s and the second sublist contains all the even
 * indexed element/s.
 *)

Fixpoint split (ls : list A) : list A * list A :=
  match ls with
  | nil => (nil, nil)
  | h :: nil => (h :: nil, nil)
  | h1 :: h2 :: ls' =>
      let (ls1, ls2) := split ls' in
        (h1 :: ls1, h2 :: ls2)
  end.

(* split_wf:
 * states that for any list ls of length at least 2, each of the two sublists
 * generated has length less than its original list's.
 *)

Lemma split_wf : forall len ls, 2 <= length ls <= len
  -> let (ls1, ls2) := split ls in lengthOrder ls1 ls /\ lengthOrder ls2 ls.
Proof.
unfold lengthOrder; induction len; intros.
- inversion H; inversion H1; rewrite H1 in H0; inversion H0.
- destruct ls; inversion H.
  + inversion H0.
  + destruct ls; simpl; auto.
    destruct (le_lt_dec 2 (length ls)).
    * specialize (IHlen ls); destruct (split ls); destruct IHlen; simpl.
      simpl in H1; apply le_S_n in H1; split; auto. apply le_Sn_le; auto.
      split; rewrite <- Nat.succ_lt_mono; auto.
    * inversion l.
      -- destruct ls; inversion H3; apply length_zero_iff_nil in H4; rewrite H4;
         simpl; auto.
      -- apply le_S_n in H3. inversion H3.
         apply length_zero_iff_nil in H5; rewrite H5; simpl; auto.
Defined.

Ltac split_wf := intros ls ?; intros; generalize (@split_wf (length ls) ls);
  destruct (split ls); destruct 1; auto.

Lemma split_wf1 : forall ls, 2 <= length ls -> lengthOrder (fst (split ls)) ls.
Proof.
split_wf.
Defined.

Lemma split_wf2 : forall ls, 2 <= length ls -> lengthOrder (snd (split ls)) ls.
Proof.
split_wf.
Defined.

(* div_conq_split:
 * - an instance of div_conq where the arbitrary splitF function
 *   is replaced by the split function defined above.
 * - To prove some proposition P holds for all lists ls, one needs to prove the
     following:
 *   1. P holds for empty list, nil.
 *   2. P holds for one-element list, (a :: nil).
 *   3. If P hold fst(split ls) and snd(split ls), then P must also hold for ls.
 *)

Definition div_conq_split P := div_conq P split split_wf1 split_wf2.

End DivConq.

Ltac div_conq_split := eapply div_conq_split.


(********** Exercice 1 **********)
(* Question 1 *)
Fixpoint myplus (a b:nat) :=
match b with
| 0 => a
| S n => S (myplus a n)
end.

(* Question 2 *)
Require Import Arith.
Lemma myplus_assoc : forall a b c : nat,
myplus (myplus a b) c = myplus a (myplus b c).
Proof.
intros.
induction c.
simpl.
reflexivity.
simpl.
rewrite IHc.
reflexivity.
Qed.

(* Question 3 *)
Lemma myplus_Sn_m : forall n m : nat,
myplus (S n) m = S (myplus n m).
Proof.
intros.
induction m.
simpl.
reflexivity.
simpl.
rewrite <- IHm.
reflexivity.
Qed.

Lemma myplus_0_m : forall m : nat,
myplus 0 m = m.
Proof.
intros.
induction m.
simpl.
reflexivity.
simpl.
rewrite IHm.
reflexivity.
Qed.

(* Question 4 *)
Lemma myplus_comm : forall a b :nat,
myplus a b = myplus b a.
Proof.
intros.
induction a.
simpl.
rewrite myplus_0_m.
reflexivity.
simpl.
rewrite myplus_Sn_m.
rewrite IHa.
reflexivity.
Qed.

(* Question 5 *)
Fixpoint sommation (f:nat->nat) (n:nat) :=
match n with
| 0 => f n
| S m => f (S m) + sommation f m
end.

Eval compute in sommation (fun x => x) 100.

(* Question 6 *)
Require Export ArithRing.
Lemma sommation_f_Sn : forall (f: nat->nat) (n:nat),
sommation f (S n) = f (S n) + sommation f n.
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma q6 : forall n : nat,
2 * sommation (plus 0) n = n*(n+1).
Proof.
intros.
induction n.
simpl.
reflexivity.
rewrite plus_Sn_m.
rewrite sommation_f_Sn.
rewrite plus_O_n.
rewrite Nat.mul_add_distr_l.
rewrite IHn.
ring.
Qed.

(********** Exercice 2 **********)
(* Question 7 *)
(*
  m correspond, à .
  i et j correspondent respectivement au nombre de pièces 5 et 3 euros.
*)
(* Question 8&9 *)
(*
  Avec le principe d'induction suivant, on pourra aisément démontrer le théorème.
  forall P : nat->Prop,
  P 0 -> P 1 -> P 2 -> (forall n : nat, P n -> P(n+3)) -> forall n : nat, P n.
*)
Lemma induc_by_3 : forall P : nat->Prop,
P 0 -> P 1 -> P 2 -> (forall n : nat, P n -> P(S (S (S n)))) -> forall n : nat, P n.
Proof.
intros.
assert (Hx : P n /\ P (S n) /\ P (S (S n))).
induction n.
split.
assumption.
split;assumption.
split.
destruct IHn.
destruct H4.
assumption.
split.
destruct IHn.
destruct H4.
assumption.
apply H2.
destruct IHn.
assumption.
destruct Hx.
assumption.
Qed.

Lemma pieces : forall m : nat, exists i : nat, exists j : nat,
8+m=5*i+3*j.
Proof.
intros.
induction m.
exists 1.
exists 1.
reflexivity.
destruct IHm as [x [y H]].
rewrite <- plus_n_Sm, H.
destruct x.
(* x=0 *)
  (* y=0 *)
  destruct y.
  discriminate.
    (* y => Sy *)
    destruct y.
    discriminate.
    destruct y.
    discriminate.
    exists 2,y.
    ring.
(* x>0 *)
exists x, (y+2).
ring.
Qed.

Lemma pieces_avec_mon_lemmme : forall m : nat, exists i : nat, exists j : nat,
8+m=5*i+3*j.
Proof.
Qed.


(* Exercise coq_tree_05 *)

Require Import Arith.

(* Let us start with the definitions from the previous
   exercises *)

Inductive nat_tree : Set :=
  | leaf : nat_tree
  | node : nat_tree -> nat -> nat_tree -> nat_tree.

Fixpoint In (n : nat) (T : nat_tree) {struct T} : Prop :=
  match T with
  | leaf => False
  | node l v r => In n l \/ v = n \/ In n r
  end.

Fixpoint mirror (T : nat_tree) : nat_tree :=
  match T with
  | leaf => leaf
  | node l v r => node (mirror r) v (mirror l)
  end.

Fixpoint tree_sum(T: nat_tree): nat :=
  match T with
  | leaf => 0
  | node l v r => (tree_sum l) + v + (tree_sum r)
  end.

Search (?n + O).

Lemma tree_sum_ex : forall a b c d,
  tree_sum (node (node leaf a leaf) b (node (node leaf c leaf) d leaf)) =
  a + b + c + d.

Proof.
intros.
simpl.
repeat rewrite Nat.add_0_r.
rewrite Nat.add_assoc.
reflexivity.
Qed.

Print Nat.add_comm.
(* Now let us prove that the sum of the elements in the
   mirrored tree is the same as in the original one *)

Lemma mirror_tree_sum : forall T, tree_sum T = tree_sum (mirror T).

Proof.
  intros.
  induction T.
* simpl; reflexivity.
* simpl.
  rewrite IHT1.
  rewrite IHT2.
  rewrite Nat.add_comm.
  rewrite Nat.add_comm with (m := n).
  rewrite Nat.add_assoc.
  reflexivity.
Qed.


(* The next couple of commands are from bool.v but their
needed to make sense of the first part of this file *)

Inductive bool : Type :=
	| true : bool
	| false: bool.

Definition negb (b:bool) : bool :=
  match b with
    | true => false
    | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => b2
    | false => false
   end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => true
    | false => b2
  end.

Module NatPlayground.

Inductive nat : Type :=
  | O : nat (* O is a natural number (note that this is the letter "O," not the numeral "0")*)
  | S : nat -> nat. (* S can be put in front of a natural number to yield another one \u2014 if n is a natural number, then S n is too *)

(* The following is the predecessor function, returns the nat before the nat given *)
Definition pred (n:nat) : nat :=
  match n with
  | O => O
  | S n' => n' (* "if n has the form S n' for some n', then return n'." *)
  end.

End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n:nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minustwo 4).

Check S.

Check pred.

Check minustwo.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n:nat) : bool := negb (evenb n).
Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

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

Compute (plus 3 2).

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m: nat) : nat :=
  match (n, m) with
  | (O, _) => O
  | (S _, O) => n
  | (S n', S m') => minus n' m'
  end.
End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Compute exp 3 3.

(* Exercise *)
Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => S O
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.
Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope.
Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

Check ((0 + 1) + 1).
Compute ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

(* tests whether its first argument is less
than or equal to its second argument, yielding a boolean. *)
Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' => match m with
            | O => false
            | S m' => leb n' m'
            end
  end.

Example test_leb1: (leb 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: (leb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: (leb 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* exercise blt_nat *)


Inductive AExp : Type :=
| ALit (n : nat)
| APlus (a1 a2 : AExp)
| ASub (a1 a2 : AExp).

Definition exTree : AExp :=
(APlus
    (ASub
        (ALit 1)
        (APlus
            (ALit 2)
            (ALit 3)
        )
     )
    (ALit 0)
).

Fixpoint leaves (a : AExp) : nat := match a with
  | ALit n => 1
  | APlus a1 a2 => leaves a1 + leaves a2
  | ASub a1 a2 => leaves a1 + leaves a2
  end.

Fixpoint height (a : AExp) : nat := match a with
  | ALit n => 0
  | APlus a1 a2 => 1 + max (height a1) (height a2)
  | ASub a1 a2 => 1 + max (height a1) (height a2)
  end.

Example exExp : AExp := (APlus (ALit 1) (ALit 2)).

Lemma exExpProp : height exExp = 1.
Proof.
  simpl.
  reflexivity.
Qed.
(*
Tactic reminder:

           INTRODUCTION     ELIMINATION
True       split
False                       destruct
/\         split            destruct
\/         left, right      destruct
forall     intro            apply
exists     exists           destruct
->         intro            apply

others:
assert
discriminate
simpl
*)

(*
Abstract representation levesl:
ABT  not possible to represent "\x.(x+y" (\x read as lambda x) due to scope
WTT  not possible to represent "true+1" due to not possible to evaluate
Alg
HOAS
*)

Example expWithProperty : exists (a : AExp), leaves a = 3 /\ height a = 2.
Proof.
  exists (ASub (ALit 10) (ASub (ALit 1) (ALit 2))).
  simpl.
  split.
  all: reflexivity.
Qed.

Example notPoss : not (exists (a : AExp), leaves a = 2 /\ height a = 0).
Proof.
  unfold not.
  intros.
  destruct H.
  destruct H.
  destruct x.
  { unfold leaves in H. discriminate. }
  all: simpl in H0.
  all: discriminate H0.
Qed.

(* Denotational semantics *)
Fixpoint aeval (a : AExp) : nat :=
  match a with
  | ALit n      => n
  | APlus a1 a2 => aeval a1 + aeval a2
  | ASub  a1 a2 => aeval a1 - aeval a2
  end.

Compute aeval exTree.
Compute exExp.
Compute aeval exExp.

Lemma eval_exExp : aeval exExp = 3.
Proof.
  simpl.
  reflexivity.
Qed.

Check ex_proj1.

Fixpoint optim (a : AExp) : AExp :=
  match a with
  | ALit n => ALit n
  | APlus e1 (ALit 0) => optim e1
  | APlus e1 e2 => APlus (optim e1) (optim e2)
  | ASub  e1 e2 => ASub  (optim e1) (optim e2)
  end.

Compute optim exExp.
Compute aeval exExp.
Compute aeval (APlus (ALit 1) (ALit 2)).

Require Import Coq.Arith.Plus.

Check plus_0_r.

Lemma optim_sound (a : AExp) :
  aeval (optim a) = aeval a.
Proof.
  induction a.
  { simpl. reflexivity. }
  { simpl.
    destruct a2.
    destruct n.
    { rewrite IHa1. simpl. rewrite (plus_0_r). reflexivity. }
    { simpl. rewrite IHa1. reflexivity. }
    { simpl. simpl in IHa2. rewrite IHa2. rewrite IHa1. reflexivity. }
    { simpl. simpl in IHa2. rewrite IHa2. rewrite IHa1. reflexivity. }
  }
  { simpl. rewrite -> IHa1. rewrite -> IHa2. reflexivity. }
Qed.

Lemma optim_sound2 (a : AExp) :
  aeval (optim a) = aeval a.
Proof.
  induction a.
  all: try ( info_auto ).
  all: try ( simpl; rewrite -> IHa1; rewrite -> IHa2; reflexivity ).
  simpl.
  destruct a2.
  destruct n.
  all: try ( simpl; simpl in IHa2; rewrite IHa2; rewrite IHa1; info_auto ).
  all: try ( simpl; rewrite IHa1; reflexivity ).
  rewrite IHa1. simpl.  rewrite (plus_0_r). reflexivity.
Qed.

(* try, ; *)

Fixpoint optimoptim (a : AExp) : AExp := ALit (aeval a).

Lemma optimoptim_sound (a : AExp ) : aeval (optimoptim a) = aeval a.
Proof.
  induction a.
  all: simpl.
  all: reflexivity.
Qed.

Fixpoint optim' (a : AExp) : AExp :=
  match a with
  | ALit n => ALit n
  | APlus (ALit x) (ALit y) => ALit (x + y)
  | APlus e1 e2 => APlus (optim' e1) (optim' e2)
  | ASub  e1 e2 => ASub  (optim' e1) (optim' e2)
  end.

Lemma optim'_sound (a : AExp) : aeval (optim' a) = aeval a.
Proof.
  induction a.
  all: try ( simpl; reflexivity ).
  all: try ( simpl; rewrite IHa1; rewrite IHa2; reflexivity ).
  destruct a1.
  destruct a2.
  destruct n.
  all: try ( simpl; reflexivity ).
  all: try ( simpl in IHa2; simpl; rewrite IHa2; reflexivity ).
  all: try ( simpl in IHa1; simpl; rewrite IHa1; rewrite IHa2; reflexivity ).
Qed.

(* exercise: create more optimisations and prove them sound! *)

Require Import Nat.
Require Import Arith.

(* standard library documentation *)

(* See Arith.Le *)

Check Nat.le_refl.
Check Nat.le_trans.
Check Nat.le_max_l.
Check Nat.le_max_r.
Check Nat.pow_le_mono.
Check Nat.add_le_mono.

Lemma leaves_height (a : AExp) : leaves a <= 2 ^ height a.


Require Import Arith fib_ind.

(* A geralisation of the fibonacci sequence, parameterized by
   its two first items *)

Fixpoint general_fib (a0 a1 n:nat) {struct n} : nat :=
  match n with
  | O => a0
  | S p => general_fib a1 (a0 + a1) p
  end.

Definition fib_tail (n:nat) := general_fib 1 1 n.

(** Test : should return 89

Compute fib_tail 10.

*)

Lemma general_fib_1 : forall a b:nat, general_fib a b 1 = b.
Proof. reflexivity. Qed.

Lemma general_fib_S :
 forall a b n:nat, general_fib a b (S n) = general_fib b (a + b) n.
Proof. reflexivity. Qed.

Lemma general_fib_2 :
 forall a b n:nat,
   general_fib a b (S (S n)) = general_fib a b n + general_fib a b (S n).
Proof.
 intros a b n; generalize a b; induction n as [ | n IHn].
 - reflexivity.
 - clear a b; intros a b.
   rewrite (general_fib_S _ _ (S (S n))), IHn.
   now rewrite (general_fib_S _ _  (S n)).
Qed.

Lemma linear_fibo_equiv : forall n:nat, fib_tail n = fib n.
Proof.
 intro n; induction n as [| | n IHn IHSn] using fib_ind.
 - reflexivity.
 - reflexivity.
 -  unfold fib_tail in *; rewrite general_fib_2.
    rewrite IHn, IHSn; reflexivity.
Qed.


Require Import ZArith.
Require Import List.
Require Extraction.

Set Implicit Arguments.

(* ================================================================================== *)
(* ====================================EXERCÍCIO 1=================================== *)
(* ================================================================================== *)

(*1. Apresente uma especificação forte adequada a cada uma das funções abaixo indicadas.
     Faça a prova desses teoremas (especificação) e, por fim, proceda à extração do respectivo programa Haskell.*)

  (*a) Uma função que, dado um número natural n e um valor x, constroi uma lista de tamanho n cujos elementos são todos iguais a x.*)
  Inductive CreateNList (A: Type) : nat -> A -> (list A) -> Prop :=
    | CNLzero : forall (x : A), CreateNList 0%nat x nil
    | CNLsucc : forall (n: nat) (x: A) (l: list A), CreateNList n x l -> CreateNList (S n) x (x::l).

  Theorem ex1a : forall (A: Type) (n: nat) (x: A), { l: list A | CreateNList n x l }.
  Proof.
    intros.
    induction n.
    - exists nil. apply CNLzero.
    - elim IHn. intros. exists (x::x0). apply CNLsucc. apply p.
  Qed.

  Extraction Language Haskell.
  Recursive Extraction ex1a.
  Extraction Inline nat_rect.
  Extraction Inline sig_rect.
  Recursive Extraction ex1a.

  Extraction "ex1a" ex1a.

  (*b) Uma função que recebe uma lista de pares de números naturais, e produz a lista com as somas das partes constituintes de cada par da lista.*)
  Inductive PairList : (list (nat*nat)) -> (list nat) -> Prop :=
    | PLnil  : PairList nil nil
    | PLcons : forall (p: (nat*nat)) (l1: list (nat*nat)) (l2: list nat), PairList l1 l2 -> PairList (p::l1) ((fst p + snd p)::l2).

  Theorem ex1b : forall (l1: list (nat*nat)), { l2: list nat | PairList l1 l2 }.
  Proof.
    intros.
    induction l1.
    - exists nil. apply PLnil.
    - elim IHl1. intros. exists ((fst a+snd a)::x). apply PLcons. apply p.
  Qed.

  Extraction Language Haskell.
  Recursive Extraction ex1b.
  Extraction Inline list_rect.
  Extraction Inline list_rec.
  Extraction Inline sig_rec.
  Recursive Extraction ex1b.

  Extraction "ex1b" ex1b.

(* ================================================================================== *)
(* ====================================EXERCÍCIO 2=================================== *)
(* ================================================================================== *)

(*2. Recorde a função count que conta o número de ocorrências de um inteiro numa lista de inteiros.*)
Fixpoint count (z: Z) (l: list Z) {struct l} : nat :=
  match l with
    | nil => 0%nat
    | (z' :: l') => if (Z.eq_dec z z')
                    then S (count z l')
                    else count z l'
  end.

  (*a) Prove a seguinte propriedade*)
  Theorem ex2a : forall (x: Z) (a: Z) (l: list Z), x <> a -> count x (a :: l) = count x l.
  Proof.
    intros.
    simpl.
    elim (Z.eq_dec x a).
      - easy.
      - intros. reflexivity.
  Qed.

  (*b) Defina uma relação indutiva que descreva a relação entre o input e o output para a função count, ou seja, a sua especificação.*)
  Inductive CountRelation : Z -> (list Z) -> nat -> Prop :=
    | CRnil     : forall (x: Z), CountRelation x nil 0%nat
    | CRheadEq  : forall (x: Z) (l: list Z) (n: nat), CountRelation x l n -> CountRelation x (x::l) (S n)
    | CRheadDif : forall (x y: Z) (l: list Z) (n: nat), (x <> y /\ CountRelation x l n) -> CountRelation x (y::l) n.

  (*c) Prove que a função dada acima satisfaz a especiificação apresentada na alínea anterior.*)
  Theorem ex2c : forall (x: Z) (l: list Z), CountRelation x l (count x l).
  Proof.
    intros.
    induction l.
    - simpl. apply CRnil.
    - simpl. elim (Z.eq_dec x a).
      + intros. replace a with x. apply CRheadEq. apply IHl.
      + intros. apply CRheadDif. split.
        * apply b.
        * apply IHl.
  Qed.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
(*
    You are only allowed to use these tactics:

    simpl, reflexivity, intros, rewrite, destruct, induction, apply, assert

    You are not allowed to use theorems outside this file *unless*
    explicitly recommended.
*)

(* ---------------------------------------------------------------------------*)

(**

Show that 5 equals 5.

 *)
Theorem ex1: 5 = 5.
Proof.
  simpl.
  reflexivity.
Qed.

(**

Show that equality for natural numbers is reflexive.

 *)
Theorem ex2: forall (x:nat), x = x.
Proof.
  intros x.
  reflexivity.
Qed.

(**

Show that [1 + n] equals the successor of [n].

 *)
Theorem ex3: forall n, 1 + n = S n.
Proof.
  intros n.
  reflexivity.

Qed.

(**

Show that if [x = y], then [y = x].

 *)
Theorem ex4: forall x (y:nat), x = y -> y = x.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

(**

Show that if the result of the conjunction and the disjunction equal,
then both boolean values are equal.

 *)
Theorem ex5: forall (b c : bool), (andb b c = orb b c) -> b = c.
Proof.
  intros.
  induction b.
  -assert (Th: forall (b:bool), orb true b = true). { reflexivity. }
   rewrite Th in H.
   rewrite <- H.
   reflexivity.
  -assert (th: forall (b : bool), andb false b = false). { reflexivity. }
   rewrite th in H.
   rewrite -> H.
   reflexivity.
Qed.

(**

In an addition, we can move the successor of the left-hand side to
the outer most.

 *)
Theorem ex6: forall n m, n + S m = S (n + m).
Proof.
  intros.
  induction n.
  -simpl.
   reflexivity.
  -simpl.
   rewrite <- IHn.
   reflexivity.
Qed.

(**

If two additions are equal, and the numbers to the left of each addition
are equal, then the numbers to the right of each addition must be equal.
To complete this exercise you will need to use the auxiliary
theorem: eq_add_S

 *)
Theorem ex7: forall x y n, n + x = n + y -> x = y.
Proof.
intros.
  induction n.
  - simpl in H.
    rewrite <- H.
    reflexivity.
  - simpl in H.
    apply eq_add_S in H.
    apply IHn.
    rewrite -> H.
    reflexivity.

Qed.

(**

Show that addition is commutative.
Hint: You might need to prove `x + 0 = x` and `S (y + x) = y + S x`
separately.

 *)

Theorem eqn1 x: x + 0 = x.
Proof.
  induction x.
  -reflexivity.
  -simpl.
   rewrite -> IHx.
   reflexivity.
Qed.

Theorem eqn2 x y: x + S y = S(x + y).
Proof.
  intros.
  induction x.
  -simpl.
   reflexivity.
 -simpl.
  rewrite IHx.
  reflexivity.
Qed.

Theorem ex8: forall x y, x + y = y + x.
Proof.
  intros.
  induction x.
  -rewrite eqn1.
   simpl.
   reflexivity.
  -simpl.
   rewrite IHx.
   rewrite eqn2.
   reflexivity.
Qed.

(**

If two additions are equal, and the numbers to the right of each addition
are equal, then the numbers to the left of each addition must be equal.

Hint: Do not try to prove this theorem directly. You should be using
auxiliary results. You can use Admitted theorems.

 *)
Theorem ex9: forall x y n, x + n = y + n -> x = y.
Proof.
  intros x y n eqn.
  assert (equ: forall x n, x + n = n + x). { apply ex8. }
  rewrite equ in eqn.
  assert (eqy: forall y n, y + n = n + y). { apply ex8. }
  symmetry in eqn.
  rewrite eqy in eqn.
  symmetry in eqn.
  apply ex7 in eqn.
  rewrite -> eqn.
  reflexivity.
Qed.


Require Import nat.
Require Import le.

Definition relation (a:Type) : Type := a -> a -> Prop.

Inductive clos (a:Type) (r:relation a) : relation a :=
| rt_step : forall x y, r x y -> clos a r x y
| rt_refl : forall x, clos a r x x
| rt_trans: forall x y z, clos a r x y -> clos a r y z -> clos a r x z
.

Arguments clos {a} _ _ _.

Inductive next : relation nat := nextS : forall n, next n (S n).

(* '<=' is the reflexive-transitive closure of 'next' *)

Lemma le_is_clos_next : forall (n m:nat), n <= m <-> clos next n m.
Proof.
    intros n m . split.
    - intros H. induction H as [n|n m H IH].
        + apply rt_refl.
        + apply rt_trans with (y:=m).
            { exact IH. }
            { apply rt_step, nextS. }
    - intros H. induction H as [n m H|n|n m p H1 IH1 H2 IH2].
        + inversion H. apply le_S, le_n.
        + apply le_n.
        + apply le_trans with (m:=m).
            { exact IH1. }
            { exact IH2. }
Qed.

(*  The definition of refl-trans closure not very convenient
    for doing proofs, due to the 'non-determinism' of the
    transitive rule. We are now trying a more useful definition.
*)

Inductive clos' (a:Type) (r:relation a) (x:a) : a -> Prop :=
| rt'_refl : clos' a r x x
| rt'_mix  : forall (y z:a), r x y -> clos' a r y z -> clos' a r x z
.

Arguments clos' {a} _ _ _.

(* are these two definitions equivalent *)

Lemma rt'_step : forall (a:Type) (r:relation a) (x y:a),
    r x y -> clos' r x y.
Proof.
    intros a r x y H. apply rt'_mix with (y:=y).
    - exact H.
    - apply rt'_refl.
Qed.

Lemma rt'_trans : forall (a:Type) (r:relation a) (x y z:a),
    clos' r x y -> clos' r y z -> clos' r x z.
Proof.
    intros a r x y z H. revert z. induction H as [|x y z Hxy H IH].
    - intros z H. exact H.
    - intros z' H'. apply rt'_mix with (y:=y).
        + exact Hxy.
        + apply IH. exact H'.
Qed.

Lemma clos_iff_clos' : forall (a:Type) (r: relation a) (x y:a),
    clos r x y <-> clos' r x y.
Proof.
    intros a r x y. split.
    - intros H. induction H as [x y H|x|x y z H1 IH1 H2 IH2].
        + apply rt'_step. exact H.
        + apply rt'_refl.
        + apply rt'_trans with (y:=y).
            { exact IH1. }
            { exact IH2. }
    - intros H. induction H as [x|x y z H H' IH'].
        + apply rt_refl.
        + apply rt_trans with (y:=y).
            { apply rt_step. exact H. }
            { exact IH'. }
Qed.


Module Playground1.

Inductive bool : Type :=
| true : bool
| false : bool.

Inductive nat : Type :=
| O : nat
| S : nat -> nat.

End Playground1.

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Fixpoint evenb (n : nat) : bool :=
  match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
  end.

Definition oddb (n : nat) : bool := negb (evenb n).

Definition admit {T: Type} : T.  Admitted.
(* Haskell: undefined *)

Module Playground2.

Fixpoint plus (n : nat) (m : nat) {struct n} : nat :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.

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

Fixpoint minus (n m : nat) : nat :=
  match n, m with
    | O   , _    => O
    | _   , O    => n          (* make this non-overlapping *)
    | S n', S m' => minus n' m'
  end.

End Playground2.

Theorem plus_O_n : forall n:nat, 0 + n = n.
Proof.
  intro n.
  simpl.
  reflexivity.
Qed.

(* End of seminar 1. *)

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

(* Looking up info *)

(* Require Import Arith. *)
Search nat.
SearchAbout nat.
(* SearchPattern (_ -> nat).    (* Doesn't work in older coq versions *) *)
SearchRewrite (0 + _).

(* More tactics. *)

Theorem plus_id_example : forall n m,
                            n = m -> n + n = m + m.
Proof.
  intros k l.
  intros H.
  rewrite <- H.                    (* show directions *)
  reflexivity.
Qed.

Theorem mult_O_plus : forall n m : nat,
                        (0 + n) * m = n * m.
Proof.
  intros.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

Fixpoint beq_nat (n m : nat) : bool :=
  match n, m with
    | O, O => true
    | S n', S m' => beq_nat n' m'
    | _, _ => false
  end.

Print beq_nat.

Theorem plus_1_neq_0_b : forall n : nat,
                           beq_nat (n+1) 0 = false.
Proof.
  intros.
  (* destruct n; reflexivity. *)
  destruct n.
    reflexivity.

    reflexivity.
Qed.

Axiom convenient : forall n, n+1 = S n.

Theorem plus_1_neq_0 : forall n : nat, n + 1 <> 0.
Proof.
  intros.
  (* rewrite convenient. *)
  (* discriminate. *)
  destruct n.
    discriminate.

    simpl.
    discriminate.
Qed.

Theorem eq_beq_nat : forall n m : nat,
    n = m <-> beq_nat n m = true.
Proof.
  intros.
  split.
    intro.
    rewrite H.
(* Finish from here. Hard. Good HW! :) *)
Admitted.

Theorem plus_0_r : forall n, n + 0 = n.
Proof.
  intros.
  induction n.
    reflexivity.

    simpl.
    rewrite IHn.
    reflexivity.
Qed.

Theorem minus_diag : forall n : nat, n - n = 0.
Proof.
  intros.
  induction n.
    reflexivity.

    simpl.
    assumption.
Qed.

Theorem plus_comm : forall n m, n + m = m + n.
Proof.
  intros n m.
  induction n.
    simpl.
    rewrite plus_0_r.
    reflexivity.

    simpl.
    rewrite IHn.
    assert (forall k l, k + S l = S (k + l)).
      clear IHn n m.
      intros.
      induction k.
        reflexivity.

        simpl.
        rewrite IHk.
        reflexivity.

    rewrite H.
    reflexivity.
Qed.
(* HW: do without assert, but with induction within induction. *)

(* Induction more closely *)

Fixpoint double n : nat :=
  match n with
    | O => O
    | S n' => S (S (double n'))
  end.

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n.
  induction n.
    intros.
    simpl in H.
    destruct m.
      reflexivity.

      simpl in H.
      discriminate H.

   (* induction side *)
   intros.
   destruct m.
     discriminate H.

     (* apply a hypothesis to the goal *)
     f_equal.                   (* remove the same constructor *)
     apply IHn.
     simpl in H.
     (* TODO(klao): look up how to introduce S-es to the goal. *)
     (* union of 'discriminate' and 'f_equal in hypothesis' *)
     inversion H.
     reflexivity.
Qed.
(* TODO(klao): look into: printing readable proofs. *)

(* End of Seminar 2. *)

(* ********************************************************************** *)
(* Seminar 3 starts here. *)

(* revert, generalize dependent, and induction in |- *)

Theorem plus_rearrange : forall n m p q,
    (n + m) + (p + q) = (m + n) + (q + p).
Proof.
  intros.
  rewrite plus_comm.
  rewrite plus_comm.
  Check plus_comm.

  rewrite (plus_comm n m).
  (* rewrite (plus_comm p q). *)
  (* reflexivity. *)
  replace (p + q) with (q + p).
  reflexivity.
  apply plus_comm.
Qed.

(* ************* *)
(* 'Apply' and other tactic examples *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  (* intros. *)
  (* apply H. *)
  (* exact H0. *)

  intro H.
  (* apply H. *)
  exact (H 3).
Qed.

Theorem silly3 : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.

  symmetry.
  (* simpl. *) (* Actually, this [simpl] is unnecessary, since
            [apply] will do a [simpl] step first. *)
  apply H.
Qed.

(* Reasoning in assumptions, aka forward reasoning. *)
Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5  ->
     true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  remember H as H1.
  clear HeqH1.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.
Qed.

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
    (* Hint: use the plus_n_Sm lemma *)
    intros. destruct m as [| m']. reflexivity.
    simpl in H. discriminate H.

    intros. destruct m as [| m']. discriminate H.
    simpl in H. rewrite <- !plus_n_Sm in H.  (* rewrite modifiers *)
    inversion H. apply IHn' in H1. rewrite H1. reflexivity.
Qed.

(* Remember and destruct expression. *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b.
  destruct b.
  Case "b = true".
  remember (f true) as ftrue.
    destruct ftrue.
    SCase "f true = true".
      rewrite <- Heqftrue.
      symmetry.
      apply Heqftrue.
    SCase "f true = false".
      remember (f false) as ffalse.
      destruct ffalse.
      SSCase "f false = true".
        symmetry.
        apply Heqftrue.
      SSCase "f false = false".
        symmetry.
        apply Heqffalse.
  remember (f false) as ffalse.
    destruct ffalse.
    SCase "f false = true".
      remember (f true) as ftrue.
      destruct ftrue.
      SSCase "f true = true".
        symmetry.
        apply Heqftrue.
      SSCase "f true = false".
        symmetry.
        apply Heqffalse.
    SCase "f false = false".
      rewrite <- Heqffalse.
      symmetry.
      apply Heqffalse.
Qed.

(* HW *)
Theorem bool_funcs : forall (f : bool -> bool),
  (forall b, f (f b) = f b) \/ (forall b, f b = negb b).
Admitted.

Theorem bool_fn_applied_thrice' :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intro f.
  destruct (bool_funcs f).
    intro.
    rewrite H.
    rewrite H.
    reflexivity.

    intro.
    rewrite !H.
    (* SearchAbout negb. *)
    rewrite Bool.negb_involutive.
    reflexivity.
Qed.

(* Seminar 3 ended here. *)
(* ********************************************************** *)
(* Seminar 4 starts here. *)

Module ExampleList1.

Inductive list (T : Type) : Type :=
  | nil
  | cons : T -> list T -> list T.

Check (cons nat 2 (cons nat 1 (nil nat))).

Check (cons _ 2 (cons _ 1 (nil _))).

Check cons.
Check nil.

End ExampleList1.

Module ExampleList2.

Set Implicit Arguments.

Inductive list (T : Type) : Type :=
  | nil
  | cons : T -> list T -> list T.

Check (cons 2 (cons 1 (nil _))).

Implicit Arguments nil [[T]].
(* Deprecated, use: Arguments nil [T]. *)

Check (cons 2 (cons 1 nil)).

Unset Implicit Arguments.

Fixpoint length {X:Type} (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length t)
  end.

Eval compute in length (cons 2 (cons 1 nil)).

Check @length.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).

(* Define app! *)
Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
    | [] => l2
    | h :: t => h :: app t l2
  end.

Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Eval compute in [1,2,3] ++ 4::5::[].

Fixpoint repeat {X : Type} (x : X) (count : nat) : list X :=
  match count with
    | O => nil
    | S c' => x :: repeat x c'
  end.

Eval compute in repeat true 3.

Theorem repeat_length : forall n X (x : X), length (repeat x n) = n.
Admitted.

(* Induction priciple for induction definition. *)

Check nat_ind.
Check list_ind.

Theorem app_assoc : forall X (l1 l2 l3 : list X), l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
Admitted.

(* HW: trivial *)
Theorem app_length : forall X (l1 l2 : list X), length (l1 ++ l2) = length l1 + length l2.
Admitted.

(* HW: involved. What should the induction go on? *)
Theorem app_length2 : forall X (l1 l2 : list X) n1 n2,
     length l1 = n1 -> length l2 = n2 -> length (l1 ++ l2) = n1 + n2.
Admitted.

Inductive vector (T : Type) : nat -> Type :=
  | nilv : vector T 0
  | consv n : T -> vector T n -> vector T (S n).

Implicit Arguments nilv [[T]].
Implicit Arguments consv [[T] [n]].

Check consv 1 (consv 2 nilv).

Fixpoint lengthv {T : Type} {n : nat} (v : vector T n) : nat := admit.

Fixpoint repeatv {X : Type} (x : X) (n : nat) : vector X n :=
  match n with
    | 0 => nilv
    | S n' => consv x (repeatv x n')
  end.

Theorem lengthv_repeatv : forall n X (x : X), lengthv (repeatv x n) = n.
Proof.
Admitted.
(* Show that simpl is not enough here, but compute is, or unfold. *)

Notation "[[ x , .. , y ]]" := (consv x .. (consv y nilv) ..).

(* Skip here to talk about Curry-Howard *)

Check [1,2,3].
Check [[ 1 , 2 , 3 ]].

Compute repeat true 3.
Compute repeatv true 3.

Check @repeat bool.
(* bool -> nat -> list bool *)
Check @repeatv bool.
(* bool -> forall n : nat, vector bool n *)
(* Wrong: bool -> nat -> vector bool nat *)

Check vector.

Definition repeatv2 : bool -> vector bool 2 :=
  fun b => repeatv b 2.
Check fun b : bool => repeatv b 2.

Check repeatv true.

(* Relation of 'forall' and '->' *)

Check forall n : nat, list bool.

End ExampleList2.

Module ExamplesC_H.

Parameter A B : Prop.

Print A.

Definition A_to_B := forall h : A, B.

Print A_to_B.

(* h : A, "means" h is a proof of A *)
(* At this point we had an exposition about Curry-Howard isomorphism. *)
(* Look into Seminar4_Curry_Howard.hs for a Haskell side track. *)

Check forall n : nat, bool.

Check forall n : nat, A.

Theorem A_to_B_to_A : A -> B -> A.
Proof.
  intros.
  assumption.
  Show Proof.
Qed.

Definition P_to_Q_to_P : forall P Q : Prop, P -> Q -> P := fun _ _ x _ => x.

Check P_to_Q_to_P.

Theorem whatever : B -> A -> B.
Proof.
  apply P_to_Q_to_P.
Qed.

Check A_to_B.                   (* = A -> B *)
Check A_to_B_to_A.              (* : A -> B -> A *)

(* two_times_n_plus_3 *)

Theorem two_times_n_plus_3 : nat -> nat.
Proof.
  intros n.
  induction n.
    exact 3.

    exact (S (S IHn)).

(* Qed. ---> makes the proof term 'opaque'. *)
Defined.

Compute two_times_n_plus_3 2.
Compute two_times_n_plus_3.

(* P -> True *)

Theorem P_to_True : forall P : Prop, P -> True.
Proof.
  intros.
  trivial.
Qed.

Print True.
(* haskell: data True = I *)

Definition P_to_True' : forall P : Prop, P -> True :=
  fun _ _ => I.
Check P_to_True'.

Definition P_to_True'' (P : Prop) (H : P) : True :=
  I.
Check P_to_True''.

(* False -> P *)

Theorem False_to_P : forall P : Prop, False -> P.
Proof.
  intros.
  (* induction H. also works! *)
  contradiction.
  Show Proof.
  Print False_ind.
  Print False_rect.
Qed.

Print False.

(* Definition False_to_P' : forall P : Prop, False -> P := *)
Definition False_to_P' (P : Prop) (H : False) : P :=
  match H with
  end.

Print False_to_P'.

(* HW: 1 <> 0.  Hard! *)
(* Unset Printing Notations. *)
Check 0 <> 1.

(* Seminar 4 ends here *)
(*****************************************************************************)

(* Logical connectives and evidence *)

(* We already know the connection between the imlication and forall,
   and functions and functions with generalized product type *)

(* And, Or, Iff *)

Theorem a_and_b_to_a'n'b : A -> B -> A /\ B.
Proof.
  intros.
  split ; assumption.
  Show Proof.
Qed.

Locate "_ /\ _".
Locate "_ * _".
Definition and' (A : Prop) (B : Prop) :=  prod A B.

Inductive and'' (A : Prop) (B : Prop) : Prop :=
  es (_ : A) (_ : B).
Print and''.

Print and.
Check conj.

Theorem a_and_b_to_a'n'b2 : A -> B -> A /\ B.
Proof.
  apply conj.
  Show Proof.
Qed.

Theorem a_and_b_to_a'n'b3 : A -> B -> A /\ B.
Proof  (fun a => fun b => conj a b).

(* Reminder for lambda expressions. *)
Check (fun x => x+1).

Locate "_ \/ _".
Print or.
Check or_introl.

Theorem a_to_a'or'b : A -> A \/ B.
Proof (fun a => or_introl _ a).
(* @or_introl A B a *)
(* Proof. *)
(*   intros. *)
(*   left. *)
(*   assumption. *)
(* Qed. *)

Theorem b'or'a_to_a'or'b : B \/ A -> A \/ B.
Proof (fun ba => match ba with
                   | or_introl x => or_intror _ x
                   | or_intror y => or_introl _ y
                 end).
Print or_introl.
Check or_introl.
(* Work it out. *)

(* How about not? *)
(* Classical vs. Intuitionistic logic *)

Locate "~ _".
Print not.

Theorem a_to_notnota : A -> ~~A.
(* Proof (fun x y => y x). *)
Proof.
  intros.
  unfold "~".
  intros.
  apply H0.
  assumption.
Qed.

(* Can we also prove this? *)
Theorem notnota_to_a : ~~A -> A. Admitted.

(* Seminar 5 ended here. *)
(* ************************************************************ *)

Definition LEM := forall p, p \/ ~p.
Print LEM.

Definition Peirce := forall (a b : Prop), ((a -> b) -> a) -> a.
Print Peirce.

(* We will prove that LEM <-> Peirce. But what is it? As a function? *)

(* Equality and non-equality. Or, where in hell is the assumption that
   1 <> 0 is buried in Coq? *)

Theorem true_neq_false : true <> false. Admitted.

(* Frobenius rule *)

Theorem Frobenius (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).
Proof.
Admitted.

Theorem dual_Frobenius (A : Set) p q :
  (forall x : A, q \/ p x) <-> (q \/ forall x : A, p x).
Proof.
Admitted.

(* Other inductive predicates. *)

End ExamplesC_H.


Inductive nat : Type :=
| O : nat
| S : nat -> nat.

Definition pred (n : nat) : nat :=
match n with
| O => O
| S n' => n'
end.

Definition succ (n:nat) :nat :=
match n with
| O => (S O)
| S n' => S (S n')
end.

Definition minustwo (n: nat) : nat :=
match n with
| O => O
| S O => O
| S (S n') => n'
end.

Fixpoint evenb (n:nat) : bool :=
match n with
| O => true
| S O => false
| S n' => negb (evenb n')
end.

Definition oddb (n:nat) : bool := negb (evenb n).

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

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

Fixpoint minus (n m : nat) : nat :=
match n, m with
| O, _ => O
| S n', O => n
| S n, S m => minus n m
end.

Fixpoint exp (base power :nat) : nat :=
match power with
| O => S O
| S n => mult base (exp base n)
end.

Fixpoint factorial (n:nat) : nat :=
match n with
| O => S O
| S O => S O
| S n' => mult n (factorial n')
end.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.

Notation "x - y" := (minus x y)
                        (at level 50,left associativity)
                        : nat_scope.

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

Fixpoint beq_nat (n m : nat) : bool :=
match n with
| O => match m with
  | O => true
  | S m' => false
end
| S n' => match m with
  | O => false
  | S m' => (beq_nat n' m')
end
end.

Fixpoint blt_nat (n m : nat) : bool :=
match n with
| O => match m with
  | O => false
  | S _ => true
end
| S n' => match m with
  | O => false
  | S m' => blt_nat n' m'
end
end.

Inductive bin : Type :=
| Z : bin
| T : bin -> bin
| T' : bin -> bin.

Fixpoint incr (n : bin) : bin :=
match n with
| Z => T' Z
| T n' => T' n'
| T' n' => T (incr n')
end.

Fixpoint bin_pred (n: bin) : bin :=
match n with
| Z => Z
| T Z => Z
| T' Z => Z
| T' n' => T n'
| T n' => T' (bin_pred n')
end.

Fixpoint bin_to_nat (n: bin) : nat :=
match n with
| Z => O
| T' n' => succ (bin_to_nat (T n'))
| T n' => succ (bin_to_nat (T' (bin_pred n')))
end.


(***********************************************************************)
(** * Definition of Finite numbers *)
(***********************************************************************)

(* Bound variables are represented using the 'fin' datatype shown below.

   Elements of fin n can be seen as natural numbers in the set {m | m < n}.

   The key idea is the index of this type says how many elements the type
   has. For example, the type [fin 0] is an empty type, the type [fin 1] only
   has a single value [fO], the type [fin 2] has two values ([fO] and [fS
   fO]), etc.

   Some definitions in this library are from equations example
   https://github.com/mattam82/Coq-Equations/blob/master/examples/Fin.v

   There is a lot more we can do with [fin], but this is enough for
   STLC (and we don't need all of it).

*)

(* ----------- imports --------------- *)
Require Import Program.Basics Program.Combinators.
From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Nat.
Require Import Lia.

Inductive fin : nat -> Set :=
  | fO : forall {n}, fin (S n)
  | fS : forall {n}, fin n -> fin (S n).

Derive Signature NoConfusionHom NoConfusion for fin.

(* decidable equality is derivable *)
Derive EqDec for fin.

(* ------- type coercions ------ *)

(* Coerce [m] to a smaller range, as long as it is not k.
   does not change the "value" of [m]. *)
(* NB: used in "open" *)
Equations decrease_fin (k : nat) (m : fin (S k)) : option (fin k) :=
  decrease_fin O _ := None ;
  decrease_fin (S _) fO := Some fO;
  decrease_fin (S m) (fS n) := option_map fS (decrease_fin m n).

(* Coerce [m] to a larger range, without changing its value. *)
(* NB: used in "close" operation. *)
Equations increase_fin {n : nat} (m : fin n) : fin (S n) :=
  increase_fin fO  := fO;
  increase_fin (fS m) := fS (increase_fin m).

(* -------- isomorphism with {m : nat | m < n} ------- *)

(* Coerce between [fin] and [nat], preserving value.

    f0 <-> O
    fS f0 <-> S O
    fS (fS f0) <-> S (S O)
*)

(* We can inject [fin n] into [nat]. Forget the rich type. *)
Equations fog {n} (f : fin n) : nat :=
  fog fO     := 0 ;
  fog (fS f) := S (fog f).

Print fog_graph.

(* And come back again. Note: we produce a [fin] with the
   smallest possible range. *)
Equations gof (n : nat) : fin (S n) :=
  gof O := fO ;
  gof (S n) := fS (gof n).

Print fog.
Print gof.

(* ------- properties of definitions above ------- *)

Lemma fog_gof (n : nat) : fog (gof n) = n.
Proof with auto with arith.
  intros. funelim (gof n). info_auto.
  simp fog. congruence.
Qed.

Lemma fog_inj {n} (f : fin n) : fog f < n.
Proof with auto with arith.
  intros.
  funelim (fog f); simp fog...
(*  induction f; simp fog...
  dependent induction f; simp fog...
  depind f; simp fog... *)
Qed.

Require Import Coq.Logic.EqdepFacts.

(* increase_fin is injective *)
Lemma increase_fin_inj : forall {n} (f f0 : fin n),
    (increase_fin f = increase_fin f0) -> f = f0.
Proof.
  intros n f g.
  funelim (increase_fin f).
  all: dependent elimination g; simp increase_fin.
  auto.
  intros h. inversion h.
  intros h. inversion h.
  intros h.
  noconf h. f_equal. auto.   (* no axiom *)
  (* These two proofs work, but need an axiom *)
(*  inversion h. dependent destruction H1. f_equal. auto. *)
(*  inversion h. apply Eqdep.EqdepTheory.inj_pair2 in H1.
  f_equal. auto. *)
Qed.

Print Assumptions increase_fin_inj.

(* decrease fin is injective *)
Lemma decrease_fin_inj : forall {n} (f f0 : fin (S n)),
    (decrease_fin n f = decrease_fin n f0) -> f = f0.
Proof.
  intros.
  dependent induction n;
  dependent elimination f;
  dependent elimination f0; auto.
  all: try solve [dependent elimination f].
  all: try simp decrease_fin in H.
  all: destruct (decrease_fin n f) eqn: E1.
  all: try destruct (decrease_fin n f0) eqn: E2.
  all: simpl in H.
  all: try discriminate.
  all: noconf H.
  all: rewrite <- E2 in E1.
  all: eapply IHn in E1.
  all: f_equal; auto.
Qed.

(* increase always produces a number less than the max. *)
Lemma increase_not_n : forall {n}(f : fin n),
         not (gof n = increase_fin f).
Proof.
  intros.
  dependent induction n;
  dependent elimination f;
  simp gof; simp increase_fin.
  intros h. noconf h.
  intros h. noconf h. eapply IHn. eauto.
Qed.

(* If we can decrease a fin, then increasing it gives us the same number. *)
Lemma decrease_increase_fin :
  forall {n1} (f0 : fin n1) (f : fin (S n1)),
    decrease_fin n1 f = Some f0 -> increase_fin f0 = f.
Proof.
  intros.
  dependent induction f.
  destruct n1. inversion f0. simp decrease_fin in H.
  inversion H. simp increase_fin. auto.
  destruct n1. inversion f0. simp decrease_fin in H.
  destruct (decrease_fin n1 f) eqn:E1. simpl in H. inversion H.
  eapply IHf in E1; eauto. simp increase_fin. f_equal. auto.
  simpl in H. discriminate.
Qed.

(* If we cannot decrease a fin, then we must have started with the maximum value. *)
Lemma decrease_to_fin :
  forall {n1} (f: fin (S n1)), decrease_fin n1 f = None -> gof n1 = f.
Proof.
  intros.
  dependent induction f.
  destruct n1; simp decrease_fin in H; simp gof. auto. discriminate.
  destruct n1; simp decrease_fin in H; simp gof.
  inversion f.
  destruct (decrease_fin n1 f) eqn:E1. simpl in H. inversion H.
  eapply IHf in E1; eauto. f_equal. auto.
Qed.

(* If we had increased first, we can decrease *)
Lemma decrease_fin_increase_fin :
  forall n1 (f : fin n1), decrease_fin n1 (increase_fin f) = Some f.
Proof.
  intros.
  dependent induction f.
  all: simp increase_fin.
  all: simp decrease_fin.
  all: auto.
  rewrite IHf.
  reflexivity.
Qed.

(* Since gof gives us the largest number in the range, we cannot decrease it. *)
Lemma decrease_fin_gof : forall n, decrease_fin n (gof n) = None.
Proof.
  induction n.
  all: simp gof.
  all: simp decrease_fin.
  auto. rewrite IHn.
  reflexivity.
Qed.

Create HintDb fin.
#[export] Hint Rewrite fog_gof : fin.
#[export] Hint Rewrite decrease_fin_increase_fin : fin.
#[export] Hint Rewrite decrease_fin_gof : fin.
#[export] Hint Resolve decrease_to_fin : fin.
#[export] Hint Resolve decrease_increase_fin : fin.
#[export] Hint Resolve increase_not_n : fin.

#[export] Hint Extern 1 (_ = _) => match goal with
 | [ H : increase_fin _ = increase_fin _ |- _ ] => apply increase_fin_inj end : fin.

#[export] Hint Extern 1 (_ = _) => match goal with
 | [ H : gof _ = increase_fin _ |- _ ] => exfalso; eapply increase_not_n end : fin.

(*

Inductive le : nat -> nat -> Type :=
| le_O n : 0 <= n
| le_S {n m} : n <= m -> S n <= S m
where "n <= m" := (le n m).
Derive Signature for le.
Hint Constructors le.
Equations le_S_inv {n m} (p : S n <= S m) : n <= m :=
le_S_inv (le_S p) := p.

Equations fin_inj {n} {m} (f : fin n) (k : n <= m) : fin m :=
fin_inj fO (le_S p) := fO;
fin_inj (fS f) (le_S p) := fS (fin_inj f p).

Lemma foo : forall m n, m <= S (n + m). Admitted.

Equations fin_plus {n m} (x : fin n) (y : fin m) : fin (n + m) :=
fin_plus (@fO n) f := fin_inj f _ ;
fin_plus (@fS n x) y := fS (fin_plus x y).
Next Obligation. apply foo. Defined.

Print fin_plus.
Print fin_plus_obligations_obligation_1.
(** Won't pass the guardness check which diverges anyway. *)
*)


Module Playground1.

Inductive bool : Type :=
| true : bool
| false : bool.

Check true.
Check bool.

Check True.
Check (forall x : bool, x=x).

Inductive nat : Type :=
| O : nat
| S : nat -> nat.

(* comment *)

(* Haskell: data Nat = O | S Nat *)

Check (S (S (S O))).

End Playground1.

Print Playground1.

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Check (S (S (S O))).
Eval simpl in (minustwo 4).

Check minustwo.
Check S.
Check pred.

Fixpoint evenb (n : nat) : bool :=
  match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
  end.

Print evenb.

Definition oddb (n : nat) : bool := negb (evenb n).

Example test_oddb1 : oddb (S O) = true.
Proof. unfold oddb. (* unfold evenb. *) simpl. reflexivity. Qed.

Example test_oddb2 : oddb 4 = false.
Proof. reflexivity. Qed.

Module Playground2.

Definition admit {T: Type} : T.  Admitted.

(* Haskell: undefined *)

Fixpoint plus (n : nat) (m : nat) {struct n} : nat :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.

(* Comment about struct *)

Theorem three_plus_two : plus 3 2 = 5.
Proof. reflexivity. Qed.

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

Fixpoint minus (n m : nat) : nat :=
  match n, m with
    | O   , _    => O
    | _   , O    => n          (* make this non-overlapping *)
    | S n', S m' => minus n' m'
  end.

Print minus.

End Playground2.

Print minus.

Example test_mult1 : (mult 3 4) <> 9.
Proof. simpl. discriminate. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

Check ((0 + 1) + 1).

Theorem plus_O_n : forall n:nat, 0 + n = n.
Proof.
  intro n.
  simpl.
  reflexivity.
Qed.

(* Explain the difference: *)
Eval simpl in (forall n:nat, 0 + n = n).

Eval simpl in (forall n:nat, n + 0 = n).

(* End of first seminar. *)