(* Sheffer 1913 states that any of the logical connectives
  for Boolean algebra can be implemented with the other using not and the logical connective.*)

Require Import Bool.

Example andb_orb : forall a b : bool,
  (* a ∧ b = ¬(¬a∨¬b) *)
  andb a b = negb(orb (negb a) (negb b)).
Proof.
  intros a b.
  destruct a.
  - simpl. rewrite -> negb_involutive. reflexivity.
  - auto.
Qed.

Search (negb (negb _)).

Example andb_implb : forall a b : bool,
  (* a ∧ b = ¬(a⇒¬b) *)
  andb a b = negb (implb a (negb b)).
Proof.
  intros a b.
  destruct a.
  - simpl. rewrite -> negb_involutive. reflexivity.
  - auto.
Qed.

Example orb_andb : forall a b: bool,
  (* a ∨ b	= ¬(¬a∧¬b) *)
  orb a b = negb (andb (negb a) (negb b)).
Proof.
  intros a b.
  destruct a.
  destruct b.
  - auto.
  - auto.
  - simpl. rewrite -> negb_involutive. reflexivity.
Qed.

Example orb_implb : forall a b: bool,
  (* a ∨ b = ¬a⇒b *)
  orb a b = implb (negb a) b.
Proof.
  intros a b.
  destruct a.
  - auto.
  - auto.
Qed.

Example implb_andb : forall a b: bool,
  (* a ⇒ b	¬(a∧¬b) *)
  implb a b = negb(andb a (negb b)).
Proof.
  intros a b.
  unfold implb.
  destruct a.
  - destruct b. auto. auto.
  - auto.
Qed.

Example implb_orb : forall a b : bool,
  (* a ⇒ b = ¬a∨b *)
  implb a b = orb (negb a) b.
Proof.
  intros a b.
  unfold implb.
  destruct a.
  - destruct b. auto. auto.
  - auto.
Qed.

Definition nandb (a: bool) (b: bool) : bool:=
  negb (andb a b).

Example nandb_tt : nandb true  true   = false. auto. Qed.
Example nandb_tf : nandb false true   = true. auto. Qed.
Example nandb_ft : nandb true  false  = true. auto. Qed.
Example nandb_ff : nandb false false  = true. auto. Qed.

Example xorb_andb : forall a b : bool,
(* (a ⊕ b) = ¬(¬(a ∧ ¬b) ∧ ¬(¬a ∧ b)) *)
  xorb a b = negb(andb (negb (andb a (negb b)))
                       (negb (andb (negb a) b))).
Proof.
  intros a b.
  unfold negb, xorb.
  destruct a.
  - destruct b. auto. auto.
  - destruct b. auto. auto.
Qed.

Example xorb_orb : forall a b : bool,
(* (a ⊕ b) = ¬(¬(¬a ∨ ¬b)∨ ¬(a∨b)) *)
  xorb a b = negb(orb (negb (orb (negb a) (negb b)))
                      (negb (orb a b))).
Proof.
  intros a b.
  unfold negb, xorb.
  destruct a.
  - destruct b. auto. auto.
  - destruct b. auto. auto.
Qed.

Example xorb_implb : forall a b : bool,
(* (a ⊕ b) = ¬((a ⇒ ¬b) ⇒ ¬(¬a ⇒ b)) *)
  xorb a b = negb ( implb (implb a (negb b))
                          (negb (implb (negb a) (b)))).
Proof.
  intros a b.
  unfold negb, implb, xorb.
  destruct a.
  - destruct b. auto. auto.
  - destruct b. auto. auto.
Qed.

Example nandb_negb : forall b : bool,
(* ¬b = b | b *)
  negb b = nandb b b.
Proof.
  unfold negb.
  destruct b.
  auto. auto.
Qed.

Example nandb_andb : forall a b : bool,
(* a ∧ b = (a | b) | (a | b) *)
  andb a b = nandb (nandb a b) (nandb a b).
Proof.
  intros a b.
  unfold nandb, andb, negb.
  destruct a.
  - destruct b. auto. auto.
  - auto.
Qed.

Example nandb_orb : forall a b : bool,
(* a ∨ b = (a | a) | (b | b) *)
  orb a b = nandb (nandb a a) (nandb b b).
Proof.
  intros a b.
  unfold nandb, andb, negb, orb.
  destruct a.
  - auto.
  - destruct b. auto. auto.
Qed.

Example nandb_implb1 : forall a b : bool,
(* a ⇒ b = (a | (b | b)) *)
  implb a b = nandb a (nandb b b).
Proof.
  intros a b.
  unfold nandb, implb, negb.
  destruct a.
  - destruct b. auto. auto.
  - auto.
Qed.

Example nandb_implb2 : forall a b : bool,
(* a ⇒ b = (a | (a | b)) *)
  implb a b = nandb a (nandb a b).
Proof.
  intros a b.
  unfold nandb, implb, negb.
  destruct a.
  - destruct b. auto. auto.
  - auto.
Qed.

Example nandb_eqb : forall a b : bool,
(*a <-> b = ((a | b) | ((a | a) | (b | b))) *)
  eqb a b = nandb (nandb a b) (nandb (nandb a a) (nandb b b)).
Proof.
  intros a b.
  unfold eqb, nandb, negb, andb.
  destruct a.
  - destruct b. auto. auto.
  - destruct b. auto. auto.
Qed.

Require Import ExtrHaskellBasic.
Extraction Language Haskell.
Extraction "nandeqb.hs" nandb_eqb.

