Require Import Arith.
Require Import Arith.Max.

Require Import set.

(******************************************************************************)
(*                         order : set -> nat                                 *)
(******************************************************************************)

(* The map order : set -> nat is a measure of the 'syntactic complexity' of the
 * expression defining a set. It will be useful as a way to prove many results
 * allowing us to carry induction arguments based on the 'order' of a set.
 *
 * order(0)   = 0
 * order({x}) = 1 + order(x)
 * order(xUy) = 1 + max(order(x), order(y))
 *)

Fixpoint order (s:set) : nat :=
  match s with
    | Empty         => 0
    | Singleton x   => 1 + order x
    | Union x y     => 1 + max (order x) (order y)
  end.

(*  order(a) = 0  =>  a = 0  *)
Lemma order_eq_0 : forall (a:set), order a = 0 -> a = Empty.
Proof.
  intro a. elim a. auto. clear a. intro a. intro IH. intro H.
  simpl in H. discriminate H. clear a. intro a. intro IH. intro b. intro H.
  intro H'. simpl in H'. discriminate H'.
Qed.

(* order(a) + order(b) = 0  =>  a = 0  *)
Lemma order_sum_eq_0_l : forall (a b:set),
  order a + order b = 0 -> a = Empty.
Proof.
  intros a b H. apply order_eq_0.
  apply and_ind with (A:= order a = 0)(B:= order b = 0). trivial.
  apply plus_is_O. exact H.
Qed.

(* order(a) + order(b) = 0 =>  b = 0  *)
Lemma order_sum_eq_0_r : forall (a b:set),
  order a + order b = 0 -> b = Empty.
Proof.
  intros a b H. rewrite plus_comm in H. apply order_sum_eq_0_l
  with (b:=a). exact H.
Qed.

(* order({x}) + order(b) <= n+1  =>  order(x) + order(b) <= n  *)
Lemma order_sum_singleton_l : forall (n:nat) (x b:set),
  order (Singleton x) + order b <= S n ->
  order x + order b <= n.
Proof.
  intros n x b H. apply le_S_n. apply le_trans with
  (m:= order (Singleton x) + order b). simpl. apply le_n. exact H.
Qed.

(* order(a) + order({y}) <= n+1  =>  order(a) + order(y) <= n  *)
Lemma order_sum_singleton_r : forall (n:nat) (a y:set),
  order a + order (Singleton y) <= S n ->
  order a + order y <= n.
Proof.
  intros n a y H. rewrite plus_comm. apply order_sum_singleton_l.
  rewrite plus_comm in H. exact H.
Qed.

(* order({x}) + order({y}) <= n+1  =>  order(x) + order(y) < n *)
Lemma order_sum_singleton_strong : forall (n:nat) (x y:set),
  order (Singleton x) + order (Singleton y) <= S n ->
  order x + order y < n.
Proof.
  intros n x y H. unfold lt. apply le_S_n. apply le_trans with
  (m:= order (Singleton x) + order (Singleton y)). simpl.
  rewrite <- plus_Snm_nSm. simpl. reflexivity. exact H.
Qed.

(* This is a weakening of the previous result *)
(* order({x}) + order({y}) <= n+1  => order(x) + order(y) <= n *)
Lemma order_sum_singleton : forall (n:nat) (x y:set),
  order (Singleton x) + order (Singleton y) <= S n ->
  order x + order y <= n.
Proof.
  intros n x y H. apply le_S_n. apply le_S. fold (order x + order y < n).
  apply order_sum_singleton_strong. exact H.
Qed.

(* 'L' refers to where 'Union' stands in the sum
** while 'l' refers to the left argument of Union *)
Lemma order_sum_union_Ll : forall (n:nat) (x y b:set),
  order (Union x y) + order b <= S n ->
  order x + order b <= n.
Proof.
  intros n x y b H. apply le_S_n. apply le_trans with
  (m:= order (Union x y) + order b). simpl. apply le_n_S.
  apply plus_le_compat_r. simpl. apply le_max_l. exact H.
Qed.

(* same proof, but use le_max_r instead of le_max_l *)
Lemma order_sum_union_Lr : forall (n:nat) (x y b:set),
  order (Union x y) + order b <= S n ->
  order y + order b <= n.
Proof.
  intros n x y b H. apply le_S_n. apply le_trans with
  (m:= order (Union x y) + order b). simpl. apply le_n_S.
  apply plus_le_compat_r. simpl. apply le_max_r. exact H.
Qed.

(* consequence of 'Ll' lemma and commutativity *)
Lemma order_sum_union_Rl : forall (n:nat) (a y z:set),
  order a + order (Union y z) <= S n ->
  order a + order y <= n.
Proof.
  intros n a y z H. rewrite plus_comm. apply order_sum_union_Ll
  with(x:= y)(y:=z). rewrite plus_comm in H. exact H.
Qed.

(* consequence of 'Lr' lemma and commutativity *)
Lemma order_sum_union_Rr : forall (n:nat) (a y z:set),
  order a + order (Union y z) <= S n ->
  order a + order z <= n.
Proof.
  intros n a y z H. rewrite plus_comm. apply order_sum_union_Lr
  with(x:= y)(y:=z). rewrite plus_comm in H. exact H.
Qed.


(** * More Logic *)

Require Export "Prop".
Require Import Le.