(* TODO write the props in set. https://stackoverflow.com/questions/27175971/generating-haskell-code-from-coq-logical-or-arity-value-used#comment42848956_27176986*)
Require Import ExtrHaskellBasic.


(** * Indução em Coq *)

Require Export aula03_provas.

(* ############################################### *)
(** * Prova por indução *)

(** Nem sempre é possível provar somente por:
    - simplificação
    - reescrita
    - análise de casos *)

(** Na aula passada, vimos o seguinte teorema *)

Print plus_O_n.

(** E se quisermos provar n + 0 = n? *)

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.
Proof.
  intros n.
  simpl. (* não simplifica nada *)
  try reflexivity.
(** [reflexivity] não funciona, pois [n]
    em [n + 0] é um número arbitrário e
    não caso padrão com o [+] *)
  Print NatPlayground2.plus.
Abort.

(** Análise de casos também não ajuda. *)

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    reflexivity. (* quando [n] é 0, funciona *)
  - (* n = S n' *)
    simpl.       (* aqui [n] é [S n'],
                  outro número arbitrário *)
Abort.

(** Chamadas sucessivas a [destruct n']
    também não ajudaria. Precisamos de indução. *)

Theorem plus_n_O : forall n:nat, n = n + 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite <- IHn'.
                   reflexivity.
Qed.

(** Outro exemplo. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.
Qed.

(** Nota: [induction] move automaticamente
    variáveis quantificadas para o contexto. *)

(** **** Exercise: (basic_induction)  *)
(** Prove os seguintes teoremas. Será necessário
    buscar por resultados previamente provados. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  induction n as [|n' IH].
  - reflexivity.
  - Print Nat.mul. simpl. rewrite -> IH. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m. induction n as [|n' IH].
  - simpl. reflexivity.
  - simpl. rewrite <- IH. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n as [| n' IH].
  - simpl. rewrite <- plus_n_O. reflexivity.
  - simpl. rewrite -> IH. rewrite plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros. induction n as [|n' IH].
  - simpl. reflexivity.
  - simpl. rewrite <- IH. reflexivity.
Qed.

(* ############################################### *)
(** * Provas aninhadas *)

(** É possivel/aconselhável quebrar provas maiores
    em subprovas. Isto pode ser feito a partir de
    [Lemma], como também a partir de "sub-teoremas". *)

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

(** Outro exemplo: veja que a tática [rewrite]
    não é muito "inteligente" sobre onde aplicar
    a reescrita no objetivo. *)

Theorem plus_rearrange_firsttry :
  forall n m p q : nat,
    (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* Só queremos trocar (n + m) por (m + n). *)
  rewrite -> plus_comm.
  (* Mas  reescrita não faz o que queremos. *)
Abort.

(** Veja a próxima prova. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.
Qed.

(* ############################################### *)
(** * Mais exercícios *)

(** **** Exercise: (mult_comm)  *)
(** Use [assert] para ajudar na prova. Não é
    necessário usar indução. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros. rewrite plus_assoc.
  assert (H: n + m = m + n).
  {
    rewrite plus_comm. reflexivity.
  }
  rewrite -> H. rewrite plus_assoc.
  reflexivity.
Qed.

(** Agora, prove comutatividade da multiplicação.
    Talvez seja necessário provar um teorema auxiliar.
    O teorema [plus_swap] será útil. *)

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros. induction m as [|m' IH].
  - simpl. Search (_ * 0). rewrite <- mult_n_O.
    reflexivity.
  - simpl. Print Nat.mul. Search (_ * _). rewrite <- mult_n_Sm.
    rewrite plus_comm. rewrite -> IH. reflexivity.
Qed.

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Induction
  https://softwarefoundations.cis.upenn.edu/lf-current/Induction.html
*)


Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.
Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

(* As with numbers, simple facts about list-processing functions can sometimes be proved entirely by simplification. For example, just the simplification performed by reflexivity is enough for this theorem... *)

Theorem nil_app : forall l : natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

(* Also, as with numbers, it is sometimes helpful to perform case analysis on the possible shapes (empty or non-empty) of an unknown list. *)

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
    reflexivity. Qed.

(* Notice that the as annotation on the destruct tactic here introduces two names, n and l', corresponding to the fact that the cons constructor for lists takes two arguments (the head and tail of the list it is constructing). *)
(* Usually, though, interesting theorems about lists require induction for their proofs. We'll see how to do this next. *)

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
  Qed.

(* reversing a list *)

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.

(* For something a bit more challenging than the proofs we've seen so far, let's prove that reversing a list does not change its length. Our first attempt gets stuck in the successor case... *)

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = n :: l' *)
    (* This is the tricky case.  Let's begin as usual
       by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality
       involving ++, but we don't have any useful equations
       in either the immediate context or in the global
       environment!  We can make a little progress by using
       the IH to rewrite the goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Abort.

(* So let's take the equation relating ++ and length that would have enabled us to make progress at the point where we got stuck and state it as a separate lemma. *)

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite -> IHl1'. reflexivity. Qed.

(* also be needing this *)
Theorem add_comm : forall n m : nat,
  n + m = m + n.
Proof. Admitted.

(* Now we can complete the original proof. *)
Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons *)
    simpl. rewrite -> app_length.
    simpl. rewrite -> IHl'. rewrite add_comm.
    reflexivity.
Qed.

(* Search *)
(* We've seen that proofs can make use of other theorems we've already proved, e.g., using rewrite. But in order to refer to a theorem, we need to know its name! Indeed, it is often hard even to remember what theorems have been proven, much less what they are called.
Coq's Search command is quite helpful with this. Let's say you've forgotten the name of a theorem about rev. The command Search rev will cause Coq to display a list of all theorems involving rev. *)
Search rev.

(* Or say you've forgotten the name of the theorem showing that plus is commutative. You can use a pattern to search for all theorems involving the equality of two additions *)
Search (_ + _ = _ + _).

(* You'll see a lot of results there, nearly all of them from the standard library. To restrict the results, you can search inside a particular module: *)
(* Search (_ + _ = _ + _) inside Induction. *)

(* You can also make the search more precise by using variables in the search pattern instead of wildcards: *)
Search (?x + ?y = ?y + ?x).


(*
This defines the exp function by recursion on peano naturals. The "Fixpoint" keyword
is required for recursive definitions (instead of "Definition"), and the recursive
calls must make one argument structurally smaller in order for termination to be
automatically verified (which is needed for logical soundness).
*)
Fixpoint exp (b e : nat) : nat :=
    match e with
    | 0 => 1
    | S e' => b * exp b e'
    end.

(*
These are two scripts for "Ltac", Coq's proof automation language, that are
enough to prove anything that's provable by a combination of 1 step of beta
reduction and induction. This includes most properties of addition, and some
properties of multiplication. Hooks for more complex logic are provided by the
first script, which shortens some later proofs. The "[ a | b ]; c" syntax is used
to run a in the first case (of a proof by cases/induction), b in the second case,
and c afterwards.
*)
Ltac simple_nat_induction n c1 c2 := intros; induction n as [ | n IHn ]; simpl; [ c1 | rewrite IHn; c2 ]; reflexivity.
Ltac simple_nat_induction' n := simple_nat_induction n idtac idtac.

(* Right reduction properties for plus (the standard library defines it left-recursively) *)
Theorem plus_rightzero : forall n, n + 0 = n. simple_nat_induction' n. Qed.
Theorem plus_rightsucc : forall n m, n + (S m) = S (n + m). simple_nat_induction' n. Qed.

(* Associativity/commutativity for plus are fairly routine; "ltac:(...)" is used to pass ltac script fragments as arguments *)
Theorem plus_associative : forall x y z, (x + y) + z = x + (y + z). simple_nat_induction' x. Qed.
Theorem plus_commutative : forall n m, n + m = m + n. simple_nat_induction n ltac:(rewrite plus_rightzero) ltac:(rewrite plus_rightsucc). Qed.

(* Right reduction properties for mult (the standard library defines it left-recursively) *)
Theorem mult_rightzero : forall n, n * 0 = 0. simple_nat_induction' n. Qed.
Theorem mult_rightsucc : forall n m, n * (S m) = (n * m) + n. simple_nat_induction n idtac ltac:(rewrite plus_rightsucc, plus_associative). Qed.

(*
The proof of associativity of multiplication is more involved than the
corresponding proof for addition, and requires the distributivity of
multiplication as a lemma. The distributivity proofs basically involve
shuffling terms around with addition's properties in the inductive step.
*)
Theorem mult_leftdist : forall x y z, x * (y + z) = x * y + x * z.
    intros; induction x.
    - reflexivity.
    - simpl. rewrite IHx.
        rewrite (plus_associative y (x * y) (z + x * z)).
        rewrite <- (plus_associative (x * y) z (x * z)).
        rewrite (plus_commutative (x * y) z).
        (* "repeat rewrite" is used here to turn the expression tree back into a linked
        list after the rewrites have been done (association can be thought of as tree
        rotation, and commutation as swapping left and right subtrees *)
        repeat rewrite <- plus_associative.
        reflexivity.
    Qed.
(* in the right-distributive case, "repeat rewrite" is used to apply right reductions until they no longer apply *)
Theorem mult_rightdist : forall x y z, (x + y) * z = x * z + y * z.
    intros; induction z.
    - repeat rewrite mult_rightzero. reflexivity.
    - repeat rewrite mult_rightsucc. rewrite IHz.
        rewrite (plus_commutative (y * z) y).
        rewrite (plus_associative (x * z) x (y + y * z)).
        rewrite <- (plus_associative x y (y * z)).
        rewrite (plus_commutative (x + y) (y * z)).
        rewrite plus_associative.
        reflexivity.
    Qed.

(* Associativity/commutativity for mult are straightforward once the above lemmas have been proven *)
Theorem mult_associative : forall x y z, (x * y) * z = x * (y * z).
    intros; induction x; [| simpl; rewrite mult_rightdist, IHx ]; reflexivity.
    Qed.

Theorem mult_commutative : forall n m, n * m = m * n.
    intros n m; induction n; simpl;
        [ rewrite mult_rightzero
        | rewrite mult_rightsucc, (plus_commutative m (n * m)), IHn
    ]; reflexivity.
    Qed.

(*
The original goal of part 1 (that exponentiation distributes over multiplication)
involves term rewriting using multiplication's associativity / commutatitivity,
which all of the above was building up to. The first one was written purely
interactively, the second one was written with the benefit of hindsight and
includes the intermediate contexts to make the rewrites visible in the source.
*)
Theorem exp_dist : forall n x y, exp (x*y) n = exp x n * exp y n.
    intros n x y. induction n.
    - reflexivity.
    - simpl.
        rewrite (mult_associative x (exp x n) (y * exp y n)).
        rewrite <- (mult_associative (exp x n) y (exp y n)).
        rewrite (mult_commutative (exp x n) y).
        rewrite IHn.
        repeat rewrite mult_associative.
        reflexivity.
    Qed.

Theorem exp_dist' : forall n x y, exp (x*y) n = exp x n * exp y n.
    intros n x y. induction n as [| n IHn].
    - reflexivity.
    - simpl. repeat match goal with
    | |- (x * y) * exp (x * y) n = (x * exp x n) * (y * exp y n) => rewrite (mult_associative x (exp x n) (y * exp y n))
    | |- (x * y) * exp (x * y) n = x * (exp x n * (y * exp y n)) => rewrite <- (mult_associative (exp x n) y (exp y n))
    | |- (x * y) * exp (x * y) n = x * ((exp x n * y) * exp y n) => rewrite (mult_commutative (exp x n) y)
    | |- (x * y) * exp (x * y) n = x * ((y * exp x n) * exp y n) => rewrite IHn
    | |- (x * y) * (exp x n * exp y n) = x * ((y * exp x n) * exp y n) => repeat rewrite mult_associative
    end. reflexivity.
    Qed.

(*
The third proof of distributivity (exp_dist'') makes use of Coq's library for
reasoning about algebraic [semi-]rings. It handles associative/commutative
rewrites by abstracting terms into variables in a polynomial and putting the
polynomial into canonical form. This results in an extremely short/robust
proof. The bulk of the work of proving that Peano naturals form a semiring is
{associativity,commutativity} of {addition,multiplication}; the remainder is
straightforward reductions involving 0/1.
*)

Require Export Ring.
Definition nat_semiring : Ring_theory.semi_ring_theory 0 1 plus mult eq := {|
    SRadd_0_l := fun _ => eq_refl;
    SRadd_comm := plus_commutative;
    SRadd_assoc := (fun x y z => eq_sym (@ plus_associative x y z));
    SRmul_1_l := plus_rightzero;
    SRmul_0_l := fun _ => eq_refl;
    SRmul_comm := mult_commutative;
    SRmul_assoc := (fun x y z => eq_sym (@ mult_associative x y z));
    SRdistr_l := mult_rightdist;
    |}.
Add Ring nat_semiring : nat_semiring.
Theorem exp_dist'' : forall n x y, exp (x*y) n = exp x n * exp y n.
    intros n x y; induction n as [| n IHn]; simpl; [| rewrite IHn; ring_simplify ]; reflexivity.
    Qed.

(*
For part 2, I did each proof both with explicit term manipulation, and then
with ltac (under the same name suffixed with a prime). The term manipulation
proofs are longer in the source, but the ltac proofs expand into longer terms.

According to the Coq manual, "tauto" implements a decision procedure for
tautologies in intuitionistic logic from a 1992 paper in the Journal of Symbolic
Logic. It's sufficient to completely solve 4.4 a on it's own, and sufficient to
solve 4.4 b once the Law of the Excluded Middle has been brought into scope.
*)

(* 4.4 a is basically currying, with (conj/proj1/proj2) in Prop instead of (pair/fst/snd) in Set *)
Definition part2_44_a : forall (A B C : Prop), (A -> B -> C) -> (A /\ B -> C) := fun A B C f x => f (proj1 x) (proj2 x).
Theorem part2_44_a' : forall (A B C : Prop), (A -> B -> C) -> (A /\ B -> C). tauto. Qed.

(* 4.4 b requires the Law of the Excluded Middle, which isn't a primitive in the Calculus of Constructions, and must be asserted as an axiom. *)
Axiom LEM : forall P, P \/ ~P.
(*
The "match ... with ... end" construct is used for pattern matching at the value level
(i.e. in kind Set), and proof by cases at the proof level (i.e. in kind Prop). Proof by
contradiction in CoC ends up being a special case of proof by cases, with the False type
(representing a contradiction) having 0 constructors, and a disjunction with 0 cases not
requiring any steps to prove the conclusion. ~E is sugar for (E -> False), so that if E
is instantiated, the term of type ~E can be applied to it get a value of type False,
which can be pattern matched on to get the principle of explosion.

The "fun ... => ..." construct is used for lambdas, which are typed as either
implications or foralls (necessarily as the latter if the type of the body
depends on the value of the binder, i.e. a dependent type)
*)
Definition part2_44_b : forall (A B C D E : Prop), (A \/ B -> C \/ D -> E) -> (A -> ~E -> ~C) :=
    fun A B C D E f a ne => match LEM C with
    | or_introl c => match (ne (f (or_introl a) (or_introl c))) with end
    | or_intror nc => nc
    end.
Theorem part2_44_b' : forall (A B C D E : Prop), (A \/ B -> C \/ D -> E) -> (A -> ~E -> ~C).
    intros; destruct (LEM C); tauto.
    Qed.


(****************************)
(************ TP6 ***********)
(****************************)
Require Import ZArith.
Open Scope Z_scope.
(********** Exercice 1 **********)
(* Question 1 *)
Inductive expr : Set :=
| Plus : expr -> expr -> expr
| Minus : expr -> expr -> expr
| Mult : expr -> expr -> expr
| Oper : Z -> expr.

(* Question 2 *)
Definition exemple_1 := Mult (Plus (Oper 2) (Oper 5)) (Oper 3).
Definition exemple_2 := Minus (Plus (Minus (Oper 2) (Oper 1)) (Mult (Oper 7) (Oper 6))) (Oper 2).

(* Question 3 *)
Fixpoint eval_expr (e:expr) : Z :=
match e with
| Plus a b => (eval_expr a) + (eval_expr b)
| Minus c d => (eval_expr c) - (eval_expr d)
| Mult e f => (eval_expr e) * (eval_expr f)
| Oper o => o
end.

Eval compute in eval_expr (Mult (Plus (Oper 2) (Oper 5)) (Oper 3)).
Eval compute in eval_expr (exemple_2).

(********** Exercice 2 **********)
(* Question 4 *)
Inductive element : Set :=
| Plus_symb : element
| Minus_symb : element
| Mult_symb : element
| Operande : Z -> element.

Definition liste_postfixe := list element.
(* Question 5 *)
Open Scope list_scope.

Definition exemple_3 := (Operande 2)::(Operande 5)::Plus_symb::(Operande 3)::Mult_symb::nil.
Definition exemple_4 := (Operande 2)::(Operande 1)::Minus_symb::(Operande 7)::(Operande 6)::Mult_symb::Plus_symb::(Operande 2)::Minus_symb::nil.

(* Question 6 *)
Definition pile := list Z.
Definition pile_nouv : pile := nil.

Definition empiler (l:pile) (e:Z) := e::l.

Definition depiler (l:pile) :=
match l with
| nil => 9999::nil
| a::b => b
end.

Definition sommet (l:pile) :=
match l with
| nil => (-1)
| a::b => a
end.

Fixpoint eval_postfixe2 (l:liste_postfixe) (p:pile) :=
match l with
| nil => p
| a::b => let s1 := sommet p in
          let p1 := depiler p in
          let s2 := sommet p1 in
          let p2 := depiler p1 in
          eval_postfixe2 b (
            match a with
            | Plus_symb => empiler p2 (s1 + s2)
            | Minus_symb => empiler p2 (s2 - s1)
            | Mult_symb => empiler p2 (s1 * s2)
            | Operande o => empiler p o
            end
          )
end.

Definition eval_postfixe (l:liste_postfixe) := sommet(eval_postfixe2 l pile_nouv).

(* Question 8 *)
Eval compute in eval_postfixe exemple_3.
Eval compute in eval_postfixe exemple_4.

(********** Exercice 3 **********)
(* Question 9 *)
Fixpoint translate (e:expr) :=
match e with
| Plus a b => (translate a)++(translate b)++(Plus_symb::nil)
| Minus c d => (translate c)++(translate d)++(Minus_symb::nil)
| Mult e f => (translate e)++(translate f)++(Mult_symb::nil)
| Oper o => (Operande o)::nil
end.

Eval compute in translate exemple_1.
Eval compute in translate exemple_2.

(* Question 10 *)
Inductive well_formed : liste_postfixe -> Prop :=
| w_seul : forall (z:Z), well_formed ((Operande z)::nil)
| w_plus : forall (l1 l2:liste_postfixe),
          well_formed l1 ->
          well_formed l2 ->
          well_formed (l1++l2++(Plus_symb::nil))
| w_moins : forall (l1 l2:liste_postfixe),
          well_formed l1 ->
          well_formed l2 ->
          well_formed (l1++l2++(Minus_symb::nil))
| w_fois : forall (l1 l2:liste_postfixe),
          well_formed l1 ->
          well_formed l2 ->
          well_formed (l1++l2++(Mult_symb::nil)).

(* Question 11 *)
Lemma wf_ok : forall (e:expr),
well_formed (translate e).
Proof.
intros.
induction e.
simpl.
apply w_plus;
assumption.
apply w_moins;
assumption.
apply w_fois;
assumption.
apply w_seul.
Qed.

(* Question 12 *)
Lemma append_eval : forall (e f:liste_postfixe), forall (p:pile),
eval_postfixe2 (e ++ f) p = eval_postfixe2 f (eval_postfixe2 e p).
Proof.
induction e.
simpl.
reflexivity.
intros.
simpl.
apply IHe.
Qed.

Lemma depiler_eval : forall (f:liste_postfixe),
well_formed f -> forall p:pile, p=depiler(eval_postfixe2 f p).
Proof.
intros.
generalize p.
induction H; intros.
simpl.
reflexivity.
rewrite append_eval.
rewrite append_eval.
simpl.
rewrite <- IHwell_formed2.
rewrite <- IHwell_formed1.
reflexivity.
rewrite append_eval.
rewrite append_eval.
simpl.
rewrite <- IHwell_formed2.
rewrite <- IHwell_formed1.
reflexivity.
rewrite append_eval.
rewrite append_eval.
simpl.
rewrite <- IHwell_formed2.
rewrite <- IHwell_formed1.
reflexivity.
Qed.

(* Question 13 *)
Lemma lemma_plus : forall (e f:liste_postfixe), forall (p:pile),
well_formed e ->
well_formed f ->
sommet (eval_postfixe2 e p) + sommet (eval_postfixe2 f (eval_postfixe2 e p))=
sommet (eval_postfixe2 (e ++ (f ++ ((Plus_symb)::nil))) p).
Proof.
intros.
rewrite append_eval.
rewrite append_eval.
simpl.
rewrite <- depiler_eval.
rewrite Zplus_comm.
reflexivity.
assumption.
Qed.

(* Question 14 *)
Lemma lemma_minus : forall (e f:liste_postfixe), forall (p:pile),
well_formed e ->
well_formed f ->
sommet (eval_postfixe2 e p) - sommet (eval_postfixe2 f (eval_postfixe2 e p))=
sommet (eval_postfixe2 (e ++ (f ++ ((Minus_symb)::nil))) p).
Proof.
intros.
rewrite append_eval.
rewrite append_eval.
simpl.
rewrite <- depiler_eval.
reflexivity.
assumption.
Qed.

Lemma lemma_mult: forall (e f:liste_postfixe), forall (p:pile),
well_formed e ->
well_formed f ->
sommet (eval_postfixe2 e p) * sommet (eval_postfixe2 f (eval_postfixe2 e p))=
sommet (eval_postfixe2 (e ++ (f ++ ((Mult_symb)::nil))) p).
Proof.
intros.
rewrite append_eval.
rewrite append_eval.
simpl.
rewrite <- depiler_eval.
rewrite Zmult_comm.
reflexivity.
assumption.
Qed.

(* Question 15 *)
Lemma interp_ok' : forall e:expr, forall p:pile,
eval_expr e = sommet (eval_postfixe2 (translate e) p).
Proof.
intros.
generalize p.
induction e.
intros.
simpl.
rewrite <- lemma_plus.
rewrite <- IHe1.
rewrite <- IHe2.
reflexivity.
apply wf_ok.
apply wf_ok.
intros.
simpl.
rewrite <- lemma_minus.
rewrite <- IHe1.
rewrite <- IHe2.
reflexivity.
apply wf_ok.
apply wf_ok.
intros.
simpl.
rewrite <- lemma_mult.
rewrite <- IHe1.
rewrite <- IHe2.
reflexivity.
apply wf_ok.
apply wf_ok.
intros.
simpl.
reflexivity.
Qed.

Lemma interp_ok : forall e:expr,
eval_expr e = (eval_postfixe (translate e)).
Proof.
intros.
unfold eval_postfixe.
apply interp_ok'.
Qed.


(* Proof Objects *)
Require Export Logic.

Inductive beautiful : nat -> Prop :=
  b_0 : beautiful 0
| b_3 : beautiful 3
| b_5 : beautiful 5
| b_sum : forall n m : nat, beautiful n -> beautiful m -> beautiful (n + m).

Print beautiful.

Check (b_sum 3 5 b_3 b_5).

Theorem eight_is_beautiful : beautiful 8.
Proof.
  apply (b_sum 3 5 b_3 b_5).
Qed.

Theorem eight_is_beautiful'' : beautiful 8.
Proof.
  Show Proof.
  apply b_sum with (n:=3) (m:=5).
  Show Proof.
  apply b_3.
  Show Proof.
  apply b_5.
  Show Proof.
Qed.

Definition eight_is_beautiful''' : beautiful 8 :=
  b_sum 3 5 b_3 b_5.

Print eight_is_beautiful.
Print eight_is_beautiful''.
Print eight_is_beautiful'''.

(**************************************************
Exercise: 1 star (six_is_beautiful)
Give a tactic proof and a proof object showing that 6 is beautiful.
**************************************************)

Theorem six_is_beautiful :
  beautiful 6.
Proof.
  apply b_sum with (n:=3) (m:=3).
  apply b_3. apply b_3.
Qed.

Definition six_is_beautiful' : beautiful 6 :=
  b_sum 3 3 b_3 b_3.

(**************************************************
Exercise: 1 star (nine_is_beautiful)
Give a tactic proof and a proof object showing that 9 is beautiful.
**************************************************)

Theorem nine_is_beautiful : beautiful 9.
Proof.

Definition nine_is_beautiful' : beautiful 9 :=
  (* FILL IN HERE *) admit.
☐


(* week_38a_recap.v *)
(* dIFP 2014-2015, Q1, Week 38 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

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

(* Learning goals for this week:

   - Using previous lemmas (with rewrite or apply)
     without giving them all their arguments,
     and
     acquiring a sense of which arguments are actually needed,
     to disambiguate.

     To this end, all the proofs of this week's exercises
     should be in two versions, separated by "Restart.":
     * in the first version,
       all the uses of previous lemmas
       should have _complete arguments_; and
     * in the second version,
       all the uses of previous lemmas
       should have _as few arguments as possible_.

   - at

   - The exact tactic:
     it is like apply, requires all the arguments,
     and is used to complete a subgoal.

   - The f_equal tactic:
     it is like f_equal_S,
     just for any function rather than just for S.

   - Proofs by case.

   - Searching the libraries.
*)

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

Require Import Arith Bool.

Search (_ + _ = _ + _ -> _ = _).

SearchAbout plus.

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

Require Import unfold_tactic.

Lemma unfold_plus_bc :
  forall y : nat,
    0 + y = y.
(* left-hand side in the base case of plus
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_plus_ic :
  forall x' y : nat,
    (S x') + y = S (x' + y).
(* left-hand side in the inductive case of plus
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_mult_bc :
  forall y : nat,
    0 * y = 0.
(* left-hand side in the base case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic mult.
Qed.

Lemma unfold_mult_ic :
  forall x' y : nat,
    (S x') * y = y + (x' * y).
(* left-hand side in the inductive case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic mult.
Qed.

(* ***** *)

Lemma plus_1_l :
  forall x : nat,
    1 + x = S x.
Proof.
  intro x.
  rewrite -> (unfold_plus_ic 0).
  rewrite -> (unfold_plus_bc x).
  reflexivity.

  Restart.

  intro x.
  rewrite -> unfold_plus_ic.
  rewrite -> unfold_plus_bc.
  reflexivity.
Qed.

Lemma plus_1_r :
  forall x : nat,
    x + 1 = S x.
Proof.
  intro x.
  rewrite -> (plus_comm x 1).
  exact (plus_1_l x).

  Restart.

  intro x.
  rewrite -> plus_comm.
  apply plus_1_l.
Qed.

(* ***** *)

Lemma f_equal_S :
  forall x y : nat,
    x = y -> S x = S y.
Proof.
  intros x y.
  intro H_xy.
  rewrite -> H_xy.
  reflexivity.

  Restart.

  Check f_equal.
  Check (f_equal S).
  apply (f_equal S).

  Restart.

  exact (f_equal S).

  Restart.

  apply f_equal.
Qed.

Lemma f_equal_plus_1 :
  forall x y : nat,
    x = y -> 1 + x = 1 + y.
Proof.
  exact (f_equal (plus 1)).

  Restart.

  apply f_equal.
Qed.

Lemma f_equal_plus_10 :
  forall x y : nat,
    x = y -> 10 + x = 10 + y.
Proof.
  exact (f_equal (plus 10)).

  Restart.

  apply f_equal.
Qed.

Lemma f_equal_plus_20 :
  forall x y : nat,
    x = y -> x + 20 = 20 + y.
Proof.
  intros x y H_xy.
  rewrite -> (plus_comm x 20).
  exact (f_equal (plus 20) H_xy).

  Restart.

  intros x y H_xy.
  rewrite -> plus_comm.
  apply f_equal.
  exact H_xy.
Qed.

Lemma f_equal_plus_30 :
  forall x y : nat,
    x = y -> 30 + x = y + 30.
Proof.
  intros x y H_xy.
  rewrite -> (plus_comm y 30).
  exact (f_equal (plus 30) H_xy).

  Restart.

  intros x y H_xy.
  rewrite -> plus_comm.

  Restart.

  intros x y H_xy.
  rewrite -> (plus_comm y 30).

  Restart.

  intros x y H_xy.
  rewrite -> (plus_comm y _).

  Restart.

  intros x y H_xy.
  rewrite -> (plus_comm _ 30).

  apply f_equal.
  exact H_xy.
Qed.

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

(* Binomial expansion at rank 2: *)

Definition square (x : nat) : nat :=
  x * x.

Lemma unfold_square :
  forall x : nat,
    square x = x * x.
Proof.
  unfold_tactic square.
Qed.

Lemma binomial_2 :
  forall x y : nat,
    square (x + y) = square x + 2 * x * y + square y.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

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

(* [To be done at home, let's skip to the evenp example.] *)

(* The power (i.e., exponentiation) function: *)

(* A unit test: *)

Notation "A =n= B" := (beq_nat A B) (at level 70, right associativity).

Definition unit_test_for_power (candidate : nat -> nat -> nat) :=
  (candidate 2 0 =n= 1)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 2 10 =n= 1024)
  .

(* A specification: *)

Definition specification_of_power (power : nat -> nat -> nat) :=
  (forall x : nat,
     power x 0 = 1)
  /\
  (forall x n' : nat,
     power x (S n') = x * (power x n')).

(* Uniqueness of the specification: *)

Proposition there_is_only_one_power :
  forall power1 power2 : nat -> nat -> nat,
    specification_of_power power1 ->
    specification_of_power power2 ->
    forall x n : nat,
      power1 x n = power2 x n.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

(* Some lemmas about power: *)

Lemma about_power_base_one :
  forall power : nat -> nat -> nat,
    specification_of_power power ->
    forall n : nat,
      power 1 n = 1.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

Lemma about_power_base_mult :
  forall power : nat -> nat -> nat,
    specification_of_power power ->
    forall x y n : nat,
      power (x * y) n = (power x n) * (power y n).
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

Lemma about_power_exponent_plus :
  forall power : nat -> nat -> nat,
    specification_of_power power ->
    forall x i j : nat,
      power x (i + j) = (power x i) * (power x j).
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

Lemma about_power_exponent_mult :
  forall power : nat -> nat -> nat,
    specification_of_power power ->
    forall x i j : nat,
      power x (i * j) = power (power x i) j.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

(* ***** *)

(* First implementation: *)

Fixpoint power_v1 (x n : nat) : nat :=
  match n with
    | 0 => 1
    | S n' => x * (power_v1 x n')
  end.

Compute unit_test_for_power power_v1.
(*
     = true
     : bool
*)

Lemma unfold_power_v1_bc :
  forall x : nat,
    power_v1 x 0 = 1.
Proof.
  unfold_tactic power_v1.
Qed.

Lemma unfold_power_v1_ic :
  forall x n' : nat,
    power_v1 x (S n') = x * (power_v1 x n').
Proof.
  unfold_tactic power_v1.
Qed.

Proposition power_v1_satisfies_the_specification_of_power :
  specification_of_power power_v1.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

(* ***** *)

(* Second implementation
   (lambda-dropped version of the first): *)

Definition power_v2 (x n_orig : nat) : nat :=
  let fix visit (n : nat) : nat :=
      match n with
        | 0 => 1
        | S n' => x * (visit n')
      end
  in visit n_orig.

Compute unit_test_for_power power_v2.
(*
     = true
     : bool
*)

Lemma unfold_power_v2_bc :
  forall x : nat,
    power_v2 x 0 = 1.
Proof.
  unfold_tactic power_v2.
Qed.

Lemma unfold_power_v2_ic :
  forall x n' : nat,
    power_v2 x (S n') = x * (power_v2 x n').
Proof.
  unfold_tactic power_v2.
Qed.

Proposition power_v2_satisfies_the_specification_of_power :
  specification_of_power power_v2.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

(* ***** *)

(* Third implementation (version with an accumulator): *)

Fixpoint power_acc (x n a : nat) : nat :=
  match n with
    | 0 => a
    | S n' => power_acc x n' (x * a)
  end.

Definition power_v3 (x n : nat) : nat :=
  power_acc x n 1.

Compute unit_test_for_power power_v3.
(*
     = true
     : bool
*)

Lemma unfold_power_acc_bc :
  forall x a : nat,
    power_acc x 0 a = a.
Proof.
  unfold_tactic power_acc.
Qed.

Lemma unfold_power_acc_ic :
  forall x n' a : nat,
    power_acc x (S n') a = power_acc x n' (x * a).
Proof.
  unfold_tactic power_acc.
Qed.

Proposition power_v3_satisfies_the_specification_of_power :
  specification_of_power power_v3.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

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

(* The even predicate: *)

(* A unit test: *)

Notation "A =b= B" := (eqb A B) (at level 70, right associativity).

Definition unit_test_for_evenp (candidate : nat -> bool) :=
  (candidate 0 =b= true)
  &&
  (candidate 1 =b= false)
  &&
  (candidate 2 =b= true)
  &&
  (candidate 3 =b= false)
  .

(* A specification: *)

Definition specification_of_evenp (evenp : nat -> bool) :=
  (evenp 0 = true)
  /\
  (evenp 1 = false)
  /\
  (forall n'' : nat,
     evenp (S (S n'')) = evenp n'').

(* Uniqueness of the specification: *)

Proposition there_is_only_one_evenp :
  forall f g : nat -> bool,
    specification_of_evenp f ->
    specification_of_evenp g ->
    forall n : nat,
      f n = g n.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

(* Properties: *)

Lemma about_evenp :
  forall evenp : nat -> bool,
    specification_of_evenp evenp ->
    forall x : nat,
      evenp (S x) = negb (evenp x).
Proof.
  intros evenp.
  unfold specification_of_evenp.
  intros [H_0 [H_1 H_SS]].
  intro x.
  induction x as [ | x' IHx'].

  rewrite -> H_1.
  rewrite -> H_0.
  unfold negb.
  reflexivity.

  rewrite -> H_SS.
  rewrite -> IHx'.
  destruct (evenp x') eqn:H_evenp_x'.

    unfold negb.
    reflexivity.

  unfold negb.
  reflexivity.
Qed.

Lemma about_evenp_of_a_sum :
  forall evenp : nat -> bool,
    specification_of_evenp evenp ->
    forall x y : nat,
      evenp (x + y) = eqb (evenp x) (evenp y).
Proof.
  intros evenp.
  unfold specification_of_evenp.
  intros [H_0 [H_1 H_SS]].
  intro x.
  induction x as [ | x' IHx'].

  intro y.
  rewrite -> plus_0_l.
  rewrite -> H_0.
  unfold eqb.
  destruct (evenp y) eqn:H_y.
    reflexivity.
  reflexivity.

  intros [ | y'].

  rewrite -> plus_0_r.
  rewrite -> H_0.
  destruct (evenp (S x')) eqn:H_evenp_Sx'.
  unfold eqb.
  reflexivity.

  unfold eqb.
  reflexivity.

  rewrite -> unfold_plus_ic.
  rewrite -> plus_comm.
  rewrite -> unfold_plus_ic.
  rewrite -> plus_comm.
  rewrite -> H_SS.
  rewrite -> IHx'.
  rewrite -> about_evenp.
  rewrite -> about_evenp.
  destruct (evenp x') eqn:H_evenp_x'.
    destruct (evenp y') eqn:H_evenp_y'.
      unfold negb.
      unfold eqb.
      reflexivity.
    unfold negb.
    unfold eqb.
    reflexivity.
  destruct (evenp y') eqn:H_evenp_y'.
    unfold negb.
    unfold eqb.
    reflexivity.
  unfold negb.
  unfold eqb.
  reflexivity.
Qed.

(* An implementation: *)

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

Compute unit_test_for_evenp evenp_v0.
(*
     = true
     : bool
*)

(* Or equivalently (syntactic sugar): *)

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

Compute unit_test_for_evenp evenp_v0'.
(*
     = true
     : bool
*)

Lemma unfold_evenp_v0_bc0 :
  evenp_v0 0 = true.
Proof.
  unfold_tactic evenp_v0.
Qed.

Lemma unfold_evenp_v0_bc1 :
  evenp_v0 1 = false.
Proof.
  unfold_tactic evenp_v0.
Qed.

Lemma unfold_evenp_v0_ic :
  forall n'' : nat,
    evenp_v0 (S (S n'')) = evenp_v0 n''.
Proof.
  unfold_tactic evenp_v0.
Qed.

Proposition evenp_satisfies_the_specification_of_evenp :
  specification_of_evenp evenp_v0.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

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

(* The Fibonacci numbers: *)

(* A unit test: *)

Definition unit_test_for_fib (candidate: nat -> nat) :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8)
  &&
  (candidate 7 =n= 13)
  &&
  (candidate 8 =n= 21)
  &&
  (candidate 9 =n= 34)
  .

(* A specification: *)

Definition specification_of_the_fibonacci_function (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall n'' : nat,
    fib (S (S n'')) = fib (S n'') + fib n''.

(* Uniqueness of the specification: *)

Proposition there_is_only_one_fibonacci_function :
  forall fib1 fib2 : nat -> nat,
    specification_of_the_fibonacci_function fib1 ->
    specification_of_the_fibonacci_function fib2 ->
    forall n : nat,
      fib1 n = fib2 n.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

(* ***** *)

(* A first implementation: *)

Fixpoint fib_ds (n : nat) : nat :=
  match n with
    | 0 => 0
    | S n' => match n' with
                | 0 => 1
                | S n'' => fib_ds n' + fib_ds n''
              end
  end.

Definition fib_v0 (n : nat) : nat :=
  fib_ds n.

Compute unit_test_for_fib fib_v0.

Lemma unfold_fib_ds_base_case_0 :
  fib_ds 0 = 0.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_ds_base_case_1 :
  fib_ds 1 = 1.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_ds_induction_case :
  forall n'' : nat,
    fib_ds (S (S n'')) = fib_ds (S n'') + fib_ds n''.
Proof.
  unfold_tactic fib_ds.
Qed.

Theorem fib_ds_fits_the_specification_of_the_fibonacci_function :
  specification_of_the_fibonacci_function fib_ds.
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

Corollary fib_v0_fits_the_specification_of_the_fibonacci_function :
  specification_of_the_fibonacci_function fib_v0.
Proof.
  unfold fib_v0.
  apply fib_ds_fits_the_specification_of_the_fibonacci_function.
Qed.

(* ***** *)

(* A second implementation, with an accumulator: *)

Fixpoint fib_acc (n a1 a0 : nat) : nat :=
  match n with
    | 0 => a0
    | S n' => fib_acc n' (a1 + a0) a1
  end.

Definition fib_v1 (n : nat) : nat :=
  fib_acc n 1 0.

Compute unit_test_for_fib fib_v1.

Lemma unfold_fib_acc_base_case :
  forall a1 a0 : nat,
    fib_acc 0 a1 a0 = a0.
Proof.
  unfold_tactic fib_acc.
Qed.

Lemma unfold_fib_acc_induction_case :
  forall n' a1 a0 : nat,
    fib_acc (S n') a1 a0 = fib_acc n' (a1 + a0) a1.
Proof.
  unfold_tactic fib_acc.
Qed.

Lemma unfold_fib_v1 :
  forall n : nat,
    fib_v1 n = fib_acc n 1 0.
Proof.
  unfold_tactic fib_acc.
Qed.

(* Eureka lemma: *)

Lemma about_fib_acc :
  forall fib : nat -> nat,
    specification_of_the_fibonacci_function fib ->
    forall k i : nat,
      fib_acc k (fib (S i)) (fib i) = fib (k + i).
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)
Qed.

Theorem fib_v1_fits_the_specification_of_the_fibonacci_function :
  specification_of_the_fibonacci_function fib_v1.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

(* ***** *)

(* A third implementation, with a co-accumulator: *)

Fixpoint fib_co_acc (n : nat) : nat * nat :=
  match n with
    | O => (1, 0)
    | S n' => let (a1, a0) := fib_co_acc n'
              in (a1 + a0, a1)
  end.

Definition fib_v2 (n : nat) : nat :=
  match n with
    | O => 0
    | S n' => let (a1, a0) := fib_co_acc n'
              in a1
  end.

Compute unit_test_for_fib fib_v2.

Lemma unfold_fib_co_acc_base_case :
  fib_co_acc 0 = (1, 0).
Proof.
  unfold_tactic fib_co_acc.
Qed.

Lemma unfold_fib_co_acc_induction_case :
  forall n' : nat,
    fib_co_acc (S n') = let (a1, a0) := fib_co_acc n'
                        in (a1 + a0, a1).
Proof.
  unfold_tactic fib_co_acc.
Qed.

Lemma unfold_fib_v2_0 :
  fib_v2 0 = 0.
Proof.
  unfold_tactic fib_v2.
Qed.

Lemma unfold_fib_v2_Sn' :
  forall n' : nat,
    fib_v2 (S n') = let (a1, a0) := fib_co_acc n'
                    in a1.
Proof.
  unfold_tactic fib_v2.
Qed.

(* Eureka lemma: *)

Lemma about_fib_co_acc :
  forall fib : nat -> nat,
    specification_of_the_fibonacci_function fib ->
    forall n : nat,
      fib_co_acc n = (fib (S n), fib n).
Proof.
Abort.
(* Replace "Abort." with a (standard) proof. *)

Theorem fib_v2_fits_the_specification_of_the_fibonacci_function :
  specification_of_the_fibonacci_function fib_v2.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

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

(* end of week_38a_recap.v *)


(** %\chapter{Propositional Logic}% *)

Module LogicPrimer.

(**

* Propositions and the [Prop] sort

CIC as a logic is expressive enough to accommodate propositions with
quantifications of an arbitrary order and over arbitrary values. On
one hand, it makes it an extremely powerful tool to state almost any
proposition of interest in modern mathematics or computer science. On
the other hand, proving such statements (i.e., constructing their
proof terms), will require human assistance, in the same way the
"paper-and-pencil" proofs are constructed in the classical
mathematics. However, unlike the paper-and-pencil proofs, proofs
constructed in Coq are a subject of immediate _automated_ check, since
they are just programs to be verified for well-typedness. Therefore,
the process of proof construction in Coq is _interactive_ and assumes
the constant interoperation between a human prover, who constructs a
proof term for a proposition (i.e., writes a program), and Coq, the
proof assistant, which carries out the task of _verifying_ the proof
(i.e., type-checking the program). This largely defines our agenda for
the rest of this course: we are going to see how to _prove_ logical
statements by means of writing _programs_, that have the types
corresponding to these statements.

*)

(** * The truth and the falsehood in Coq *)

Require Import ssreflect.

Print True.

(**
[[
Inductive True : Prop :=  I : True
]]
*)

Theorem true_is_true: True.

(**
[[
1 subgoals, subgoal 1 (ID 1)

  ============================
   True
]]
*)

Proof.
exact: I.

(**
[[
No more subgoals.
(dependent evars:)
]]
*)

Qed.

(**
So, our first theorem is proved. As it was hinted previously, it could
have been stated even more concisely, formulated as a mere definition,
and proved by means of providing a corresponding value, without the
need to enter a proof mode:
*)

Definition true_is_true': True := I.

(**
The difference between the two definitions of the truth's validity,
which we have just constructed, can be demonstrated by means of the
[Eval] command.
*)

Eval compute in true_is_true.
(**
[ = true_is_true : True]
*)

Eval compute in true_is_true'.
(**
[ = I : True]

As we can see now, the theorem is evaluated to itself, whereas the
definition evaluates to it body, i.e., the value of the constructor
[I].

Thinking by analogy, one can now guess how the falsehood can be encoded.
*)

Print False.

(**
[[
Inductive False : Prop :=
]]
*)

Check False_ind.

(**
[[
False_ind
     : forall P : Prop, False -> P
]]
*)

Theorem one_eq_two: False -> 1 = 2.
Proof.

exact: (False_ind (1 = 2)).

Undo.

(**

Instead of supplying the argument [(1 = 2)] to [False_ind] manually,
we can leave it to Coq to figure out, what it should be, by using the
SSReflect [apply:] tactic.

*)

apply: False_ind.

(**

There are many more ways to prove this rather trivial statement, but
at this moment we will demonstrate just yet another one, which does
not appeal to the [False_ind] induction principle, but instead
proceeds by _case analysis_.

*)

Undo.

Print False_rect.

case.

(**

The tactic [case] makes Coq to perform the case analysis. In
particular, it _deconstructs_ the _top assumption_ of the goal. The
top assumption in the goal is such that it comes first before any
arrows, and in this case it is a value of type [False]. Then, for all
constructors of the type, whose value is being case-analysed, the
tactic [case] constructs _subgoals_ to be proved.  *)

Undo.

exact: (fun (f: False) => match f with end).

Qed.

(** * Implication and universal quantification

Unlike most of the value-level functions we have seen so far,
propositions are usually parametrized by other propositions, which
makes them instances of _polymorphic_ types, as they appear in System
F and System F_\omega. Similarly to these systems, in Coq the
universal quantifier [forall] binds a variable immediately following
it in the scope of the subsequent type. For instance, the transitivity
of implication in Coq can be expressed via the following proposition:

%\begin{center}%
[forall P Q R: Prop, (P -> Q) -> (Q -> R) -> P -> R]
%\end{center}%

The proposition is therefore _parametrized_ over three propositional
variables, [P], [Q] and [R], and states that from the proof term of
type [P -> Q] and a proof term of type [Q -> R] one can receive a
proof term of type [P -> R]. Let us now prove these statement in the
form of theorem.

*)

Theorem imp_trans: forall P Q R: Prop, (P -> Q) -> (Q -> R) -> P -> R.
Proof.

move=> A B C.
(**
[[
  A : Prop
  B : Prop
  C : Prop
  ============================
   (A -> B) -> (B -> C) -> A -> C
]]
*)
(*
move=> H1 H2 a.
*)
(**
[[
  H1 : A -> B
  H2 : B -> C
  a : A
  ============================
   C
]]

Again, there are multiple ways to proceed now. For example, we can
recall the functional programming and get the result of type [C] just
by two subsequent applications of [H1] and [H2] to the value [a] of type [A]:

*)
(*
exact: (H2 (H1 a)).

(**

Alternatively, we can replace the direct application of the hypotheses
[H1] and [H2] by the reversed sequence of calls to the [apply:]
tactics.

*)

Undo.
*)
(**
The first use of [apply:] will replace the goal [C] by the goal [B],
since this is what it takes to get [C] by using [H2]:

*)
move => H1 H2 a.
apply: H2.

(**
[[
  H1 : A -> B
  a : A
  ============================
   B
]]
The second use of [apply:] reduces the proof of [B] to the proof of
[A], demanding an appropriate argument for [H1].

*)

apply: H1.
(**
[[
  a : A
  ============================
   A
]]
*)

exact: a.
Qed.

(**

In the future, we will replace the use of trivial tactics, such as
[exact:] by SSReflect's much more powerful tactics [done], which
combines a number of standard Coq's tactics in an attempt to finish
the proof of the current goal and reports an error if it fails to do
so.  *)

(** ** On forward and backward reasoning

Let us check now the actual value of the proof term of theorem
[imp_trans].

*)

Print imp_trans.
(**
[[
imp_trans =
  fun (A B C : Prop) (H1 : A -> B) (H2 : B -> C) (a : A) =>
  (fun _evar_0_ : B => H2 _evar_0_) ((fun _evar_0_ : A => H1 _evar_0_) a)
       : forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R

Argument scopes are [type_scope type_scope type_scope _ _ _]
]]

Even though the proof term looks somewhat furry, this is almost
exactly our initial proof term from the first proof attempt: [H2 (H1
a)]. The only difference is that the hypotheses [H1] and [H2] are
_eta-expanded_, that is instead of simply [H1] the proof terms
features its operational equivalent [fun b: B => H2 b]. Otherwise, the
printed program term indicates that the proof obtained by means of
direct application of [H1] and [H2] is the same (modulo eta-expansion)
as the proof obtained by means of using the [apply:] tactic.

These two styles of proving: by providing a direct proof to the goal
or some part of it, and by first reducing the goal via tactics, are
usually referred in the mechanized proof community as _forward_ and
_backward_ proof styles.

  *)

(** ** Refining and bookkeeping assumptions

Suppose, we have the following theorem to prove, which is just a
simple reformulation of the previously proved [imp_trans]:

*)

Theorem imp_trans' (P Q R: Prop) : (Q -> R) -> (P -> Q) -> P -> R.
Proof.
move=> H1 H2.

move: (imp_trans P Q R) => H.
(**
[[
  H1 : Q -> R
  H2 : P -> Q
  H : (P -> Q) -> (Q -> R) -> P -> R
  ============================
   P -> R
]]
*)

apply: H.
(**
[[
  H1 : Q -> R
  H2 : P -> Q
  ============================
   P -> Q

subgoal 2 (ID 142) is:
 Q -> R
]]
*)

done.
done.

(**

The proof is complete, although the last step is somewhat repetitive,
since we know that for two generated sub-goals the proofs are the
same. In fact, applications of tactics can be _chained_ using the [;]
connective, so the following complete proof of [imp_trans'] runs
[done] for _all_ subgoals generated by [apply: H]:

*)

Restart.

move: (imp_trans P Q R)=> H H1 H2.
apply: H; done.

(**

To conclude this section, let us demonstrate even shorter way to prove
this theorem once again.

*)

Restart.
move=>H1 H2; apply: (imp_trans P Q R)=>//.
Qed.

(** * Conjunction and disjunction *)

Module Connectives.
Variables P Q R: Prop.

Locate "_ /\ _".

(** ["A /\ B" := and A B  : type_scope] *)

Print and.

(**
[[
Inductive and (A B : Prop) : Prop :=  conj : A -> B -> A /\ B

For conj: Arguments A, B are implicit
For and: Argument scopes are [type_scope type_scope]
For conj: Argument scopes are [type_scope type_scope _ _]
]]
*)

Goal P -> R -> P /\ R.
move=> p r.

(**

The proof can be completed in several ways. The most familiar one is
to apply the constructor [conj] directly. It will create two subgoals,
[P] and [Q] (which are the constructor arguments), that can be
immediately discharged.

*)

apply: conj=>//.

(**

Alternatively, since we now know that [and] has just one constructor,
we can use the generic Coq's [constructor n] tactic, where [n] is an
(optional) number of a constructor to be applied (and in this case
it's [1])

*)

Undo.
constructor 1=>//.

(**

Finally, for propositions that have exactly one constructor, Coq
provides a specialized tactic [split], which is a synonym for
[constructor 1]: *)

Undo. split=>//.
Qed.

(**

In order to prove something out of a conjunction, one needs to
_destruct_ it to get its constructor's arguments, and the simplest way
to do so is by the [case]-analysis on a single constructor.

*)

Goal P /\ Q -> Q.
Proof.
case.

done.
Qed.

(**

The datatype of disjunction of [P] and [Q], denoted by [P \/ Q], is
isomorphic to the [sum] datatype from the provious lecture and can be
constructed by using one of its two constructors: [or_introl] or
[or_intror].

*)

Locate "_ \/ _".

(** ["A \/ B" := or A B   : type_scope] *)

Print or.

(**

[[
Inductive or (A B : Prop) : Prop :=
    or_introl : A -> A \/ B | or_intror : B -> A \/ B

For or_introl, when applied to less than 1 argument:
  Arguments A, B are implicit
...
]]

In order to prove disjunction of [P] and [Q], it is sufficient to
provide a proof of just [P] or [Q], therefore appealing to the
appropriate constructor.

*)

Goal Q -> P \/ Q \/ R.
move=> q.

by right; left.
Qed.

Goal P \/ Q -> Q \/ P.
case=>x.

(**
[[
  P : Prop
  Q : Prop
  R : Prop
  x : P
  ============================
   Q \/ P

subgoal 2 (ID 248) is:
 Q \/ P
]]
*)

by right.

(**

[[
  P : Prop
  Q : Prop
  R : Prop
  x : Q
  ============================
   Q \/ P
]]

In the second branch the type of [x] is [Q], as it accounts for the
case of the [or_intror] constructor.

*)

by left.
Qed.

(** * Proofs with negation *)

(**

In Coq's constructive approach proving the negation of [~P] of a
proposition [P] literally means that one can derive
the falsehood from [P].

*)

Locate "~ _".

(**
["~ x" := not x       : type_scope]
*)

Print not.
(**
[[
  not = fun A : Prop => A -> False
       : Prop -> Prop
]]

Therefore, the negation [not] on propositions from [Prop] is just a
function, which maps a proposition [A] to the implication [A ->
False]. Calculus of Constructions lacks the axiom of double negation,
which means that the proof of [~ ~A] will not deliver the proof of
[A], as such derivation would be not constructive, as one cannot get a
value of type [A] out of a function of type [(A -> B) -> B], where [B]
is taken to be [False].

However, reasoning out of negation helps to derive the familiar proofs
by contradiction, given that we managed to construct [P] _and_ [~P],
as demonstrated by the following theorem, which states that from any
[Q] can be derived from [P] and [~P].

*)

Theorem absurd: P -> ~P -> Q.
Proof. by move=>p H; move : (H p). Qed.

(**

One extremely useful theorem from propositional logic involving
negation is _contraposition_. It states states that in an implication, the
assumption and the goal can be flipped if inverted.

*)

Theorem contraP: (P -> Q) -> ~Q -> ~P.

(** Let us see how it can be proved in Coq *)

Proof.
move=> H Hq.
move /H.
(**
[[
  H : P -> Q
  Hq : ~ Q
  ============================
   Q -> False
]]
*)

move /Hq.
done.
Qed.

(** * Existential quantification *)

Locate "exists".

(**
[[
"'exists' x .. y , p" := ex (fun x => .. (ex (fun y => p)) ..)
                      : type_scope
]]

*)

Print ex.

(**
[[
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex A P
]]
*)

Theorem ex_imp_ex A (S T: A -> Prop):
  (exists a: A, S a) -> (forall x: A, S x -> T x) -> exists b: A, T b.

(**

The parentheses are important here, otherwise, for instance, the scope
of the first existentially-quantified variable [a] would be the whole
subsequent statement, not just the proposition _S a_.

*)

Proof.

case=>a Hs Hst.
(**
[[
  A : Type
  S : A -> Prop
  T : A -> Prop
  a : A
  Hs : S a
  Hst : forall x : A, S x -> T x
  ============================
   exists b : A, T b
]]

Next, we apply the [ex]'s constructor by means of the [exists]
tactic with an explicit witness value [a]:
*)

exists a.

(** We finish the proof  by applying the weakening hypothesis [Hst]. *)

by apply: Hst.

Qed.

(** ** A conjunction and disjunction analogy

Sometimes, the universal and the existential quantifications are
paraphrased as "infinitary" conjunction and disjunction
correspondingly. This analogy comes in handy when understanding the
properties of both quantifications, so let us elabore on it for a bit.

*)

End Connectives.

(** * Missing axioms from the classical logic *)

Require Import Classical_Prop.

(**

The most often missed axiom is the axiom of _excluded middle_, which
postulates that the disjunction of [P] and [~P] is provable. Adding
this axiom circumvents the fact that the reasoning out of the excluded
middle principle is _non-constructive_.

*)

Check classic.

(**
[[
classic
     : forall P : Prop, P \/ ~ P
]]

Another axiom from the classical logic, which coincides with the type
of Scheme's [call/cc] operator.
*)

Definition peirce_law := forall P Q: Prop, ((P -> Q) -> P) -> P.

(**

In Scheme-like languages, the [call/cc] operator allows one to
invoke the undelimited continuation, which aborts the
computation. Similarly to the fact that [call/cc] cannot be
implemented in terms of polymorphically-typed lambda calculus as a
function and should be added as an external operator, the Peirce's law
is an axiom in the constructive logic.
*)

Check NNPP.

(**
[[
NNPP
     : forall P : Prop, ~ ~P -> P
]]

Finally, the classical formulation of the implication through the
disjunction is again an axiom in the constructive logic, as otherwise
from the function of type [P -> Q] one would be able to construct the
proof of [~P \/ Q], which would make the law of the excluded middle
trivial to derive.
*)

Check imply_to_or.

(**

[[
imply_to_or
     : forall P Q : Prop, (P -> Q) -> ~P \/ Q
]]

Curiously, none of these axioms, if added to Coq, makes its logic
unsound: it has been rigorously proven (although, not within Coq, due
to Godel's incompleteness result) that all classical logic axioms are
consistent with CIC, and, therefore, don't make it possible to derive
the falsehood.

*)

(** * Universes and [Prop] impredicativity

_Impredicativity_ as a property of definitions allows one to define
domains that are _self-recursive_---a feature of [Prop] that we
recently observed. Unfortunately, when restated in the classical set
theory, impredicativity immediately leads to the famous Russel's
paradox, which arises from the attempt to define a set of all sets
that do not belong to themselves. In the terms of programming, the
Russel's paradox provides a recipe to encode a fixpoint combinator in
the calculus itself and write generally-recursive programs.

** Exploring and debugging the universe hierarchy

In the light of Martin-Loef's stratification, the Coq' non-polymorphic
types, such as [nat], [bool], [unit] or [list nat] "live" at the [0]th
level of universe hierarchy, namely, in the sort [Set]. The
polymorphic types, quantifying over the elements of the [Set] universe
are, therefore located at the higher level, which in Coq is denoted as
[Type(1)], but in the displays is usually presented simply as [Type],
as well as all the higher universes. We can enable the explicit
printing of the universe levels to see how they are assigned:

*)

Set Printing Universes.

Check bool.

(**
[[
bool
     : Set
]]
*)

Check Set.

Check Prop.

(**
The following type is polymorphic over the elements of the [Set]
universe, and this is why its own universe is "bumped up" by one, so
it becomes [Type(1)].
*)

Definition S := forall T: Set, list T.
Check S.

(**
At this moment, Coq provides a very limited version of _universe
polymorphism_. For instance, the next definition [R] is polymorphic
with respect to the universe of its parameter [A], so its result lives
in the universe, whose level is taken to be the level of [A].

*)

Definition R (A: Type) (x: A): A := x.
Implicit Arguments R [A].

Check R tt.

(**
[[
R tt
     : unit
]]
*)

(**

If the argument of [R] is itself a universe, it means that [A]'s
level is higher than [x]'s level, and so is the level of [R]'s result.

*)

Check R Type.

(**
However, the attempt to apply [R] to itself immediately leads to an
error reported, as the system cannot infer the level of the result, by
means of solving a system of universe level inequations, therefore,
preventing meta-circular paradoxes.

*)

(**
[[
Check R R.

Error: Universe inconsistency (cannot enforce Top.1225 < Top.1225).
]]
*)

(*******************************************************************)
(**                     * Exercices *                              *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [forall-distributivity]
---------------------------------------------------------------------

Formulate and prove the following theorem in Coq, which states the
distributivity of universal quantification with respect to implication:
\[
forall P Q,
  [(forall x, P(x) => Q(x)) => ((forall y, P(y)) => forall z, Q(z))]
\]

Be careful with the scoping of universally-quantified variables
and use parentheses to resolve ambiguities!
*)

Theorem all_imp_ist A (P Q: A -> Prop):
  (forall x: A, P x -> Q x) -> (forall y, P y) -> forall z, Q z.
Proof.
move => H1 H2 z.
apply : H1; apply : H2.
Qed.

(**
---------------------------------------------------------------------
Exercise [Or-And distributivity]
---------------------------------------------------------------------
Prove the following theorems.
*)

Theorem or_distributes_over_and P Q R:
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
split.
- case=>[p | [q r]]; split; do?[by left| by right].
- case; case => [p _| q]; first by left.
  by case=>p; [left | right].
Qed.

Theorem or_distributes_over_and_2 P Q R :
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
move : (or_distributes_over_and P Q R).
by move=> H; move/H.
Qed.

(**
---------------------------------------------------------------------
Exercise [Home-brewed existential quantification]
---------------------------------------------------------------------

Let us define our own version [my_ex] of the existential quantifier
using the SSReflect notation for constructors: *)

Inductive my_ex A (S: A -> Prop) : Prop := my_ex_intro x of S x.

(** You invited to prove the following goal, establishing the
equivalence of the two propositions. *)

Goal forall A (S: A -> Prop), my_ex A S <-> exists y: A, S y.
Proof.
by split; case; move => x Sx; exists x.
Qed.

(**
Hint: the propositional equivalence [<->] is just a conjunction of
two implications, so proving it can be reduced to two separate goals
by means of [split] tactics.
*)

(**
---------------------------------------------------------------------
Exercise [Distributivity of existential quantification]
---------------------------------------------------------------------
Prove the following theorem.
*)

Theorem dist_exists_or (X : Type) (P Q : X -> Prop):
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
split.
- by case => x; case => p; [left | right]; exists x.
- by case; case => x p; exists x; [left | right].
Qed.

(**
---------------------------------------------------------------------
Exercise [Two equals three]
---------------------------------------------------------------------
Prove the following  theorem. Can you explain the proof?
*)

Theorem two_is_three A: (exists x : A, (forall R : A -> Prop, R x)) -> 2 = 3.
Proof.
by case => x H; move: (H (fun _ => 2 = 3)).
Qed.

(**
---------------------------------------------------------------------
Exercise [Dyslexic implication and contraposition]
---------------------------------------------------------------------

The "dyslexic" implication and contrapositions are the following
propositions.
*)

Definition dys_imp (P Q: Prop) := (P -> Q) -> (Q -> P).
Definition dys_contrap (P Q: Prop) := (P -> Q) -> (~P -> ~Q).

(**
These propositions are inhabited, as otherwise one, given a proof of
any of them, would be able to construct a proof of [False]. You are
invited to deomnstrate it by proving the following statements.
*)

Theorem di_false: (forall P Q: Prop, dys_imp P Q) -> False.
Proof.
by move/ (_ _ True) => H1; apply: H1.
Qed.

Theorem dc_false: (forall P Q: Prop, dys_contrap P Q) -> False.
Proof.
move/ (_ False True).
rewrite /dys_contrap.
by move=> H1; apply: H1.
Qed.

(**
---------------------------------------------------------------------
Exercise [Irrefutability of the excluded middle]
---------------------------------------------------------------------

Proof the following theorem that states that the assumption of the
falsehood of the excluded middle leads to inconsistencies, as is
allows one to derive [False].
*)

Theorem excluded_middle_irrefutable: forall (P : Prop), ~~(P \/ ~ P).
Proof.
move=> P H.
apply: (H); right.
move=> HP; move: H.
by case; left.
Qed.

(**
---------------------------------------------------------------------
Exercise [Equivalence of classical logic axioms]
---------------------------------------------------------------------

Prove that the following five axioms of the classical are equivalent.

*)

Definition peirce := peirce_law.
Definition double_neg := forall P: Prop, ~ ~ P -> P.
Definition excluded_middle := forall P: Prop, P \/ ~P.
Definition de_morgan_not_and_not := forall P Q: Prop, ~ ( ~P /\ ~Q) -> P \/ Q.
Definition implies_to_or := forall P Q: Prop, (P -> Q) -> (~P \/ Q).

Lemma peirce_dn: peirce -> double_neg.
Proof.
rewrite /peirce /peirce_law /double_neg /not => H P HP.
by move: (H P False)=> H'; apply: H'; move/HP.
Qed.

Lemma dn_em : double_neg -> excluded_middle.
Proof.
rewrite /excluded_middle /double_neg => H P.
suff: ~ ~ (P \/ ~ P); first by apply H.
move/ not_or_and.
by case.
Qed.

Lemma em_dmnan: excluded_middle -> de_morgan_not_and_not.
Proof.
rewrite /excluded_middle /de_morgan_not_and_not=> H P Q.
case (H P); case (H Q); intuition.
Qed.

Lemma dmnan_ito : de_morgan_not_and_not -> implies_to_or.
Proof.
rewrite /de_morgan_not_and_not /implies_to_or => H P Q H1.
apply: (H); case => HP HQ.
by apply: HP; move/H1.
Qed.

Lemma ito_peirce : implies_to_or -> peirce.
Proof.
rewrite /implies_to_or /peirce /peirce_law => H P Q H1.
move: (H P P (@id P)) => HP.
move: (H Q Q (@id Q)) => HQ.
move: HP; case; move: HQ; case => //= => HQ HP; apply: H1 => //.
Qed.

(**

Hint: Use [rewrite /d] tactics to unfold the definition of a value [d]
 and replace its name by its body. You can chain several unfoldings by
 writing [rewrite /d1 /d2 ...]  etc.

Hint: To facilitate the forward reasoning by contradiction, you can
 use the SSReflect tactic [suff: P], where [P] is an arbitrary
 proposition. The system will then require you to prove that [P]
 implies the goal _and_ [P] itself.

Hint: Stuck with a tricky proof? Use the Coq [admit] tactic as a
 "stub" for an unfinished proof of a goal, which, nevertheless will be
 considered completed by Coq. You can always get back to an admitted
 proof later.

*)

(**
---------------------------------------------------------------------
Exercise [Inifinitary de Morgan laws]
---------------------------------------------------------------------

Prove the following implication analogous to the Morgan law for
conjunctions  and disjunctions.

*)

Theorem not_forall_exists A (P : A -> Prop):
  (forall x: A, P x) -> ~(exists y: A, ~ P y).
Proof.
move=> H. case; move=> x HP.
by move: (H x).
Qed.

(**

Then, prove that the assumption of the excluded middle axiom allows one to
establish the implication from the negation of (exists) to (forall).

*)

Theorem not_exists_forall :
  excluded_middle -> forall (X: Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
move=> EM X P H x.
rewrite /excluded_middle in EM.
move: (EM (P x)).
case.
- done.
- move=> PN.
  suff: False=>//.
  apply: H.
  by exists x.
Qed.

End LogicPrimer.


Require Import bool.
Require Import nat.

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

(*
Check S (S (S (S O))).
Compute minustwo 4.
Check S.
Check Playground1.pred.
Check minustwo.
*)

Example test_evenb0: evenb 0 = true.
Proof. simpl. reflexivity. Qed.

Example test_evenb1: evenb 1 = false.
Proof. simpl. reflexivity. Qed.

Example test_evenb2: evenb 2 = true.
Proof. simpl. reflexivity. Qed.

Example test_oddb0: oddb 0 = false.
Proof. simpl. reflexivity. Qed.

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_oddb2: oddb 2 = false.
Proof. simpl. reflexivity. Qed.

(*
Compute plus 3 2.
Compute plus 1540 3000. (* stack overflow pretty soon *)
*)

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

Example test_minus1: minus 10 3 = 7.
Proof. simpl. reflexivity. Qed.

Example test_exp1: exp 3 4 = 81.
Proof. simpl. reflexivity. Qed.

Example test_fact1: fact 5 = 120.
Proof. simpl. reflexivity. Qed.

(*
Compute 5 + 3 + 2 + 15.
*)

(*
Compute 10 - 2 - 4.
*)

(*
Compute 10 + 3 * 4.
Check plus 4 3.
*)

(*
Compute eqb 0 0.
Compute eqb 43 12.
Compute eqb 56 56.
*)

(*
Compute leb 23 24.
Compute leb 24 24.
Compute leb 25 24.
*)

(*
Compute ltb 23 24.
Compute ltb 24 24.
Compute ltb 25 24.
*)

Lemma plus_0_n' : forall n:nat, 0 + n = n.
Proof.
    intros n. reflexivity.
Qed.

Lemma plus_id_example: forall n m:nat,
    n = m -> n + n = m + m.
Proof.
    intros n m H. rewrite H. reflexivity.
Qed.

Lemma plus_id_exercise: forall n m o: nat,
   n = m -> m = o -> n + m = m + o.
Proof.
    intros n m o H1 H2. rewrite H1. rewrite <- H2. reflexivity.
Qed.

(*
Theorem plus_comm : forall n m:nat,
    n + m = m + n.
Proof.
Admitted.  (* useful when writing bigger proofs *)
*)

Lemma plus_1_neq_0' : forall n:nat,
    eqb (n + 1) 0 = false.
Proof.
    (* 'as' clause to name variables of constructors    *)
    (*  of inductive type. 0 is a nullary constructor   *)
    intros n. destruct n as [|n].   (* we don't need induction here *)
    - reflexivity.          (* you can skip 'simpl' *) (* using bullet for clarity *)
    - reflexivity.          (* you can skip 'simpl' *) (* using bullet for clarity *)
Qed.

Lemma plus_1_neq_0'' : forall n:nat,
    eqb (n + 1) 0 = false.
Proof.
    intros [|n].           (* shortcut for intros n. destruct n as [|n]. *)
    - reflexivity.
    - reflexivity.
Qed.


Require Import Nat.

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

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

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

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

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

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Definition qpush (q : queue) (n : nat) : queue :=
match q with
  | Queue l1 l2 => amortizeQueue l1 (Cons n l2)
end.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. rewrite len_app. simpl. rewrite plus_comm. simpl. rewrite IHl. reflexivity.
Qed.

Theorem queue_push : forall q n, qlen (qpush q n) = 1 + (qlen q).
Proof.
  intros. simpl. destruct q. unfold qpush. unfold qlen. unfold amortizeQueue.
  destruct (leb (len (Cons n l0)) (len l)).
  - simpl. rewrite plus_n_Sm. reflexivity.
  - simpl. rewrite <- plus_n_O.
    rewrite len_app.
    rewrite len_app. rewrite len_rev.
    simpl. rewrite plus_n_Sm. rewrite (plus_comm (len l0)). reflexivity.
Qed.


(** * More Logic *)

Require Export Propositions.

(* ############################################################ *)
(** * Existential Quantification *)

(** Another critical logical connective is _existential
    quantification_.  We can express it with the following
    definition: *)

Inductive ex (X:Type) (P : X->Prop) : Prop :=
  ex_intro : forall (witness:X), P witness -> ex X P.

(** That is, [ex] is a family of propositions indexed by a type [X]
    and a property [P] over [X].  In order to give evidence for the
    assertion "there exists an [x] for which the property [P] holds"
    we must actually name a _witness_ -- a specific value [x] -- and
    then give evidence for [P x], i.e., evidence that [x] has the
    property [P].

*)

(** *** *)
(** Coq's [Notation] facility can be used to introduce more
    familiar notation for writing existentially quantified
    propositions, exactly parallel to the built-in syntax for
    universally quantified propositions.  Instead of writing [ex nat
    ev] to express the proposition that there exists some number that
    is even, for example, we can write [exists x:nat, ev x].  (It is
    not necessary to understand exactly how the [Notation] definition
    works.) *)

Notation "'exists' x , p" := (ex _ (fun x => p))
  (at level 200, x ident, right associativity) : type_scope.
Notation "'exists' x : X , p" := (ex _ (fun x:X => p))
  (at level 200, x ident, right associativity) : type_scope.

(** *** *)
(** We can use the usual set of tactics for
    manipulating existentials.  For example, to prove an
    existential, we can [apply] the constructor [ex_intro].  Since the
    premise of [ex_intro] involves a variable ([witness]) that does
    not appear in its conclusion, we need to explicitly give its value
    when we use [apply]. *)

Example exists_example_1 : exists n, n + (n * n) = 6.
Proof.
  apply ex_intro with (witness:=2).
  reflexivity.  Qed.

(** Note that we have to explicitly give the witness. *)

(** *** *)
(** Or, instead of writing [apply ex_intro with (witness:=e)] all the
    time, we can use the convenient shorthand [exists e], which means
    the same thing. *)

Example exists_example_1' : exists n, n + (n * n) = 6.
Proof.
  exists 2.
  reflexivity.  Qed.

(** *** *)
(** Conversely, if we have an existential hypothesis in the
    context, we can eliminate it with [inversion].  Note the use
    of the [as...] pattern to name the variable that Coq
    introduces to name the witness value and get evidence that
    the hypothesis holds for the witness.  (If we don't
    explicitly choose one, Coq will just call it [witness], which
    makes proofs confusing.) *)

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intros n H.
  inversion H as [m Hm].
  exists (2 + m).
  apply Hm.  Qed.

(** Here is another example of how to work with existentials. *)
Lemma exists_example_3 :
  exists (n:nat), even n /\ beautiful n.
Proof.
(* WORKED IN CLASS *)
  exists 8.
  split.
  unfold even. simpl. reflexivity.
  apply b_sum with (n:=3) (m:=5).
  apply b_3. apply b_5.
Qed.

(** **** Exercise: 1 star, optional (english_exists) *)
(** In English, what does the proposition
      ex nat (fun n => beautiful (S n))
]]
    mean? *)

(* There is exists some Nat with a [beautiful] successor. *)

(*
*)
(** **** Exercise: 1 star (dist_not_exists) *)
(** Prove that "[P] holds for all [x]" implies "there is no [x] for
    which [P] does not hold." *)

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros. unfold not. intros. inversion H0.
    apply H1. apply H.
Qed.

(** [] *)

(** **** Exercise: 3 stars, optional (not_exists_dist) *)
(** (The other direction of this theorem requires the classical "law
    of the excluded middle".) *)

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  unfold excluded_middle. intros ex_mid. intros.
  unfold not in H. unfold not in ex_mid.

  assert (M : P x \/ ~ P x).
    Case "Proof of assertion".
    apply ex_mid.

  Case "Assertion application".
  unfold not in M.
  inversion M.
    apply H0.
    destruct H.
      exists x.
      apply H0.
Qed.

(** [] *)

(** **** Exercise: 2 stars (dist_exists_or) *)
(** Prove that existential quantification distributes over
    disjunction. *)

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros. split. intros. inversion H. inversion H0.
  Case "L".
    left. exists witness. apply H1.
    right. exists witness. apply H1.
  Case "R".
   intros. inversion H.
     inversion H0. exists witness. left. apply H1.
     inversion H0. exists witness. right. apply H1.
Qed.

(** [] *)

(* ###################################################### *)
(** * Evidence-carrying booleans. *)

(** So far we've seen two different forms of equality predicates:
[eq], which produces a [Prop], and
the type-specific forms, like [beq_nat], that produce [boolean]
values.  The former are more convenient to reason about, but
we've relied on the latter to let us use equality tests
in _computations_.  While it is straightforward to write lemmas
(e.g. [beq_nat_true] and [beq_nat_false]) that connect the two forms,
using these lemmas quickly gets tedious.
*)

(** *** *)
(**
It turns out that we can get the benefits of both forms at once
by using a construct called [sumbool]. *)

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

Notation "{ A } + { B }" :=  (sumbool A B) : type_scope.

(** Think of [sumbool] as being like the [boolean] type, but instead
of its values being just [true] and [false], they carry _evidence_
of truth or falsity. This means that when we [destruct] them, we
are left with the relevant evidence as a hypothesis -- just as with [or].
(In fact, the definition of [sumbool] is almost the same as for [or].
The only difference is that values of [sumbool] are declared to be in
[Set] rather than in [Prop]; this is a technical distinction
that allows us to compute with them.) *)

(** *** *)

(** Here's how we can define a [sumbool] for equality on [nat]s *)

Theorem eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  (* WORKED IN CLASS *)
  intros n.
  induction n as [|n'].
  Case "n = 0".
    intros m.
    destruct m as [|m'].
    SCase "m = 0".
      left. reflexivity.
    SCase "m = S m'".
      right. intros contra. inversion contra.
  Case "n = S n'".
    intros m.
    destruct m as [|m'].
    SCase "m = 0".
      right. intros contra. inversion contra.
    SCase "m = S m'".
      destruct IHn' with (m := m') as [eq | neq].
      left. apply f_equal.  apply eq.
      right. intros Heq. inversion Heq as [Heq']. apply neq. apply Heq'.
Defined.

(** Read as a theorem, this says that equality on [nat]s is decidable:
that is, given two [nat] values, we can always produce either
evidence that they are equal or evidence that they are not.
Read computationally, [eq_nat_dec] takes two [nat] values and returns
a [sumbool] constructed with [left] if they are equal and [right]
if they are not; this result can be tested with a [match] or, better,
with an [if-then-else], just like a regular [boolean].
(Notice that we ended this proof with [Defined] rather than [Qed].
The only difference this makes is that the proof becomes _transparent_,
meaning that its definition is available when Coq tries to do reductions,
which is important for the computational interpretation.)
*)

(** *** *)
(**
Here's a simple example illustrating the advantages of the [sumbool] form. *)

Definition override' {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if eq_nat_dec k k' then x else f k'.

Theorem override_same' : forall (X:Type) x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override' f k1 x1) k2 = f k2.
Proof.
  intros X x1 k1 k2 f. intros Hx1.
  unfold override'.
  destruct (eq_nat_dec k1 k2).   (* observe what appears as a hypothesis *)
  Case "k1 = k2".
    rewrite <- e.
    symmetry. apply Hx1.
  Case "k1 <> k2".
    reflexivity.  Qed.

(** Compare this to the more laborious proof (in MoreCoq.v) for the
   version of [override] defined using [beq_nat], where we had to
   use the auxiliary lemma [beq_nat_true] to convert a fact about booleans
   to a Prop. *)

(** **** Exercise: 1 star (override_shadow') *)
Theorem override_shadow' : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  (override' (override' f k1 x2) k1 x1) k2 = (override' f k1 x1) k2.
Proof.
  intros.
  unfold override'.
  destruct (eq_nat_dec k1 k2).
    reflexivity.
    reflexivity.
Qed.
(** [] *)

(* ####################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 3 stars (all_forallb) *)
(** Inductively define a property [all] of lists, parameterized by a
    type [X] and a property [P : X -> Prop], such that [all X P l]
    asserts that [P] is true for every element of the list [l]. *)

Inductive all {X : Type} (P : X -> Prop) : list X -> Prop :=
  | a_nil : all P []
  | a_cons h t : P h -> all P t -> all P (h :: t).

(** Recall the function [forallb], from the exercise
    [forall_exists_challenge] in chapter [Poly]: *)

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
    | [] => true
    | x :: l' => andb (test x) (forallb test l')
  end.

(** Using the property [all], write down a specification for [forallb],
    and prove that it satisfies the specification. Try to make your
    specification as precise as possible.

    Are there any important properties of the function [forallb] which
    are not captured by your specification? *)

Theorem forallb_spec :
  forall X (test : X -> bool) (l : list X),
    forallb test l = true <-> all (fun x => test x = true) l.
Proof.
  intros. split. intros. induction l as [|h t].
    Case "1".
      apply a_nil.
    Case "2".
      apply a_cons.
      simpl in H.
      destruct (test h). reflexivity. apply H.
      apply IHt. simpl in H.
      destruct (test h). apply H. inversion H.
   Case "3".
    intros.
    induction H.
      reflexivity.
      simpl. rewrite H. simpl. apply IHall.
Qed.

(** [] *)

(** **** Exercise: 4 stars, advanced (filter_challenge) *)
(** One of the main purposes of Coq is to prove that programs match
    their specifications.  To this end, let's prove that our
    definition of [filter] matches a specification.  Here is the
    specification, written out informally in English.

    Suppose we have a set [X], a function [test: X->bool], and a list
    [l] of type [list X].  Suppose further that [l] is an "in-order
    merge" of two lists, [l1] and [l2], such that every item in [l1]
    satisfies [test] and no item in [l2] satisfies test.  Then [filter
    test l = l1].

    A list [l] is an "in-order merge" of [l1] and [l2] if it contains
    all the same elements as [l1] and [l2], in the same order as [l1]
    and [l2], but possibly interleaved.  For example,
    [1,4,6,2,3]
    is an in-order merge of
    [1,6,2]
    and
    [4,3].
    Your job is to translate this specification into a Coq theorem and
    prove it.  (Hint: You'll need to begin by defining what it means
    for one list to be a merge of two others.  Do this with an
    inductive relation, not a [Fixpoint].)  *)

Inductive in_order_merge {X : Type} : list X -> list X -> list X -> Prop :=
  | iom_nil : in_order_merge [] [] []
  | iom_l   : forall (h : X) (xs ys zs : list X),
                in_order_merge (h :: xs) ys (h :: zs)
  | iom_r   : forall (h : X) (xs ys zs : list X),
                in_order_merge xs (h :: ys) (h :: zs).

Theorem filter_challenge : forall X (p : X -> bool) (l lt lf : list X),
                             in_order_merge l lt lf ->
                             forallb p lt = true ->
                             forallb (fun x => negb (p x)) lf = true ->
                             filter p l = lt.
Proof. Admitted.

(** [] *)

(** **** Exercise: 5 stars, advanced, optional (filter_challenge_2) *)
(** A different way to formally characterize the behavior of [filter]
    goes like this: Among all subsequences of [l] with the property
    that [test] evaluates to [true] on all their members, [filter test
    l] is the longest.  Express this claim formally and prove it. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 4 stars, advanced (no_repeats) *)
(** The following inductively defined proposition... *)

Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
  | ai_here : forall l, appears_in a (a::l)
  | ai_later : forall b l, appears_in a l -> appears_in a (b::l).

(** ...gives us a precise way of saying that a value [a] appears at
    least once as a member of a list [l].

    Here's a pair of warm-ups about [appears_in].
*)

Lemma appears_in_app : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x (xs ++ ys) -> appears_in x xs \/ appears_in x ys.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma app_appears_in : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x xs \/ appears_in x ys -> appears_in x (xs ++ ys).
Proof.
  (* FILL IN HERE *) Admitted.

(** Now use [appears_in] to define a proposition [disjoint X l1 l2],
    which should be provable exactly when [l1] and [l2] are
    lists (with elements of type X) that have no elements in common. *)

(* FILL IN HERE *)

(** Next, use [appears_in] to define an inductive proposition
    [no_repeats X l], which should be provable exactly when [l] is a
    list (with elements of type [X]) where every member is different
    from every other.  For example, [no_repeats nat [1,2,3,4]] and
    [no_repeats bool []] should be provable, while [no_repeats nat
    [1,2,1]] and [no_repeats bool [true,true]] should not be.  *)

(* FILL IN HERE *)

(** Finally, state and prove one or more interesting theorems relating
    [disjoint], [no_repeats] and [++] (list append).  *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars (nostutter) *)
(** Formulating inductive definitions of predicates is an important
    skill you'll need in this course.  Try to solve this exercise
    without any help at all (except from your study group partner, if
    you have one).

    We say that a list of numbers "stutters" if it repeats the same
    number consecutively.  The predicate "[nostutter mylist]" means
    that [mylist] does not stutter.  Formulate an inductive definition
    for [nostutter].  (This is different from the [no_repeats]
    predicate in the exercise above; the sequence [1,4,1] repeats but
    does not stutter.) *)

Inductive nostutter:  list nat -> Prop :=
 (* FILL IN HERE *)
.

(** Make sure each of these tests succeeds, but you are free
    to change the proof if the given one doesn't work for you.
    Your definition might be different from mine and still correct,
    in which case the examples might need a different proof.

    The suggested proofs for the examples (in comments) use a number
    of tactics we haven't talked about, to try to make them robust
    with respect to different possible ways of defining [nostutter].
    You should be able to just uncomment and use them as-is, but if
    you prefer you can also prove each example with more basic
    tactics.  *)

Example test_nostutter_1:      nostutter [3;1;4;1;5;6].
(* FILL IN HERE *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_2:  nostutter [].
(* FILL IN HERE *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_3:  nostutter [5].
(* FILL IN HERE *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_4:      not (nostutter [3;1;1;4]).
(* FILL IN HERE *) Admitted.
(*
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H1; auto. Qed.
*)
(** [] *)

(** **** Exercise: 4 stars, advanced (pigeonhole principle) *)
(** The "pigeonhole principle" states a basic fact about counting:
   if you distribute more than [n] items into [n] pigeonholes, some
   pigeonhole must contain at least two items.  As is often the case,
   this apparently trivial fact about numbers requires non-trivial
   machinery to prove, but we now have enough... *)

(** First a pair of useful lemmas (we already proved these for lists
    of naturals, but not for arbitrary lists). *)

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma appears_in_app_split : forall (X:Type) (x:X) (l:list X),
  appears_in x l ->
  exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
  (* FILL IN HERE *) Admitted.

(** Now define a predicate [repeats] (analogous to [no_repeats] in the
   exercise above), such that [repeats X l] asserts that [l] contains
   at least one repeated element (of type [X]).  *)

Inductive repeats {X:Type} : list X -> Prop :=
  (* FILL IN HERE *)
.

(** Now here's a way to formalize the pigeonhole principle. List [l2]
    represents a list of pigeonhole labels, and list [l1] represents
    the labels assigned to a list of items: if there are more items
    than labels, at least two items must have the same label.  This
    proof is much easier if you use the [excluded_middle] hypothesis
    to show that [appears_in] is decidable, i.e. [forall x
    l, (appears_in x l) \/ ~ (appears_in x l)].  However, it is also
    possible to make the proof go through _without_ assuming that
    [appears_in] is decidable; if you can manage to do this, you will
    not need the [excluded_middle] hypothesis. *)

Theorem pigeonhole_principle: forall (X:Type) (l1  l2:list X),
   excluded_middle ->
   (forall x, appears_in x l1 -> appears_in x l2) ->
   length l2 < length l1 ->
   repeats l1.
Proof.
   intros X l1. induction l1 as [|x l1'].
  (* FILL IN HERE *) Admitted.
(** [] *)

(* FILL IN HERE *)

(* $Date: 2014-02-22 09:43:41 -0500 (Sat, 22 Feb 2014) $ *)


Require Import ZArith BinIntDef.

Local Open Scope Z_scope.

Theorem poly_congruence_pg_28 : ~(exists x, x * x - 117 * x + 31 = 0).
Proof.
  (** First establish that the constants we use (-117 and 31) are odd. *)
  assert (Zodd (-117)) as H117IsOdd. compute. auto.
  assert (Zodd 31) as H31IsOdd. compute. auto.
  (** We proceed with a proof by contradiction.  Support some x exists.  Then x^2 - 117*x must be even.  Therefore the polynomial is odd, and the result can cannot be zero. *)
  intro H.
  destruct H as [x H].
  (** We show a slightly different term is even because it makes the proof more straightforward. *)
  assert (Zeven (-117 * x + x * x)) as HVariableComboIsEven.
  (** We proceed by the case of whether x is even or odd. *)
  destruct (Zeven_odd_dec x) as [HXIsEven | HXIsOdd].
  (** If x is even, both x^2 and -117 * x must be even.  The sum of two evens is also even. **)
  - assert (Zeven (x * x)) as HXSquaredIsEven. apply (Zeven_mult_Zeven_l x x HXIsEven).
    assert (Zeven (-117 * x)) as HLinearTermIsEven. apply (Zeven_mult_Zeven_r (-117) x HXIsEven).
    apply (Zeven_plus_Zeven _ _ HLinearTermIsEven) in HXSquaredIsEven.
    assumption.
  (** If x is even, both x^2 and -117 * x must be odd.  The sum of two odds is also odd. **)
  - assert (Zodd (x * x)) as HXSquaredIsOdd. apply (Zodd_mult_Zodd x x HXIsOdd HXIsOdd).
    assert (Zodd (-117 * x)) as HLinearTermIsOdd. apply (Zodd_mult_Zodd (-117) x H117IsOdd HXIsOdd).
    apply (Zodd_plus_Zodd _ _ HLinearTermIsOdd) in HXSquaredIsOdd.
    assumption.
    (** Since the term x^2 + -117 * x) is even, the sum of it with 31 must be odd.
        However 0 cannot be odd, so there cannot be an x that relationship x^2 - 117 * x + 31. *)
  - apply (Zodd_plus_Zeven _ _ H31IsOdd) in HVariableComboIsEven.
    replace (31 + (-117 * x + x * x)) with (x * x - 117 * x + 31) in HVariableComboIsEven.
    rewrite H in HVariableComboIsEven.
    compute in HVariableComboIsEven. contradict HVariableComboIsEven.
    (** The replacement we used is easily proven with the ring tactic. *)
    ring.
Qed.


Require Import Arith.

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

#[export] Hint Constructors even : core.

Fixpoint mult2 (n:nat) : nat :=
  match n with
  | O => 0
  | S p => S (S (mult2 p))
  end.

Lemma mult2_even : forall n:nat, even (mult2 n).
Proof.
 induction n; simpl; auto.
Qed.

Theorem sum_even : forall n p:nat, even n -> even p -> even (n + p).
Proof.
 intros n p Heven_n; induction  Heven_n; simpl; auto.
Qed.

#[export] Hint Resolve sum_even : core.

Lemma square_even : forall n:nat, even n -> even (n * n).
Proof.
 intros n Hn; elim Hn; simpl; auto.
 intros n0 H0 H1; rewrite (mult_comm n0 (S (S n0))).
 right; simpl;apply sum_even; auto.
Qed.

Lemma even_mult2 : forall n:nat, even n -> (exists p, n = mult2 p).
Proof.
 induction 1.
 -  exists 0; reflexivity.
 -  destruct IHeven as [p Hp]; exists (S p); simpl; now rewrite Hp.
Qed.


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

Notation "0" := (O).
Notation "1" := (S 0).

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

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

Lemma plus_0_n : forall (n:nat), 0 + n = n.
Proof.
intros n. simpl. reflexivity.
Qed.

Lemma plus_n_0 : forall (n:nat), n + 0 = n.
Proof.
intros n. induction n as [|n IH].
    - simpl. reflexivity.
    - simpl. rewrite IH. reflexivity.
Qed.

Lemma plus_1_n : forall (n:nat), 1 + n = S n.
Proof.
intros n. simpl. reflexivity.
Qed.

Lemma plus_n_1 : forall (n:nat), n + 1 = S n.
Proof.
intros n. induction n as [|n IH].
    - simpl. reflexivity.
    - simpl. rewrite IH. reflexivity.
Qed.

Lemma plus_n_Sm : forall (n:nat)(m:nat), n + S m = S (n + m).
Proof.
intros n. induction n as [|n IH].
    - intros m. reflexivity.
    - intros m. simpl. rewrite IH. reflexivity.
Qed.


Require Export P01.

(** Given a boolean operator [beq] for testing equality of elements of
    some type [A], we can define a function [beq_list beq] for testing
    equality of lists with elements in [A].  Complete the definition
    of the [beq_list] function below.  To make sure that your
    definition is correct, prove the lemma [beq_list_true_iff]. *)

Fixpoint beq_list {A} (beq : A -> A -> bool)
         (l1 l2 : list A) : bool :=
  match l1, l2 with
  | [] , [] => true
  | _  , [] => false
  | [] , _  => false
  | h1 :: t1 , h2 :: t2 => if(beq h1 h2) then beq_list beq t1 t2 else false
  end.

Lemma beq_list_true_iff :
  forall A (beq : A -> A -> bool),
    (forall a1 a2, beq a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, beq_list beq l1 l2 = true <-> l1 = l2.
Proof.
  intros A beq H l1 l2. generalize dependent l2.
  induction l1 as [| h1 l1' IHl1']; induction l2 as [| h2 l2' IHl2'].
  - simpl. split; auto.
  - simpl. split; intros Hcontra; inversion Hcontra.
  - simpl. split; intros Hcontra; inversion Hcontra.
  - simpl. split; intros; destruct (beq h1 h2) eqn: Hbeq.
    + apply H in Hbeq. apply IHl1' in H0. subst. reflexivity.
    + inversion H0.
    + apply H in Hbeq. apply IHl1'. subst. inversion H0. reflexivity.
    + inversion H0. subst. rewrite <- Hbeq. apply H. reflexivity.
Qed.