(* ############################################################ *)
(** * 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? *)

(* FILL IN HERE *)

(*
*)
(** **** 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 as [x Hx]. apply Hx. 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.
  intros. unfold excluded_middle in H. destruct H with (P x).
  - apply H1.
  - unfold not in H0. apply ex_falso_quodlibet. apply H0.
    exists x. fold (not (P x)). apply H1.
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.
  split.
  - intros. destruct H as [x Hx]. destruct Hx.
    + left. exists x. apply H.
    + right. exists x. apply H.
  - intros. destruct H.
    + destruct H as [x Hx]. exists x. left. apply Hx.
    + destruct H as [x Hx]. exists x. right. apply Hx.
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 :=
| all_nil  : all X P []
| all_cons : forall (x : X) (xs : list X), P x -> all X P xs -> all X P (x :: xs)
.

(** 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 all_forallb :
  forall (X:Type) (xs:list X) (test : X -> bool),
    forallb test xs = true <-> all X (fun x => test x = true) xs.
Proof.
  intros. split.
  - intros. induction xs as [|t ts].
    + apply all_nil.
    + simpl in H. apply all_cons.
      * apply andb_true_elim1 in H. apply H.
      * apply IHts. apply andb_true_elim2 in H. apply H.
  - intros. induction H as [|t ts HP A].
    + reflexivity.
    + simpl. rewrite HP. simpl. apply IHA.
Qed.

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

(** **** 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 :=
| merge_nil : in_order_merge [] [] []
| merge_fst : forall (x : X) (xs ys zs : list X),
                in_order_merge xs ys zs -> in_order_merge (x :: xs) ys (x :: zs)
| merge_snd : forall (y : X) (xs ys zs : list X),
                in_order_merge xs ys zs -> in_order_merge xs (y :: ys) (y :: zs).

Theorem filter_spec_1 :
  forall (X:Type) (test : X -> bool) (l : list X) (lt : list X) (lf : list X),
    (forallb test lt = true) -> (forallb (fun x => negb (test x)) lf = true) ->
    in_order_merge lt lf l -> filter test l = lt.
Proof.
  intros X test l lt lf Pt Pf IM. induction IM as [|x xs ys zs M IHM|y xs ys zs M IHM].
  - reflexivity.
  - simpl. simpl in Pt. assert (test x = true) as C.
    + apply andb_true_elim1 in Pt. apply Pt.
    + rewrite C. apply f_equal. apply IHM.
      * apply andb_true_elim2 in Pt. apply Pt.
      * apply Pf.
  - simpl. simpl in Pf. assert (test y = false) as C.
    + apply andb_true_elim1 in Pf. rewrite <- negb_involutive with (test y).
      rewrite Pf. reflexivity.
    + rewrite C. apply IHM.
      * apply Pt.
      * apply andb_true_elim2 in Pf. apply Pf.
Qed.

(** [] *)

(** **** 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. *)

Inductive sub_satisfy {X:Type} (f:X -> bool) : list X -> list X -> Prop :=
| sub_nil : sub_satisfy f [] []
| sub_f   : forall (x : X) (xs ls: list X),
              sub_satisfy f xs ls -> (f x = true) -> sub_satisfy f (x :: xs) (x :: ls)
| sub_skip : forall (l : X) (xs ls : list X),
               sub_satisfy f xs ls -> sub_satisfy f xs (l :: ls).

Theorem filter_is_sub_satisfy :
  forall (X:Type) (l:list X) (test:X -> bool),
    sub_satisfy test (filter test l) l.
Proof.
  intros. induction l as [|h t].
  - simpl. apply sub_nil.
  - simpl. destruct (test h) eqn:C.
    + apply sub_f. apply IHt. apply C.
    + apply sub_skip. apply IHt.
Qed.

Theorem filter_spec_2 :
  forall (X:Type) (xs:list X) (l:list X) (f:X -> bool),
    sub_satisfy f xs l ->
    length xs <= length (filter f l).
Proof.
  intros. induction H as [|x xs ls S IS f_true|l xs ls S IS].
  - reflexivity.
  - simpl. rewrite f_true. simpl. apply le_n_S. apply IS.
  - simpl. destruct (f l) eqn:C.
    + simpl. apply le_S. apply IS.
    + apply IS.
Qed.
(** [] *)

(** **** 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.
  intros. induction xs as [|t ts].
  - right. apply H.
  - simpl in H. inversion H.
    + left. apply ai_here.
    + destruct IHts.
      * apply H1.
      * left. apply ai_later.  apply H3.
      * right. apply H3.
Qed.

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.
  intros. destruct H.
  - induction H.
    + apply ai_here.
    + simpl. apply ai_later. apply IHappears_in.
  - induction xs as [|h t].
    + simpl. apply H.
    + simpl. apply ai_later. apply IHt.
Qed.

(** 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. *)

Definition disjoint (X:Type) (xs ys:list X) :=
  forall x : X, appears_in x xs -> ~(appears_in x ys).

(** 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.  *)

Inductive no_repeats (X:Type) : list X -> Prop :=
| nr_nil : no_repeats X []
| nr_cons : forall (x : X) (xs : list X),
              ~(appears_in x xs) -> no_repeats X xs -> no_repeats X (x :: xs).

Example no_repeats_ex1 : no_repeats nat [1;2;3;4].
Proof.
  apply nr_cons.
  unfold not. intros. inversion H. inversion H1. inversion H4. inversion H7.
  apply nr_cons.
  unfold not. intros. inversion H. inversion H1. inversion H4.
  apply nr_cons.
  unfold not. intros. inversion H. inversion H1.
  apply nr_cons.
  unfold not. intros. inversion H.
  apply nr_nil.
Qed.

Example no_repeats_ex2 : ~ no_repeats nat [1;2;1].
Proof.
  unfold not. intros. inversion H. unfold not in H2. apply H2.
  apply ai_later. apply ai_here.
Qed.

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

Theorem not_appears_in_app :
  forall (X:Type) (x:X) (xs ys:list X),
    ~ appears_in x xs -> ~ appears_in x ys -> ~ appears_in x (xs ++ ys).
Proof.
  intros. unfold not. intros. apply appears_in_app in H1. destruct H1.
  - apply H. apply H1.
  - apply H0. apply H1.
Qed.

Theorem disjoint_no_repeats_app :
  forall (X:Type) (xs ys:list X),
    disjoint X xs ys -> no_repeats X xs -> no_repeats X ys -> no_repeats X (xs ++ ys).
Proof.
  intros X xs. induction xs as [|h t].
  - intros. simpl. apply H1.
  - intros. simpl. apply nr_cons. unfold disjoint in H. apply not_appears_in_app.
    + inversion H0. apply H4.
    + apply H. apply ai_here.
    + apply IHt.
      * unfold disjoint. unfold disjoint in H. intros. apply H. apply ai_later. apply H2.
      * inversion H0. apply H5.
      * apply H1.
Qed.

Theorem no_repeats_split_disjoint :
  forall (X:Type) (xs ys:list X),
    no_repeats X (xs ++ ys) -> disjoint X xs ys.
Proof.
  intros X xs ys NR_xs_ys. unfold disjoint. unfold not. intros x x_ai_xs x_ai_ys.
  induction x_ai_xs.
  + inversion NR_xs_ys. apply H1. apply app_appears_in. right. apply x_ai_ys.
  + apply IHx_ai_xs. inversion NR_xs_ys. apply H2.
Qed.

(** [] *)

(** **** 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 :=
| ns_nil  : nostutter []
| ns_unit : forall n:nat, nostutter [n]
| ns_cons : forall (n x:nat) (xs:list nat),
              nostutter (x :: xs) -> beq_nat x n = false -> nostutter (n :: x :: xs).

(** 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].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_2:  nostutter [].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_3:  nostutter [5].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_4:      not (nostutter [3;1;1;4]).
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  apply beq_nat_false in H5; contradiction H5; 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.
  intros X l1. induction l1 as [|h t].
  - intros. reflexivity.
  - intros. simpl. apply f_equal. apply IHt.
Qed.

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.
  intros. induction H.
  - exists nil. exists l. reflexivity.
  - destruct IHappears_in as [l1 Hl1].
    destruct Hl1 as [l2 Hl2].
    exists (b :: l1). exists l2. simpl. apply f_equal. apply Hl2.
Qed.

(** 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 :=
  | cons_rep : forall (x:X) (xs:list X), appears_in x xs -> repeats (x :: xs)
  | cons_any : forall (x:X) (xs:list X), repeats xs      -> repeats (x :: xs).

(** 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 app_nil_r : forall (T:Type) (xs:list T), xs ++ [] = xs.
Proof.
  induction xs as [|xh xt].
  reflexivity.
  simpl. apply f_equal. apply IHxt.
Qed.

Theorem snoc_cons_app :
  forall (T:Type) (x:T) (xs ys:list T), snoc xs x ++ ys = xs ++ x :: ys.
Proof.
  intros. induction xs as [|h t].
  - reflexivity.
  - simpl. apply f_equal. rewrite IHt. reflexivity.
Qed.

Theorem pigeonhole_principle: forall (X:Type) (l1  l2:list X),
   (forall x, appears_in x l1 -> appears_in x l2) ->
   length l2 < length l1 ->
   repeats l1.
Proof.
(* todo *)
Admitted.

Example ex_pigeonhole : repeats [1; 2; 1].
Proof.
  apply pigeonhole_principle with [1; 2].
  intros. inversion H.
  - apply ai_here.
  - inversion H1.
    + apply ai_later. apply ai_here.
    + inversion H4. apply ai_here. inversion H7.
  - unfold lt. simpl. apply le_n.
Qed.

(** [] *)

(* FILL IN HERE *)

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


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

(* The final goal of the exercise is to implement a dictionary (aka map).
   We'll do this incrementally by defining auxiliary functions and testing them. *)

Require Import List.
Import ListNotations.

(* The mechanism of sections allows to modularize the proof in multiple ways.
   We'll see its applications along the way. *)
Section NatEq.

  (* Implement a function that checks the equality of two natural numbers.
     Use pattern matching and recursion. *)
  Fixpoint nat_eq (x y: nat): bool
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* We're not _proving_ that our implementations are correct yet,
     but we can still test them on some inputs. *)
  (* Do not modify these test suits. *)
  (* Try to understand the meaning of the 'nat_eq_tests' definition. *)
  (* To do that, you may want to investigate the 'forallb': *)
  Print forallb.
  Let nat_eq_tests := forallb id
                       [ nat_eq 0 0;
                         negb (nat_eq 0 1);
                         negb (nat_eq 10 0);
                         nat_eq 10 10;
                         negb (nat_eq 10 13) ].

  (* Do not modify these '*_pass' definitions and proofs.  *)
  (* If your implementations are correct, the execution of them should proceed, *)
  (* otherwise an error should occur.  *)
  Let nat_eq_tests_pass: nat_eq_tests = true.
  Proof. tauto. Qed.

  (* Now try to remove one of 'negb' in 'nat_eq_tests' definitions *)
  (* and execute nat_eq_tests_pass. *)
  (* Don't forget to restore the initial state of 'nat_eq_tests'. *)

End NatEq.

(* The section hides 'Let' definitions. *)
Fail Print nat_eq_tests_pass.
Print nat_eq.

Section Option.

  (* A value of 'option' type instantiated with an arbitrary type A
     contains either a value of the type A or a special value None. *)
  Print option.

  (* Implement a function that checks if an optional actually contains a value. *)
  (* Use 'if-then-else' syntax: *)
  (* For a value 't' of an inductive type T with exactly two constructors T1 and T2,
     an expression 'if t then X1 else X2' is equivalent to
     'match t with
      | T1 => X1
      | T2 => X2
      end' *)
  Definition has_some {A: Type} (o: option A) : bool
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  Let has_some_tests := forallb id
                       [
                         (* here A = nat is inferred because of (1: nat) *)
                         has_some (Some 1);
                       (* note that without an argument we can't automatically infer the type *)
                         negb (has_some (@None nat));
                         has_some (Some (@None bool))
                       ].

  Let has_some_tests_pass: has_some_tests = true.
  Proof. tauto. Qed.

  (* Implement a function that compares two optional natural numbers. *)
  (* Reuse the nat_eq you've defined before *)
  Definition option_nat_eq (o1 o2: option nat) : bool
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  Let option_nat_eq_tests := forallb id
                                     [option_nat_eq None None;
                                     negb (option_nat_eq (Some 5) None);
                                     option_nat_eq (Some 5) (Some 5)
                                     ].

  Let option_nat_eq_tests_pass: option_nat_eq_tests = true.
  Proof. tauto. Qed.

End Option.

Section FunUpd.

  (* A handy primitive we'll use below is the function update. *)
  (* Essentially, we'd like to take a function and override its value on a single input. *)
  (* Here we'll only concentrate on functions whose input type is nat,
     but which are still polymorphic on the output type. *)
  (* Implement the function update using if-then-else expression and nat_eq. *)
  Definition upd {V: Type} (f: nat -> V) (x: nat) (y: V): nat -> V
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  Let upd_tests := forallb id
                           [
                             nat_eq ((upd id 5 3) 5) 3;
                             nat_eq ((upd (upd id 5 3) 5 7) 5) 7;
                             nat_eq ((upd id 5 3) 123) 123;
                             nat_eq ((upd (upd id 5 3) 7 10) 5) 3
                           ].

  Let upd_tests_pass: upd_tests = true.
  Proof. tauto. Qed.

End FunUpd.

Section NatDict.
  (* Now we're ready to provide the first implementation of a dictionary. *)
  (* We'll work with dictionaries whose keys are natural numbers
     and values have an arbitrary (but uniform) type. *)

  (* Remember that in previous sections we had to specify arguments like '{A: Type}' to keep the definitions polymorphic. *)
  (* Instead of repeating them, we can specify that a particular type is a common argument for all functions in this section. *)
  Context {V: Type}.

  (* The first implementation of dictionary is based on partial functions. *)
  (* Remember that in Coq all functions are total,
     that is, the function should return a value for all inputs. *)
  (* If we're to implement a dictionary with a total function, it wont' be clear
     how to represent a missing value. *)
  (* But the absence of a value is naturally represented with None,
     while a value 'v' contained in a dictionary can be wrapped in 'Some v' *)
  Definition nat_dict_fun := nat -> option V.
  Print nat_dict_fun. (* Note that here V is fixed *)

  (* Implement a function that creates an empty dictionary *)
  Definition new_dict' : nat_dict_fun
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement an insertion using the 'upd' construct. *)
  Definition insert' (d: nat_dict_fun) (k: nat) (v: V) : nat_dict_fun
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement a deletion similarly. *)
  Definition remove' (d: nat_dict_fun) (k: nat) : nat_dict_fun
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement a function that retrieves a value by key. *)
  (* Note that here the usage of option as a return type
     is not due to the partial function implementation,
     but rather due to a common sense:
     if a dictionary (with an arbitrary implementation) doesn't contain a value,
     a retrieval method should somehow reflect it. *)
  Definition get' (d: nat_dict_fun) (k: nat) : option V
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement a function that checks the presence of a given key. *)
  (* You can either reuse existing dict methods or write an independent implementation. *)
  Definition contains' (d: nat_dict_fun) (k: nat): bool
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

End NatDict.

Section NatDictTests.

  Print nat_dict_fun. (* note that now nat_dict_fun is polymorphic on value type *)

  (* To save some space we'll define common terms and reuse them
     with 'let .. in ..' syntax. *)
  Let tests :=
    (* Note that we must specify the value type for an empty dictionary,
       since there are no arguments which can be used to infer it *)
    let new := @new_dict' nat in
    let ins5 := insert' new 5 10 in
    let ins5ins5 := insert' ins5 5 15 in
    let ins5rm5 := remove' ins5 5 in
    let ins5ins5rm5 := remove' ins5ins5 5 in
    forallb id
                       [
                         negb (contains' new 5);
                         contains' ins5 5;
                         contains' ins5ins5 5;
                         negb (contains' ins5rm5 5);
                         negb (contains' ins5ins5rm5 5);
                         option_nat_eq (get' new 5) None;
                         option_nat_eq (get' ins5 5) (Some 10);
                         option_nat_eq (get' ins5ins5 5) (Some 15);
                         option_nat_eq (get' ins5ins5rm5 5) None;
                         option_nat_eq (get' ins5 3) None
                       ].

  Let nat_dict_fun_tests_pass: tests = true.
  Proof. tauto. Qed.

End NatDictTests.

Section NatDict'.
  Context {V: Type}.

  (* The other implementation of a dictionary is based on a list
     that stores pairs of keys and values. *)
  (* If there are multiple pairs with the same key,
     the one closer to the list head is used. *)

  (* '*' in context of types means the product (aka pair) type. *)
  Definition nat_dict_list := list (nat * V).

  (* Since the functions below operate on list which is defined inductively,
     some of them should also be inductively defined. *)

  (* Implement a function that creates an empty dictionary. *)
  Definition new_dict'' : nat_dict_list
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the insertion *)
  Definition insert'' (d: nat_dict_list) (k: nat) (v: V) : nat_dict_list
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the deletion. *)
  (* Mind the case when the list contain multple occurences of the same key. *)
  (* You may find useful that a pattern to be matched can be complex: *)
  (*    '(k, v) :: d'     destructs the list into the head and tail (named d')
     and, additionally, destructs the head into the key 'k' and value 'v' *)
  Fixpoint remove'' (d: nat_dict_list) (k: nat) : nat_dict_list
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the retrieval function. *)
  Fixpoint get'' (d: nat_dict_list) (k: nat) : option V
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the check for key presence. *)
  Fixpoint contains'' (d: nat_dict_list) (k: nat): bool
  . Admitted.
 (* Replace the previous line with ':= (your implementation) . ' *)

End NatDict'.

Section NatDict'Tests.

  (* The tests here are the same as for the previous implementation. *)
  Let tests :=
    let new := @new_dict'' nat in
    let ins5 := insert'' new 5 10 in
    let ins5ins5 := insert'' ins5 5 15 in
    let ins5rm5 := remove'' ins5 5 in
    let ins5ins5rm5 := remove'' ins5ins5 5 in
    forallb id
                       [
                         negb (contains'' new 5);
                         contains'' ins5 5;
                         contains'' ins5ins5 5;
                         negb (contains'' ins5rm5 5);
                         negb (contains'' ins5ins5rm5 5);
                         option_nat_eq (get'' new 5) None;
                         option_nat_eq (get'' ins5 5) (Some 10);
                         option_nat_eq (get'' ins5ins5 5) (Some 15);
                         option_nat_eq (get'' ins5ins5rm5 5) None;
                         option_nat_eq (get'' ins5 3) None
                       ].

  Let nat_dict_list_tests_pass: tests = true.
  Proof. tauto. Qed.

End NatDict'Tests.

(* The tasks below are additional and not required. *)

(* As you can see, these two implementations comply to the same interface. *)
(* Yet, since their types are different, we had to write separate test suites,
   despite they're essentially the same. *)
(* Functional languages allow to specify a general interface with typeclasses. *)
Section DictGeneral.

  (* General interface for a dict polymorphic on value type. *)
  (* This actually defines a type whose elements are interface implementations. *)
  Class Dict := {
    D: Type -> Type;
    new_dict: forall (V: Type), D V;
    insert: forall {V: Type}, (D V) -> nat -> V -> (D V);
    remove: forall {V: Type}, (D V) -> nat -> (D V);
    get: forall {V: Type}, (D V) -> nat -> option V;
    contains: forall {V: Type}, (D V) -> nat -> bool;
  }.

  (* Now we can specify expected behavior on the level of this interface. *)
  (* The argument is an arbitrary dict implementation. *)
  Let dict_tests (DictImpl: Dict) : bool :=
    let new := @new_dict DictImpl nat in
    let ins5 := insert new 5 10 in
    let ins5ins5 := insert ins5 5 15 in
    let ins5rm5 := remove ins5 5 in
    let ins5ins5rm5 := remove ins5ins5 5 in
    forallb id
                       [
                         negb (contains new 5);
                         contains ins5 5;
                         contains ins5ins5 5;
                         negb (contains ins5rm5 5);
                         negb (contains ins5ins5rm5 5);
                         option_nat_eq (get new 5) None;
                         option_nat_eq (get ins5 5) (Some 10);
                         option_nat_eq (get ins5ins5 5) (Some 15);
                         option_nat_eq (get ins5ins5rm5 5) None;
                         option_nat_eq (get ins5 3) None
                       ].

  (* Now we can state that our function-based implementation
     complies to Dict interface. *)
  Instance FunDict: Dict := {
    D := @nat_dict_fun;
    new_dict := @new_dict';
    insert := @insert';
    remove := @remove';
    get := @get';
    contains := @contains';
  }.

  (* Define instance of Dict class for the list-based implementation. *)

      (* place your code here *)

  (* Then, state and prove 'fun_dict_tests' and 'list_dict_tests' lemmas
     by instantiating 'dict_tests' with instances you've just created.
     These lemmas, as before, should be proved just by 'tauto'. *)

      (* place your code here *)

End DictGeneral.


Require Import Arith.
Require Import Omega.
Require Import Recdef.

Module Pset1Bnat.

  (* In this module, you'll prove some facts about *binary*
     numbers, rather than Coq's default unary numbers.
     We'll start out with some useful lemmas. *)
  Lemma double_eq (n m:nat) : n + n = m + m <-> n = m.
  Proof. omega. Qed.

  Lemma double_lt (n m:nat) : n + n < m + m <-> n < m.
  Proof. omega. Qed.

  Lemma double_lt_n_Sm (n m:nat) : n + n < S (m + m) <-> n < S m.
  Proof. omega. Qed.

  (* The `clean_arithmetic` tactic cleans up a lot of arithmetic
     identities typically occurring in these problems.
     It replaces `x + 0` with `x`, `S x = S y` with `x = y`, and
     `x + x = y + y` with `x = y`. *)
  Ltac clean_arithmetic :=
    repeat match goal with
      | [H : context[_ + 0] |- _] => rewrite Nat.add_0_r in H
      | [ |- context[_ + 0] ] => rewrite Nat.add_0_r
      | [H : context[?a + ?a = ?b + ?b] |- _] => rewrite double_eq in H
      | [ |- context[?a + ?a = ?b + ?b] ] => rewrite double_eq
      | [H : context[S _ = S _] |- _] => apply eq_add_S in H
      | [ |- context[S _ = S _] ] => apply eq_S
    end.

  (* Coq's Peano arithmetic defines natural numbers inductively,
     based on two constructors: 0 and successor. So 10 is defined
     as a structure of length 11:
     (S (S (S (S (S (S (S (S (S (S Z)))))))))))
     And in general N is defined in a structure of length O(N).

     We're going to work with natural numbers based on *three*
     constructors. That will lead to numbers defined in structures
     of length O(log_2 N). *)

  Inductive bnat : Type :=
    | BZ : bnat              (* Zero *)
    | BD1 : bnat -> bnat     (* BD1 X is the number 2*X + 1 *)
    | BD2 : bnat -> bnat.    (* BD2 X is the number 2*X + 2 *)

  (* EXERCISE: Write a function that computes the conventional
     (Peano) value of bnat `b`. *)
  Function bval (b:bnat) : nat :=
    0.

  (* EXERCISE: Prove that if `bval b = 0`, then `b = BZ`. *)
  Lemma bval_zero (b:bnat) :
    bval b = 0 -> b = BZ.
  Proof.
  Abort.

  (* EXERCISE: Prove that every natural number has a unique
     binary representation. *)
  Lemma bval_uniq (b c:bnat) :
    bval b = bval c -> b = c.
  Proof.
    (* Your first tactic should be `generalize c`.
       Don't forget `discriminate`, `clean_arithmetic`, and `omega`. *)
    generalize c.
  Abort.

  (* EXERCISE: Write a function that returns the successor of `b`.
     You'll want to work this out on paper first, and there will
     be at least one recursive call to `bsucc`. *)
  Function bsucc (b:bnat) : bnat :=
    0.

  (* EXERCISE: Prove that your `bsucc` is correct. *)
  Lemma bsucc_correct (b:bnat) :
    bval (bsucc b) = S (bval b).
  Proof.
    (* If regular induction doesn't work, try
       `functional induction (bval b)`, which runs induction over the
       cases of the `bval` function. *)
  Abort.

  (* This function returns the length of a binary number. *)
  Function blen (b:bnat) : nat :=
    match b with
    | BZ => 0
    | BD1 b' => S (blen b')
    | BD2 b' => S (blen b')
    end.

  (* The sum of the lengths of two binary numbers in a pair. *)
  Definition bpairlen (x:bnat*bnat) : nat :=
    blen (fst x) + blen (snd x).

  (* EXERCISE: Write a function that adds two binary numbers.
     You'll want to work this out on paper first too. Everything
     works out easier if the numbers are passed in a pair; you
     can decompose the pair with `fst` and `snd` (Check them),
     or with matching.

     After writing the function, you'll need to prove that its
     recursion terminates. Do that too. *)
  Function baddpair (x:bnat*bnat) {measure bpairlen x} : bnat :=
    0.
  (* Proof. ... Qed. *)

  (* A more conventional adder function: *)
  Definition badd (x y:bnat) := baddpair (x,y).

  (* EXERCISE: Prove that your add function is correct. *)
  Lemma baddpair_correct (x:bnat*bnat) :
    bval (baddpair x) = bval (fst x) + bval (snd x).
  Proof.
  Abort.

  (* EXERCISE: Write a function that determines whether
     `fst x < snd x`. Return either False or True. *)
  Function blesspair (x:bnat*bnat) {measure bpairlen x} : Prop :=
    True.
  (* Proof. ... Qed. *)

  Definition bless (x y:bnat) : Prop := blesspair (x,y).

  (* EXERCISE: Prove that `blesspair` is correct.
     For me this was the hardest proof in this module. *)
  Lemma blesspair_correct (x:bnat*bnat) :
    bval (fst x) < bval (snd x) <-> blesspair x.
  Proof.
  Abort.

End Pset1Bnat.


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

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

Compute pred (S(S O)).

Compute pred (S(S(S(S(S(S(S(S(S(S(S(S(S(S(S O))))))))))))))).

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

Compute plus (S O)(S O).

Fixpoint leb (x y : nat) : bool :=
  match x with
   | O => true
   | S x' => match y with
              | O => false
              | S y' => leb x' y'
               end
end.

Fixpoint mult (x y : nat) : nat :=
  match x with
   | O => O
   | S x => plus x (mult x y)
end.

Lemma plus_O x : plus x O = x.
Proof.
induction x; simpl.
reflexivity.
rewrite IHx.
reflexivity.
Qed.

Lemma plus_S x y : plus x (S y) = S (plus x y).
Proof.
induction x; simpl.
reflexivity.
rewrite IHx.
reflexivity.
Qed.

Lemma plus_com x y : plus x y = plus y x.
Proof.
induction x; simpl.
rewrite plus_O; reflexivity.
rewrite plus_S; rewrite IHx.
reflexivity.
Qed.

Lemma plus_asso x y z : plus (plus x y) z = plus x (plus y z).
Proof.
induction x; simpl.
reflexivity.
rewrite IHx.
reflexivity.
Qed.

Print plus_asso.

Require Import Omega.

Lemma plus_AC x y z : plus y (plus x z) = plus (plus z y) x.
Proof.
setoid_rewrite plus_com at 3.
setoid_rewrite plus_com at 1.
apply plus_asso.
Qed.


Require Import Arith.

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

Hint Constructors even.

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.

Hint Resolve sum_even.

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.


(** Exercise sheet for lecture 4: Tactics in Coq.

Written by Ralph Matthes (CNRS, IRIT, Univ. Toulouse, France).
 *)

(** * Exercise 1
Formalize the following types in UniMath and construct elements for them interactively -
if they exist. Give a counter-example otherwise, i.e., give specific parameters and a
proof of the negation of the statement.

[[
1.    A × (B + C) → A × B + A × C, given types A, B, C
2.    (A → A) → (A → A), given type A (for extra credit, write down five elements of this type)
3.    Id_nat (0, succ 0)
4.    ∑ (A : Universe) (A → empty) → empty
5.    ∏ (n : nat), ∑ (m : nat), Id_nat n (2 * m) + Id_nat n (2 * m + 1),
      assuming you have got arithmetic
6.    (∑ (x : A) B × P x) → B × ∑ (x : A) P x, given types A, B, and P : A → Universe
7.    B → (B → A) → A, given types A and B
8.    B → ∏ (A : Universe) (B → A) → A, given type B
9.    (∏ (A : Universe) (B → A) → A) → B, given type B
]]

More precise instructions and hints:

1.  Use [⨿] in place of the + and pay attention to operator precedence.

2.  Write a function that provides different elements for any natural number argument,
    not just five elements; for extra credits: state correctly that they are different -
    for a good choice of [A]; for more extra credits: prove that they are different.

3.  An auxiliary function may be helpful (a well-known trick).

4.  The symbol for Sigma-types is [∑], not [Σ].

5.  Same as 1; and there is need for module [UniMath.Foundations.NaturalNumbers], e.g.,
    for Lemma [natpluscomm].

6.-9. no further particulars
*)

Require Import UniMath.Foundations.Preamble.
Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.NaturalNumbers.

(** * Exercise 2
Define two computable strict comparison operators for natural numbers based on the fact
that [m < n] iff [n - m <> 0] iff [(m+1) - n = 0]. Prove that the two operators are
equal (using function extensionality, i.e., [funextfunStatement] in the UniMath library).

It may be helpful to use the definitions of the exercises for lecture 2.
The following lemmas on substraction [sub] in the natural numbers may be
useful:

a) [sub n (S m) = pred (sub n m)]

b) [sub 0 n = 0]

c) [pred (sub 1 n) = 0]

d) [sub (S n) (S m) = sub n m]

*)

(** from exercises to Lecture 2: *)
Definition ifbool (A : UU) (x y : A) : bool -> A :=
  bool_rect (λ _ : bool, A) x y.

Definition negbool : bool -> bool := ifbool bool false true.

Definition nat_rec (A : UU) (a : A) (f : nat -> A -> A) : nat -> A :=
  nat_rect (λ _ : nat, A) a f.

Definition pred : nat -> nat := nat_rec nat 0 (fun x _ => x).

Definition is_zero : nat -> bool := nat_rec bool true (λ _ _, false).

Definition iter (A : UU) (a : A) (f : A → A) : nat → A :=
  nat_rec A a (λ _ y, f y).

Notation "f ̂ n" := (λ x, iter _ x f n) (at level 10).

Definition sub (m n : nat) : nat := pred ̂ n m.


Add LoadPath "~/cpdt/src".

Require Import CpdtTactics.

(** propositional logic *)

(* (10 minutes) Propositional logic often comes with an A <=> B form that is
true when A and B have the same truth values. Show how to define "iff" as
a Coq Prop. *)

Definition iff' (a b : Prop) := a -> b /\ b -> a.

Notation "a <=> b" := (iff' a b) (at level 77, right associativity).
Hint Unfold iff'.

Theorem iff'_refl : forall P : Prop, P <=> P.
  auto.
Qed.

Theorem iff'_sym : forall P Q : Prop, (P <=> Q) <=> (Q <=> P).
  auto.
Qed.

(* How automated can you make these proofs? *)

(* (15 minutes) In college-level logic classes, we learn that implication can
be expressed in terms of not and or operations (rather than in terms of
forall). *)
Definition implies (A B : Prop) : Prop := ~A \/ B.
Notation "a => b" := (implies a b) (at level 75, right associativity).
Hint Unfold implies.

(* One might wonder whether this form of implication is "the same as" Coq's
version that uses forall. State two theorems claiming that each kind of
implication can be converted into the other. Which one(s) can you prove? *)

Theorem imp1 : forall A B : Prop, (A => B) -> (A -> B).
Proof.
  intros. unfold implies in H. intuition.
Qed.

(*
Can't prove:
Theorem imp2 : forall A B : Prop, (A -> B) -> (A => B).
Proof.
  intros. unfold implies. intuition.
Qed.
*)

(* How about... *)
Axiom nowai : forall P : Prop, P \/ ~P.
(* ...now? *)

Theorem imp2 : forall A B : Prop, (A -> B) -> (A => B).
Proof.
  intros. unfold implies. destruct (nowai A); intuition.
Qed.

(* Some handy imports:
   Arith gives us nat, *, and +
   Arith.Even gives us even and odd
   Arith.Div2 gives us div2
*)
Require Import Arith.
Require Import Arith.Even.
Require Import Arith.Div2.
Set Implicit Arguments.
Hint Constructors even odd.

(** propositions with implicit equality *)

(* (35 minutes) The Collatz sequence starting at n is defined as the infinite
sequence obtained by iterating the step function:

step(n) = n/2  if n is even
step(n) = 3n+1 if n is odd

For example, the sequence starting at 11 looks like

11, 34, 17, 52, 26, 13, 40, 20, ...

It is conjectured that all collatz sequences eventually cycle (and in
particular reach 1 if they weren't 0 to begin with). Create an inductive
proposition collatz_cycles which expresses the fact that a particular nat
eventually reaches a cycle, then state and prove the fact that the collatz
sequence starting at 5 eventually cycles.

Don't forget about "Hint Constructors" and "auto n" when creating proofs about
constants!
*)

Definition step n :=
  if even_odd_dec n
  then div2 n
  else 3 * n + 1.

Inductive cycles : nat -> Prop :=
| cycles_1 : cycles 1
| cycles_step : forall n, cycles (step n) -> cycles n
.
Hint Constructors cycles.

Theorem cycles_5 : cycles 5.
Proof.
  (* 5 -> 16 -> 8 -> 4 -> 2 -> 1 : 5 step + 1 *)
  auto 6.
Qed.

(* (45 minutes) We say a list A is a "subsequence" of a list B when you can
produce list A by deleting some elements from list B.  For example, [1,2,3] is
a subsequence of each of the lists
[1,2,3]
[1,1,1,2,2,3]
[1,2,7,3]
[5,6,1,9,9,2,7,3,8]
but it is not a subsequence of any of the lists:
[1,2]
[1,3]
[5,6,2,1,7,3,8]

Define an inductive proposition subsequence that captures what it means to be
a subsequence, then prove that subsequence is transitive. Some hints on
automating this proof:

1. Use Hint Constructors to add your inductive proposition's constructors to
the hint database.
2. Choose which thing you do induction on carefully!
3. Try "crush" and look where it fails -- then add that as a lemma and put it
in your rewriting database. For example, on my first attempt, crush died here
first:

  A : Type
  l1 : list A
  H : subsequence l1 nil
  l : list A
  ============================
   subsequence l1 l

So I added a lemma:

Lemma subsequence_nil_anything : forall A (l1 l2 : list A),
    subsequence l1 nil -> subsequence l1 l2.
(* ... ;-) *)
Qed.

Hint Resolve subsequence_nil_anything.

That let crush get a bit farther, and suggested the next lemma I would need to
prove.
*)

(* I'm not really sure why we're not getting this notation for free, actually.
But we're not, se here it is for convenience. *)
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Inductive subsequence {T : Type} : list T -> list T -> Prop :=
| subnil   : forall l, subsequence nil l
| subdrop  : forall s y ry, subsequence s ry -> subsequence s (y :: ry)
| submatch : forall x rx ry, subsequence rx ry -> subsequence (x :: rx) (x :: ry)
.
Hint Constructors subsequence.

Definition sub123 := subsequence [1; 2; 3].
Definition notsub123 := fun l => ~(subsequence [1; 2; 3] l).
Hint Unfold sub123.

Example e1 : sub123 [1; 2; 3]. auto 100. Qed.
Example e2 : sub123 [1; 1; 1; 2; 2; 3]. auto 100. Qed.
Example e3 : sub123 [1; 2; 7; 3]. auto 100. Qed.
Example e4 : sub123 [5; 6; 1; 9; 9; 2; 7; 3; 8]. auto 100. Qed.
(* optional; you'll like inversion and unfold a lot*)

Ltac solvesubseq := intro;
  repeat (
    match goal with
    | [H : subsequence _ _ |- False] => inversion H; clear H; crush
    end
  ).

Example e5 : notsub123 [1; 2]. solvesubseq. Qed.
Example e6 : notsub123 [1; 3]. solvesubseq. Qed.
Example e7 : notsub123 [5; 6; 2; 1; 7; 3; 8]. solvesubseq. Qed.


Module Playground1.

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

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

End Playground1.

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

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

Check S.
Check pred.
Check minustwo.

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

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

Example test_oddb1: (oddb (S O)) = true.
Proof. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. reflexivity. Qed.

Module Playground2.

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

Eval compute in (plus (S (S (S O))) (S (S O))).

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

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

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

End Playground2.

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


(* Standard set of imports. *)
Add LoadPath "~/programming/coq/cpdt/src".
Require Import Bool Arith List CpdtTactics.
Set Implicit Arguments.

(* An ADT *)
Inductive binop : Set := Plus | Times.
Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
  end.

(*
Sugar for:
Definition binopDenote : binop -> nat -> nat -> nat := fun (b: binop) =>
  match b with
    | Plus => plus
    | Times => mult
  end.

Or, without the types:
Definition binopDenote := fun b =>
  match b with
    | Plus => plus
    | Times => mult
  end.
*)

(* Fixpoint denotes recursive data type. *)
Fixpoint expDenote (e: exp) : nat :=
  match e with
    | Const n => n
    | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

(* We want to eval some things in order to test we have the right definitions. *)
Eval simpl in expDenote (Const 42).
Eval simpl in expDenote (Binop Plus (Const 2) (Const 2)).
Eval simpl in expDenote (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).

(* The actual language. *)
Inductive instr : Set :=
(* Push Const on the stack. *)
| iConst : nat -> instr
(* Pop two Const's apply the Binop and push on the stack. *)
| iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.
Definition instrDenote (i : instr) (s: stack) : option stack :=
  match i with
    (* Push it on the stack. *)
    | iConst n => Some (n :: s)
    | iBinop b =>
      match s with
        (* Apply the operator. *)
        | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2 :: s')
        (* Stack underflow. *)
        | _ => None
      end
  end.
Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
    (* No more instructions. *)
    | nil => Some s
    | i :: p' =>
      (* Apply the instruction. *)
      match instrDenote i s with
        (* Stack underflow. *)
        | None => None
        | Some s' => progDenote p' s'
      end
  end.

(* Compiler. *)
Fixpoint compile (e : exp) : prog :=
  match e with
    | Const n => iConst n :: nil
    | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

(* Test the compiler. *)
Eval simpl in compile (Const 42).
Eval simpl in compile (Binop Plus (Const 2) (Const 2)).
Eval simpl in compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).

Eval simpl in progDenote (compile (Const 42)) nil.
Eval simpl in progDenote (compile (Binop Plus (Const 2) (Const 2))) nil.
Eval simpl in progDenote (compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))) nil.

(* Proving correctness. *)
Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).

(* Our first attempt seems too hard, for what reason?
Let's try something else. *)
Abort.

Lemma compile_correct' : forall e p s, progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).

(* Let's try the induction tactic. *)
induction e.

(* Use the intros tactic, whatever that is. *)
intros.
(* This seems to lift forall variables into a free state? *)

(* Let's unfold the functions in our goal. *)
unfold compile.
unfold expDenote.
(* We only need to unfold the LHS progDenote, why? *)
unfold progDenote at 1.
(* Now we can remove some of the cruft, since we know the first arg to progDenote *)
simpl.
(* Now fold it back up. *)
fold progDenote.
(* It's trivial now. *)
reflexivity.

(* On to the next one. *)
intros.
unfold compile.
fold compile.
unfold expDenote.
fold expDenote.
(* Near as I can tell, this folding/unfolding is equivalent to simpl. *)

(* The LHS almost looks like IHe2, we jus need to change the parens. *)
(* Need associative law for lists. *)
Check app_assoc_reverse.
(* We can also search like in hoogle. *)
SearchRewrite ((_ ++ _) ++ _).
rewrite app_assoc_reverse.
(* Now we can rewrite it as the hypothesis. *)
rewrite IHe2.
(* If we do that again, we can get IHe1. *)
rewrite app_assoc_reverse.
rewrite IHe1.
(* We're practically done. *)
unfold progDenote at 1.
simpl.
fold progDenote.
reflexivity.

(* But this was messy.  We can do better with coq. *)
Abort.

Lemma compile_correct' : forall e s p, progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
  induction e; crush.
Qed.

(* Now we can actually prove our theorem. *)
Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
  intros.
  (* We need to use the lemma we constructed, and it almost looks like it, just need a rewrite. *)
  Check app_nil_end.
  (* Have to state exactly what to rewrite. *)
  rewrite (app_nil_end (compile e)).
  (* Use our lemma. *)
  rewrite compile_correct'.
  (* Let's skip a step and let coq handle the nitty. *)
  reflexivity.
Qed.


(*

  Script du Thème 01 :  fonctions récursives

*)

(*

 * Fonctions simples

let id (e:'a) : 'a = e
val id : 'a -> 'a = <fun>

*)

Definition id {A:Set} (a:A) : A := a.

(*

# id 12 ;;
- : int = 12
# id true ;;
- : bool = true

*)

Eval compute in id 12.

Eval compute in id true.

Example id_12: id 12 = 12.
Proof.
compute.
reflexivity.
Qed.

Lemma id_id:
  forall A : Set, forall a : A,
    id a = a.
Proof.
intros A a.
compute.
reflexivity.
Qed.

(**

  ** Exercice : fonction constante

Définir en Ocaml puis traduire en Coq la fonction [constant] qui retourne toujours le premier
de ses deux arguments.

Tester avec [constant 12 true]

Montrer que [constant (id a) b = a].

*)

Definition constant {A B : Set} (a: A) (b : B) : A := a.

Example cst_12: constant 12 true = 12.
Proof.
  compute.
  reflexivity.
Qed.

Lemma cst_ab:
  forall A B : Set,  forall a : A, forall b : B,  constant (id a) b = a.
Proof.
  intros A B a b.
  compute.
  reflexivity.
Qed.

(*

  Un autre exemple de fonction.

*)

Definition flip {A B C:Set} (f:A -> B -> C) : B -> A ->  C :=
  fun (b:B) (a:A) => f a b.

(*

let flip (f:'a -> 'b -> 'c) : 'b -> 'a -> 'c =
   fun (b:B) (a:A) -> f a b.

*)

Lemma flip_flip:
  forall A B C : Set, forall f : A -> B -> C,
    flip (flip f) = f.
Proof.
intros A B C f.
unfold flip.
reflexivity.
Qed.

Lemma flip_flip_flip_flip:
  forall A B C : Set, forall f : A -> B -> C,
    f = flip (flip (flip (flip f))).
Proof.
intros A B C f.
rewrite flip_flip.
rewrite flip_flip.
reflexivity.
Qed.

Lemma flip_flip_flip_flip':
  forall A B C : Set, forall f : A -> B -> C,
    f = flip (flip (flip (flip f))).
Proof.
repeat rewrite flip_flip ; reflexivity.
Qed.

(*

 ** Fonctions totales

# let rec until (pred: 'a -> bool) (f:'a -> 'a) (a:'a) : 'a =
     if pred a then until pred f (f a)
     else a ;;

*)

(*

<<DECOMMENTER POUR ESSAYER>>

Fixpoint until {A:Set} (pred: A -> bool) (f:A -> A) (a:A) : A :=
  if pred a then until pred f (f a)
  else a.

*)

Fixpoint untiln {A:Set} (n:nat) (pred: A -> bool) (f:A -> A) (a:A) : A :=
  if pred a then match n with
                     | 0 => a
                     | S n' => untiln n' pred f (f a)
                 end
  else a.

Lemma untiln_id:
  forall A : Set, forall n:nat,
  forall pred:A -> bool, forall a : A,
    untiln n pred id a = a.
Proof.
intros A n pred a.
induction n as [|n'].
  - (* cas n=0 *)
    simpl.
    case (pred a) ; reflexivity.
  - (* cas n=S n' *)
    simpl.
    destruct (pred a).
    + (* cas (pred a) = True *)
      rewrite id_id.
      rewrite IHn'.
      reflexivity.
    + (* cas (pred a) = False *)
      reflexivity.
Qed.

(*

  * Fonctions sur les listes

*)

Require Import List.

Print list.

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

Example cons_infixe:
 1::2::3::nil = cons 1 (cons 2 (cons 3 nil)).
Proof.
reflexivity.
Qed.

(*

 ** Une première fonction

let rec concat (l1 : 'a list) (l2 : 'a list) : 'a list =
  match l1 with
  | [] -> l2
  | e::l1' -> e::(concat l1' l2)

*)

Fixpoint concat {A : Set} (l1 l2 : list A) : list A :=
  match l1 with
    | nil => l2
    | e::l1' => e::(concat l1' l2)
  end.

Eval compute in concat (1::2::nil) (3::4::5::nil).

Example concat_ex1:
  concat (1::2::3::nil) (4::5::nil)  = 1::2::3::4::5::nil.
Proof.
compute.
reflexivity.
Qed.

Lemma nil_concat:
  forall A : Set, forall l : list A,
    concat nil l = l.
Proof.
intros A l.
simpl.
reflexivity.   (* ou [trivial] *)
Qed.

Lemma concat_nil_fails:
  forall A : Set, forall l : list A,
  concat l nil = l.
Proof.
intros A l.
simpl.  (* bloqué *)
Abort.

Lemma concat_nil_destruct:
  forall A : Set, forall l : list A,
  concat l nil = l.
Proof.
intros A l.
destruct l as [| e l'].
  - (* cas nil : l=nil *)
    simpl.
    reflexivity.
  - (* cas cons: l=e::l' *)
    simpl.  (* bloqué *)
Abort.

Lemma concat_nil:
  forall A : Set, forall l : list A,
  concat l nil = l.
Proof.
induction l as [|e l'].
  - (* cas de base : l=nil *)
    simpl.
    reflexivity.
  - (* cas inductif: l=e::l' *)
    simpl.
    rewrite IHl'.
    reflexivity.
Qed.

(* Le schéma de preuve qui a été
suivi : *)

Check list_ind.

(*

  ** Fonctions partielles

# exception Boum ;;
exception Boum
# let boum (e:'a) = raise Boum ;;
val boum : 'a -> 'b = <fun>

*)

Print option.

Definition head {A:Set} (l:list A) : option A :=
  match l with
      | nil => None
      | e::_ => Some e
  end.

Example head_ex1:
  head (1::2::3::4::nil) = Some 1.
Proof.
compute.
reflexivity.
Qed.

Lemma head_concat:
  forall A : Set, forall l1 l2 : list A,
    head (concat l1 l2) =
    match l1 with
      | nil => head l2
      | e1::l1' =>  Some e1
    end.
Proof.
intros A l1 l2.
destruct l1 as [| e1'' l1''].
  - (* cas l1 = nil *)
    simpl.
    reflexivity.
  - (* cas l1 = e1''::l1'' *)
    simpl.
    reflexivity.
Qed.

(*

one-liner

*)

Lemma head_concat':
  forall A : Set, forall l1 l2 : list A,
    head (concat l1 l2) =
    match l1 with
      | nil => head l2
      | e1::l1' =>  Some e1
    end.
Proof.
  destruct l1 ; trivial.
Qed.

Definition tail {A:Set} (l:list A) : list A :=
  match l with
      | nil => nil
      | _::l' => l'
  end.

Lemma tail_amb:
  forall A : Set, forall e : A,
    tail nil = tail (e::nil).
Proof.
intros A e.
simpl.
reflexivity.
Qed.

Lemma head_tail:
  forall A : Set, forall e : A, forall l : list A,
    head l = Some e -> e :: tail l = l.
Proof.
intros A e l Hhead.
destruct l as [| e' l'].
  - (* cas l = nil *)
    inversion Hhead. (* contradiction *)
  - (* cas l = e'::l' *)
    simpl.
    inversion Hhead as [ He ].
    reflexivity.
Qed.

(*

 ** Exercice : [untiln] partielle

La fonction [untiln] vue précédemment devrait être réécrite pour
être une fonction partielle. En particulier, si la borne d'approximation
est atteinte, le résultat devrait être [None].

Réécrire la fonction [untiln] en conséquence. Que faire du lemme démontré
 sur cette fonction ?

*)

Fixpoint untiln_part { A : Set } ( n : nat ) ( pred : A -> bool ) ( f : A -> A ) ( a : A ) : option A :=
  if pred a
  then Some(a)
  else
    match n with
      | 0 => None
      | S n' => untiln_part n' pred f ( f a )
    end.

(*
Réponse : On oublie le lemme, (c'est plus compliqué)
*)

Lemma untiln_part_id:
  forall A : Set, forall n:nat,
  forall pred:A -> bool, forall a : A, forall x:A,
    untiln_part n pred id a = Some(x) -> x = a.
Proof.
intros A n pred a x.
induction n as [|n'].
  - (* cas n=0 *)
    simpl.
    case (pred a).
      +intros H.
      inversion H.
      reflexivity.
      +intros H.
      inversion H.
  - (* cas n=S n' *)
    simpl.
    destruct (pred a).
    + intros H.
      inversion H.
      reflexivity.
    + (* cas (pred a) = False *)
      exact IHn'.
Qed.

(*

 ** Exercice : Renversement de liste

 *** Question 1

Définir la fonction [rev] qui renverse les élément d'une liste.

*)

Fixpoint rev {A: Set} (l : list A) : list A :=
match l with
  | nil => nil
  | e :: l1' => concat (rev l1') (e :: nil)
end .

(*
 *** Question 2

Compléter l'exemple suivant :

*)

Example rev_ex1:
  rev (1::2::3::4::5::nil) = 5::4::3::2::1::nil.
Proof.
  simpl.
  reflexivity.
Qed.

(**

 *** Question 3

On souhaite montrer que [rev] est idempotent, mais la preuve suivante
 bloque.

*)

Theorem rev_rev_fails:
  forall A : Set, forall l : list A,
    rev (rev l) = l.
Proof.
intros A l.
induction l as [| e l'].
  - (* cas l=nil *)
    simpl.
    reflexivity.
  - (* cas l=e::l' *)
    simpl. (* bloqué *)
Abort.

(*

Il nous manque une propriété importante reliant [rev], [concat] et [nil].

Démonter le lemme [rev_concat_nil] correspondant. En déduire une preuve
complète pour le théorème [rev_rev].

*)

Lemma rev_concat_nil:
    forall A : Set, forall l : list A, forall e : A,
    rev (concat l (e::nil)) = e :: rev l.
Proof.
  induction l as [|e' l'].
  -intro.
   simpl.
   reflexivity.

  -intro.
   simpl.
   rewrite IHl'.
   simpl.
   reflexivity.
   Qed.

Theorem rev_rev:
  forall A : Set, forall l : list A,
    rev (rev l) = l.
Proof.
  intros A l.
  induction l as [|e l'].

  -simpl.
   reflexivity.

  -simpl.
   rewrite rev_concat_nil.
   rewrite IHl'.
   reflexivity.
Qed.

(*

 ** Exercice : dernier élément

 *** Question 1

Définir la fonction [last] qui retourne le dernier élément d'une
liste non-vide.  Cette fonction prendra un argument [d]  (pour défaut) que l'on retournera si la liste est vide.

*)

Fixpoint last {A : Set} (l : list A) (d:A) : A :=
  match l with
    | nil => d
    | e :: nil => e
    | e :: l' => last l' d
  end.

(*

*** Question 2

Montrer le lemme suivant.

*)

Lemma last_single:
  forall A : Set, forall d e : A,
    last (e::nil) d = e.
Proof.
  intros A d e.
  simpl.
  trivial.
Qed.

(*

*** Question 3

Montrer par induction le lemme suivant.

*)

Lemma concat_cons_not_nil:
  forall A : Set, forall l1 l2 : list A, forall e : A,
    concat l1 (e::l2) <> nil.
Proof.
  intros A l1 l2 e.
  unfold not.
  intro Hcontra.
  destruct l1 as [| e1 l1'].
  - (* cas l1=nil *)
    simpl in Hcontra.
    inversion Hcontra.
  - (* cas l1=e1::l1' *)
    simpl in Hcontra.
    inversion Hcontra.
Qed.

Lemma last_concat:
  forall A : Set, forall l1 l2 : list A, forall d e : A,
    last (concat l1 (e::l2)) d = last (e::l2) d.
Proof.
  intros A l1 l2 d e.
  induction l1 as [|e1 l1'].

  -rewrite nil_concat.
   trivial.

  - cut (concat (e1 :: l1') (e :: l2) = e1 :: (concat l1' (e :: l2) )).
    +intros H.
    rewrite H.
    cut (last (e1 :: concat l1' (e :: l2)) d = last (concat l1' (e::l2)) d).
    *intros H1.
    rewrite H1.
    exact IHl1'.
    *
    simpl.
    destruct (concat l1' (e :: l2)).
      {-simpl.
    Abort.

(*

  * Fonctions d'ordre supérieur

 ** Exercice : la fonction map

*)

Fixpoint map {A B :Set} (f:A -> B) (l:list A) : list B :=
  match l with
    | nil => nil
    | e::l' => (f e) :: map f l'
  end.

(**

  *** Question

Démontrer les lemmes suivants :

*)

Lemma head_map:
  forall A B : Set, forall e : A, forall l : list A, forall f : A -> B,
    head (map f (e::l)) = Some (f e).
Proof.
  intros A B e l f.
  simpl.
  reflexivity.
Qed.

Lemma map_id:
  forall A : Set, forall l : list A,
    map id l = l.
Proof.
  intros A l.
  induction l as [|e l'].
  - simpl.
    reflexivity.

  - simpl.
    rewrite IHl'.
    reflexivity.
Qed.

Lemma map_concat:
  forall A B : Set, forall l1 l2 : list A, forall f : A -> B,
    map f (concat l1 l2) = concat (map f l1) (map f l2).
Proof.
  intros A B l1 l2 f.
  induction l1 as [|e l1'].

  - simpl.
    reflexivity.

  -simpl.
   rewrite IHl1'.
   reflexivity.
Qed.

(*

  ** Exercice : la fonction foldr

*)

Fixpoint foldr {A B :Set} (f:A -> B -> B) (u:B) (l:list A) : B :=
  match l with
    | nil => u
    | e::l' => f e (foldr f u l')
  end.

(*

  *** Question 1

Définir une fonction [folder_id] : *)

Definition folder_id {A :Type} (a : A) (b : list A) : list A := a :: b.

(* telle que l'exemple suivant est prouvable : *)

Example foldr_id_ex1:
  foldr folder_id nil (1::2::3::nil) = (1::2::3::nil).
Proof.
  compute.
  reflexivity.
Qed.

(* En déduire le théorème général suivant : *)

Theorem foldr_id:
  forall A : Set, forall l : list A,
    foldr folder_id nil l = l.
Proof.
  intros A l.
  induction l as [|e l'].
    - simpl.
      reflexivity.

    -simpl.
     rewrite IHl'.
     reflexivity.
Qed.

(*

  *** Question 2

En vous inspirant de l'exemple suivant  (à compléter) :

*)

Example folder_id_ex2:
 foldr folder_id (4::5::6::nil) (1::2::3::nil) = 1::2::3::4::5::6::nil.
Proof.
  compute.
  reflexivity.
Qed.

Theorem fold_concat:
  forall A : Set, forall l1 l2 : list A,
    foldr folder_id l2 l1 = concat l1 l2.
Proof.
  intros A l1 l2.
  induction l2 as [|e2' l2'].
    +rewrite concat_nil.
     rewrite foldr_id.
     reflexivity.
    +
Abort.

(*

  *** Question 3

Selon les mêmes principes, redéfinir la fonction [map] en utilisant [foldr].

Tester avec l'exemple correspondant à [map (fun n : nat => S n) (1::2::3::4::5::nil)].

Démontrer le théorème général reliant [map] et [foldr].

*)

Definition foldmap {A B :Set} (f:A -> B) (l:list A) : list B :=
foldr (fun (le :A) (les :(list B)) => (f le)::les) nil l.

Example foldmap_ex1:
foldmap (fun n : nat => S n) (1::2::3::4::5::nil) = (2::3::4::5::6::nil).
Proof.
compute.
reflexivity.
Qed.

(*

  *** Question 4

Mêmes questions pour la fonction [rev]

*)

Definition foldrev {A:Set} (l:list A) : list A :=
 foldr (fun (le :A) (les :(list A)) => concat les (le::nil)) nil l.

Example foldrev_ex1:
foldrev (1::2::3::4::5::nil) = (5::4::3::2::1::nil).
Proof.
compute.
reflexivity.
Qed.

(*

  ** Exercice : pliage à gauche (difficile)

La fonction de pliage à gauche est la suivante :

*)

Fixpoint foldl {A B :Set} (f:A -> B -> A) (u:A) (l:list B) : A :=
  match l with
    | nil => u
    | e::l' => foldl f (f u e) l'
  end.

(*

  *** Question 1

Définir une fonction _non-récursive_ [foldl'] de pliage à gauche à partir de [foldr].

*)

(* wrong def*)
Definition foldl' {A B :Set} (f:A -> B -> A) (u:A) (l:list B) : A :=
  foldr (fun (b:B)(g:A -> B)(x:A) =>  (g (f (x) (b)))) u l.

(* Démontrer le théorème suivant : *)

Theorem foldl'_foldl:
  forall A B : Set, forall f : A -> B -> A,
  forall l : list B, forall u : A,
    foldl f u l = foldl' f u l.
Proof.
  intros A B f l u.
  induction l as [|e l'].

  - compute.
    reflexivity.

  - simpl.
 unfold foldl' in IHl'.
    unfold foldl'.
    simpl.
    rewrite <- IHl'.
    fold.
Abort.

(*

  *** Question 2

Reconstruire les fonctions [id], [concat], [rev] et [map] avec
 [foldl] et [foldl'].

Démontrer les lemmes et théorèmes qui
semblent les plus pertinents. Alterner des preuves pour [foldl]
 et des preuves pour [foldl']   ainsi que des preuves
 exploitant le théorème [foldl'_foldl] ci-dessus.

*)


Require Import Lia.
(* Note that we can talk about binary numbers by introducing
   three new constructors; B0, B1, and the termination Z;
    3_10 == B1 (B1 Z)_2 == S (S (S 0)_1 *)

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z => B1 Z
  | B0 m' => B1 m'
  | B1 m'' => B0 (incr m'')
  end.

Example bin_incr1: (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.

Fixpoint bin_to_nat (m : bin) : nat :=
  match m with
  | Z => O
  | B0 m' => 2 * (bin_to_nat m')
  | B1 m'' => 2 * (bin_to_nat m'') + 1
  end.

Example test_bin_incr6:
  bin_to_nat (B0 (B0 (B0 (B1 Z)))) = S (S (S (S (S (S (S (S O))))))).
Proof. simpl. reflexivity. Qed.

(* Proof that the increment function commutes *)
Theorem bin_incr_nat_succ_commu:
  forall (b : bin),
  bin_to_nat (incr b) = (bin_to_nat b) + 1.
Proof.
  induction b.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. rewrite IHb. lia.
Qed.


Parameter E : Set.
Parameters P Q : E -> Prop.

Lemma ex1_1 : (forall x : E, (P x) -> (Q x)) -> (exists x : E, (P x)) -> (exists x : E, (Q x)).
intros.
elim H0.
intros.
exists x.
apply H.
assumption.
Qed.

Lemma ex1_2 : (exists x : E, (P x)) \/ (exists x : E, (Q x)) -> exists x : E, (P x) \/ (Q x).
intros.
elim H.
intros.
elim H0.
intros.
exists x.
left.
assumption.
intros.
elim H0.
intros.
exists x.
right.
assumption.
Qed.

Require Import Lists.List.

Open Scope list_scope.

Lemma ex2_1 : forall (F : Set) (l1 l2 : list F), length (l1++l2) = (length l1) + (length l2).
intros.
induction l1.
induction l2.
auto.
auto.
simpl.
rewrite IHl1.
auto.
Qed.

Inductive is_even : nat -> Prop :=
| is_even_O : is_even 0
| is_even_S : forall n : nat, is_even n -> is_even (S (S n)).

Inductive is_even_list : list nat -> Prop :=
| is_even_zero : is_even_list nil
| is_even_rec : forall (a : nat) (l : list nat), (is_even a) -> (is_even_list l) -> is_even_list (a::l).

Lemma ex3_2 : is_even_list (0::2::4::nil).
apply is_even_rec.
apply is_even_O.
apply is_even_rec.
apply is_even_S.
apply is_even_O.
apply is_even_rec.
apply is_even_S.
apply is_even_S.
apply is_even_O.
apply is_even_zero.
Qed.

Lemma ex3_3 : ~ is_even_list (0::1::2::4::nil).
intro.
inversion H.
inversion H3.
inversion H6.
Qed.


From LF Require Export Logic.
From LF Require Export Basics.
Require Coq.omega.Omega.

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS : forall n : nat, ev n -> ev (S (S n)).

Check ev_0.
Check ev_SS.

Fail Inductive wrong_ev (n : nat) : Prop :=
| wrong_ev_0 : wrong_ev 0
| wrong_ev_SS : forall n, wrong_ev n -> wrong_ev (S (S n)).
(* ===> Error: A parameter of an inductive type n is not
        allowed to be used as a bound variable in the type
        of its constructor. *)

Theorem ev_4 : ev 4.
Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed.

Theorem ev_4' : ev 4.
Proof. apply (ev_SS 2 (ev_SS 0 ev_0)). Qed.

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

(*Exercise 1*)
Theorem ev_double : forall n,
  ev (double n).
Proof.
  intros. unfold double.
  induction n as [|n'].
  - apply ev_0.
  - apply ev_SS. apply IHn'.
Qed.

Theorem ev_minus2 : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  inversion  E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.  Qed.

Theorem ev_minus2' : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.  Qed.

Theorem evSS_ev : forall n,
  ev (S (S n)) -> ev n.

Proof.
  intros n E.
  destruct E as [| n' E'].
  - (* E = ev_0. *)
    (* We must prove that [n] is even from no assumptions! *)
Abort.

Theorem evSS_ev : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E.
  inversion E as [| n' E'].
  (* We are in the [E = ev_SS n' E'] case now. *)
  apply E'.
Qed.

Theorem one_not_even : ~ ev 1.
Proof.
  intros H. inversion H. Qed.

(*Exercise 2*)
Theorem SSSSev__even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros. inversion H. inversion H1. apply H3.
Qed.

(*Exercise 3*)
Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros. simpl. exfalso.
  inversion H. inversion H1. inversion H3.
Qed.

Lemma ev_even_firsttry : forall n,
  ev n -> exists k, n = double k.
Proof.
  intros n E. inversion E as [| n' E'].
  - (* E = ev_0 *)
    exists 0. reflexivity.
  - (* E = ev_SS n' E' *) simpl.
    assert (I : (exists k', n' = double k') ->
                (exists k, S (S n') = double k)).
    { intros [k' Hk']. rewrite Hk'. exists (S k'). reflexivity. }
    apply I. (* reduce the original goal to the new one *)

Admitted.

Lemma ev_even : forall n,
  ev n -> exists k, n = double k.
Proof.
  intros n E.
  induction E as [|n' E' IH].
  - (* E = ev_0 *)
    exists 0. reflexivity.
  - (* E = ev_SS n' E'
       with IH : exists k', n' = double k' *)
    destruct IH as [k' Hk'].
    rewrite Hk'. exists (S k'). reflexivity.
Qed.

Theorem ev_even_iff : forall n,
  ev n <-> exists k, n = double k.
Proof.
  intros n. split.
  - (* -> *) apply ev_even.
  - (* <- *) intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

(*Exercise 4*)
Theorem ev_sum : forall n m, ev n -> ev m -> ev (n + m).
Proof.
  intros n m In Im. induction In.
  - simpl. apply Im.
  - simpl. apply ev_SS. apply IHIn.
Qed.

(*Exercise 5*)
Inductive ev' : nat -> Prop :=
| ev'_0 : ev' 0
| ev'_2 : ev' 2
| ev'_sum : forall n m, ev' n -> ev' m -> ev' (n + m).

Theorem ev'_ev : forall n, ev' n <-> ev n.
Proof.
  intros. split.
  - intros. induction H.
    + apply ev_0.
    + apply ev_SS. apply ev_0.
    + apply ev_sum. apply IHev'1. apply IHev'2.
  - intros. induction H.
    + apply ev'_0.
    + apply (ev'_sum 2).
      * apply ev'_2.
      * apply IHev.
Qed.

(*Exercise 6*)
Theorem ev_ev__ev : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros. induction H0.
  simpl in H. apply H. apply IHev.
  simpl in H. inversion H. apply H2.
Qed.

Lemma helper_ex7: forall n, ev(n + n).
Proof.
intros. induction n. simpl. apply ev_0.
 simpl. rewrite <- plus_n_Sm. apply ev_SS. apply IHn.
Qed.

(*Exercise 7*)
Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
intros.
  apply ev_ev__ev with (n:=(n+n)).
  - rewrite <- plus_assoc.
    rewrite plus_assoc with (m:=m).
    rewrite plus_comm.
    rewrite <- plus_assoc.
    rewrite plus_comm with (n:= p).
    apply ev_sum. apply H. apply H0.
  - apply helper_ex7. Qed.

Lemma helper: ev 1.
  Proof. apply (ev_sum 1). Admitted.

(*Exercise 8*)
Theorem ex_mid_ev:
  forall n, ev n \/ ~ ev n.

Proof.
  intros. assert (helper: (forall n, if evenb n then ev n else ~ ev n)).
  { intros.  destruct n0. simpl. apply ev_0.

}Admitted.

(*Exercise 9*)
Theorem ev_n_not_ev_Sn:
  forall n,
  ev n -> ~ ev (S n).

Proof.
  intros. unfold not. destruct n.
Admitted.