Coq < Section More_Practice.

Coq < Require Import Classical.

Coq < Variables P Q : Prop.
P is assumed
Q is assumed

Coq < Goal (P /\ Q) -> (Q /\ P).
1 subgoal

  P : Prop
  Q : Prop
  ============================
   P /\ Q -> Q /\ P

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  H : P /\ Q
  ============================
   Q /\ P

Unnamed_thm < destruct H.
1 subgoal

  P : Prop
  Q : Prop
  H : P
  H0 : Q
  ============================
   Q /\ P

Unnamed_thm < split.
2 subgoals

  P : Prop
  Q : Prop
  H : P
  H0 : Q
  ============================
   Q

subgoal 2 is:
 P

Unnamed_thm < exact H0.
1 subgoal

  P : Prop
  Q : Prop
  H : P
  H0 : Q
  ============================
   P

Unnamed_thm < exact H.
No more subgoals.

Unnamed_thm < Qed.
intros.
destruct H.
split.
 exact H0.

 exact H.

Unnamed_thm is defined


Require Import ZArith Nnat Omega.
Open Scope Z_scope.

(** Test of the zify preprocessor for (R)Omega *)

(* More details in file PreOmega.v

   (r)omega with Z        : starts with zify_op
   (r)omega with nat      : starts with zify_nat
   (r)omega with positive : starts with zify_positive
   (r)omega with N        : starts with uses zify_N
   (r)omega with *        : starts zify (a saturation of the others)
*)

(* zify_op *)

Goal forall a:Z, Z.max a a = a.
intros.
omega with *.
Qed.

Goal forall a b:Z, Z.max a b = Z.max b a.
intros.
omega with *.
Qed.

Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c.
intros.
omega with *.
Qed.

Goal forall a b:Z, Z.max a b + Z.min a b = a + b.
intros.
omega with *.
Qed.

Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a.
intros.
zify.
intuition; subst; omega. (* pure multiplication: omega alone can't do it *)
Qed.

Goal forall a:Z, Z.abs a = a -> a >= 0.
intros.
omega with *.
Qed.

Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1.
intros.
omega with *.
Qed.

(* zify_nat *)

Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat.
intros.
omega with *.
Qed.

Goal forall m:nat, (m<1)%nat -> (m=0)%nat.
intros.
omega with *.
Qed.

Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat.
intros.
omega with *.
Qed.
(* 2000 instead of 200: works, but quite slow *)

Goal forall m: nat, (m*m>=0)%nat.
intros.
omega with *.
Qed.

(* zify_positive *)

Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive.
intros.
omega with *.
Qed.

Goal forall m:positive, (m<2)%positive -> (m=1)%positive.
intros.
omega with *.
Qed.

Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive.
intros.
omega with *.
Qed.

Goal forall m: positive, (m*m>=1)%positive.
intros.
omega with *.
Qed.

(* zify_N *)

Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N.
intros.
omega with *.
Qed.

Goal forall m:N, (m<1)%N -> (m=0)%N.
intros.
omega with *.
Qed.

Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N.
intros.
omega with *.
Qed.

Goal forall m:N, (m*m>=0)%N.
intros.
omega with *.
Qed.

(* mix of datatypes *)

Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p.
intros.
omega with *.
Qed.


(** Calculation of an abstract machine for the call-by-value lambda
calculus. The resulting abstract machine coincides with the CEK
machine. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** The evaluator for this language is given as follows:
<<
type Env = [Value]
data Value =  Fun (Value -> Value)

eval ::  Expr -> Env -> Value
eval (Var i) e   = e !! i
eval (Abs x) e   = Fun (\v -> eval x (v:e))
eval (App x y) e = case eval x e of
                     Fun f -> f (eval y e)
>>
After defunctionalisation and translation into relational form we
obtain the semantics below. *)

Inductive Value : Set :=
| Clo : Expr -> list Value -> Value.

Definition Env := list Value.

Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Value -> Prop :=
| eval_var e i v : nth e i = Some v -> Var i ⇓[e] v
| eval_abs e x : Abs x ⇓[e] Clo x e
| eval_app e e' x x' w y v : x ⇓[e] Clo x' e' -> y ⇓[e] v -> x' ⇓[v :: e'] w -> App x y ⇓[e] w
where "x ⇓[ e ] y" := (eval x e y).

(** * Abstract machine *)

Inductive CONT : Set :=
| FUN : Expr -> Env -> CONT -> CONT
| ARG : Expr -> Env -> CONT -> CONT
| HALT : CONT
.

Inductive Conf : Set :=
| eval'' : Expr -> Env -> CONT -> Conf
| apply : CONT -> Value -> Conf.

Notation "⟨ x , e , c ⟩" := (eval'' x e c).
Notation "⟪ c , v ⟫" := (apply c v).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive AM : Conf -> Conf -> Prop :=
| am_var i e c v : nth e i = Some v -> ⟨Var i, e, c⟩ ==> ⟪c, v⟫
| am_abs x e c : ⟨Abs x, e, c⟩ ==> ⟪c, Clo x e⟫
| am_app x y e c : ⟨App x y, e, c⟩ ==> ⟨x, e, ARG y e c⟩
| am_FUN x' e' c v : ⟪FUN x' e' c, v⟫ ==> ⟨x', v::e', c⟩
| am_ARG y e c x' e' : ⟪ARG y e c, Clo x' e'⟫ ==> ⟨y, e, FUN x' e' c⟩
where "x ==> y" := (AM x y).

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module AM <: Preorder.
Definition Conf := Conf.
Definition VM := AM.
End AM.
Module AMCalc := Calculation AM.
Import AMCalc.

(** Specification of the abstract machine *)

Theorem spec x e r c : x ⇓[e] r -> ⟨x, e, c⟩ =>> ⟪c, r⟫.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction H;intros.

(** Calculation of the abstract machine *)

(** - [Var i ⇓[e] v] *)

  begin
    ⟪c, v ⟫.
  <== {apply am_var}
    ⟨Var i, e, c ⟩.
   [].

(** - [Abs x ⇓[e] Clo x e] *)

  begin
    ⟪c, Clo x e⟫.
  <== { apply am_abs }
    ⟨Abs x, e, c⟩.
  [].

(** - [App x y ⇓[e] w] *)

  begin
    ⟪c, w⟫.
  <<= { apply IHeval3 }
    ⟨x', (v::e'), c⟩.
  <== { apply am_FUN }
    ⟪FUN x' e' c, v⟫.
  <<= {apply IHeval2}
    ⟨y, e, FUN x' e' c⟩.
  <== {apply am_ARG}
    ⟪ARG y e c, Clo x' e'⟫.
  <<= {apply IHeval1}
    ⟨x, e, ARG y e c⟩.
  <== {apply am_app}
    ⟨App x y, e, c⟩.
  [].
Qed.

(** * Soundness *)

Lemma determ_am : determ AM.
  intros C c1 c2 V. induction V; intro V'; inversion V'; subst; congruence.
Qed.

Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r.

Theorem sound x C : terminates x -> ⟨x, nil, HALT⟩ =>>! C ->
                          exists r, C = ⟪HALT, r⟫ /\ x ⇓[nil] r.
Proof.
  unfold terminates. intros. destruct H as [r T].

  pose (spec x nil r HALT) as H'. exists r. split. pose (determ_trc determ_am) as D.
  unfold determ in D. eapply D. eassumption. split. eauto. intro. destruct H.
  inversion H. assumption.
Qed.


(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    [Smallstep] chapter), so readers who are already comfortable with
    these ideas can safely skim or skip this chapter.  However,
    relations are also a good source of exercises for developing
    facility with Coq's basic reasoning facilities, so it may be
    useful to look at this material just after the [IndProp]
    chapter. *)

Require Export SF.IndProp.

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

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

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.
(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ######################################################### *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)

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

(** **** Exercise: 2 stars, optional  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)

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

(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
    (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.

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

(** **** Exercise: 1 star, optional  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional  *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional  *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ########################################################### *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


Require Export MoreCoq.

(* ((Conjunction (Logical "and"))) *)

(* Exercise: 2 stars (and_exercise) *)

Example and_exercise:
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m H.
  destruct n.
  Case "n = 0".
    split.
    SCase "0 = 0 ?".
      reflexivity.
    SCase "m = 0".
      simpl in H.
      rewrite H.
      reflexivity.
  Case "n != 0".
    inversion H.
Qed.

(* END and_exercise. *)

(* Exercise: 1 star, optional (proj2) *)

Theorem proj2 : forall (P Q : Prop), P /\ Q -> Q.
Proof.
  intros P Q H.
  destruct H as [HP HQ].
  apply HQ.
Qed.

(* END proj2. *)

(* Exercise: 2 stars (and_assoc) *)

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  destruct H as [HP [HQ HR]].
  split.
  Case "P and Q".
    split.
    SCase "P".
      apply HP.
    SCase "Q".
      apply HQ.
  Case "R".
    apply HR.
Qed.

(* END and_assoc. *)

(* ((Iff)) *)

(* Exercise: 1 star, optional (iff_properties) *)

Theorem iff_refl : forall P : Prop, P <-> P.
Proof.
  intros P.
  split.
  Case "P -> P #1".
    intros H.
    apply H.
  Case "P -> P #2".
    intros H.
    apply H.
Qed.

(* END iff_properties. *)

(* Exercise: 2 stars (or_distributes_over_and_2) *)

Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros P Q R H.
  destruct H as [[HP|HQ] [HP2|HR]] eqn: Hd.
  Case "(true \/ _) /\ (true \/ _)".
    left.
    apply HP.
  Case "(true \/ _) /\ (_ \/ true)".
    left.
    apply HP.
  Case "(_ \/ true) /\ (true \/ _)".
    left.
    apply HP2.
  Case "(_ \/ true) /\ (_ \/ true)".
    right.
    split.
    SCase "Q".
      apply HQ.
    SCase "R".
      apply HR.
Qed.

(* END or_distributes_over_and_2. *)

(* Exercise: 1 star, optional (or_distributes_over_and) *)

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R H.
  split.
  Case "P \/ Q".
    destruct H as [HP | [HQ HR]] eqn: Hd.
    SCase "true \/ _".
      left.
      apply HP.
    SCase "_ \/ (true /\ true)".
      right.
      apply HQ.
  Case "P \/ R".
    destruct H as [HP | [HQ HR]] eqn: Hd.
    SCase "true \/ _".
      left.
      apply HP.
    SCase "_ \/ (true /\ true)".
      right.
      apply HR.
Qed.

(* END or_distributes_over_and. *)

(* Exercise: 2 stars, optional (andb_false) *)

Theorem andb_false : forall b c, andb b c = false -> b = false \/ c = false.
Proof.
  intros b c H.
  destruct b eqn : Hd.
  Case "b = true".
    simpl in H.
    right.
    apply H.
  Case "b = false".
    left.
    trivial.
Qed.

(* END andb_false. *)

(* Exercise: 2 stars, optional (orb_false) *)

Theorem orb_prop : forall b c, orb b c = true -> b = true \/ c = true.
Proof.
  intros b c.
  intros H.
  destruct b eqn : Hd.
  Case "b = true".
    left.
    trivial.
  Case "b = false".
    right.
    simpl in H.
    apply H.
Qed.

(* END orb_false. *)

(* Exercise: 2 stars, optional (orb_false_elim) *)

Theorem orb_false_elim : forall b c, orb b c = false -> b = false /\ c = false.
Proof.
  intros b c H.
  destruct b eqn : Hd.
  Case "b = true".
    inversion H.
  Case "b = false".
    split.
    SCase "false = false".
      trivial.
    SCase "c = false".
      simpl in H.
      apply H.
Qed.

(* END orb_false_elim. *)

(* ((Falsehood)) *)

(* Exercise: 2 stars, advanced (True) *)

Inductive True : Prop :=
  truth : True.

(* END True. *)

(* ((Negation)) *)

(* Exercise: 2 stars, advanced (double_neg_inf) *)

(* By definition of negation, ~~P means (P -> False) -> False, i. e. in order
* to prove a false statement P is enough, and the goal is to prove a false
* statement. Thus, (P -> False) -> False simplifies to just P, which is given.
*)

(* END double_neg_inf. *)

(* Exercise: 2 stars (contrapositive) *)

Theorem contrapositive : forall P Q : Prop, (P -> Q) -> (not Q -> not P).
Proof.
  intros P Q H.
  unfold not.
  intros G HP.
  apply G.
  apply H.
  apply HP.
Qed.

(* END contrapositive. *)

(* Exercise: 1 star (not_both_true_and_false) *)

Theorem not_both_true_and_false : forall P : Prop, not (P /\ not P).
Proof.
  intros P.
  unfold not.
  intros H.
  inversion H.
  apply H1.
  apply H0.
Qed.

(* END not_both_true_and_false. *)

(* Exercise: 1 star, advanced (informal_not_PNP) *)

(* not (P /\ not P), by definition of negation, is the same as (P /\ not P) ->
* False. By definition of /\, both P and `not P` must be true for the implied
* False to be true. `not P` unfolds into P -> False, that is, P is sufficient
* to prove False. P is a given to the implication. *)

(* END informal_not_PNP. *)

Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y},
  (forall (x:X), f x = g x) -> f = g.

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
  match l1 with
    | nil => l2
    | (x :: l1')%list => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X} (l : list X) : list X :=
  rev_append l nil.

(* Exercise: 5 stars (tr_rev) *)

Theorem snoc_append : forall (X : Type) (x : X) (l : list X),
  snoc l x = app l (cons x nil).
Proof.
  induction l; simpl; auto. rewrite -> IHl. trivial.
Qed.

Theorem rev_append_snoc_helper : forall X (x : list X) (a1 a2 : X),
  (a1 :: (x ++ a2 :: nil))%list = ((a1 :: x) ++ (a2 :: nil))%list.
Proof.
  induction x.
  - reflexivity.
  - reflexivity.
Qed.

Lemma rev_append_snoc : forall X (x1 x2 : list X) (a : X),
  rev_append x1 (x2 ++ a :: nil) = snoc (rev_append x1 x2) a.
Proof.
  intros X x.
  induction x.
  - simpl. intros. rewrite -> snoc_append. reflexivity.
  - simpl. intros. rewrite -> rev_append_snoc_helper. rewrite -> IHx.
    reflexivity.
Qed.

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intro X.
  apply functional_extensionality.
  intro x.
  induction x.
  - reflexivity.
  - simpl. rewrite <- IHx. unfold tr_rev. simpl.
    replace (a :: nil)%list with (nil ++ a :: nil)%list.
    + rewrite -> rev_append_snoc. reflexivity.
    + reflexivity.
Qed.

(* END tr_rev. *)

Theorem double_neg : forall P : Prop, P -> ~~P.
Proof.
  unfold not.
  intros P P_ PF.
  apply PF.
  apply P_.
Qed.

(* Exercise: 3 stars (excluded_middle_irrefutable) *)

Theorem excluded_middle_irrefutable : forall P : Prop, ~ ~ (P \/ ~P).
Proof.
  unfold not.
  intros P H1.
  apply H1.
  right.
  intros P1.
  apply H1.
  left.
  apply P1.
Qed.

(* END excluded_middle_irrefutable. *)

Theorem ex_falso_quodlibet : forall P : Prop, False -> P.
Proof. intros P H. inversion H. Qed.

(* Exercise: 5 stars, advanced, optional (classical_axioms) *)

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

Definition classic := forall P : Prop, not (not P) -> P.

Definition excluded_middle := forall P : Prop, P \/ not P.

Definition de_morgan_not_and_not := forall P Q : Prop,
  not (not P /\ not Q) -> P \/ Q.

Definition implies_to_or := forall P Q : Prop, (P -> Q) -> (not P \/ Q).

Theorem P_or_false : forall P : Prop, P \/ False -> P.
Proof.
  intros P PoFH.
  destruct PoFH.
  apply H.
  inversion H.
Qed.

Theorem or_com : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
  intros P Q PQ.
  destruct PQ.
  right.
  apply H.
  left.
  apply H.
Qed.

Theorem pierce_implies_classic : pierce -> classic.
Proof.
  unfold pierce.
  unfold classic.
  intros pierce.
  intros P.
  unfold not.
  intros pff.
  apply pierce with (Q := False).
  intros pf.
  apply pff in pf.
  inversion pf.
Qed.

Theorem classic_implies_pierce : classic -> pierce.
Proof.
  unfold classic.
  unfold pierce.
  intros C.
  intros P Q PQP.
  unfold not in C.
  apply C.
  intros pf.
  apply pf.
  apply PQP.
  intros P_.
  apply pf in P_.
  inversion P_.
Qed.

Theorem classic_implies_excluded_middle : classic -> excluded_middle.
Proof.
  unfold classic.
  unfold excluded_middle.
  intros H.
  intros P.
  apply H.
  apply excluded_middle_irrefutable.
Qed.

Theorem excluded_middle_implies_classic :
  excluded_middle -> classic.
Proof.
  unfold excluded_middle.
  unfold classic.
  unfold not.
  intros EM P nnP.
  assert ((P \/ (P -> False)) -> P).
    intros kh.
    destruct kh.
    apply H.
    apply ex_falso_quodlibet.
    apply nnP.
    apply H.
  apply H.
  apply EM.
Qed.

Theorem classic_implies_de_morgan_not_and_not :
  classic -> de_morgan_not_and_not.
Proof.
  unfold classic.
  intros EM.
  unfold de_morgan_not_and_not.
  intros P Q Hand.
  unfold not in Hand.
  apply EM.
  unfold not.
  intros Hor.
  apply Hand.
  split.
  Case "P -> False".
    intros P_.
    apply Hor.
    left.
    apply P_.
  Case "Q -> False".
    intros Q_.
    apply Hor.
    right.
    apply Q_.
Qed.

Theorem de_morgan_not_and_not_implies_classic :
  de_morgan_not_and_not -> classic.
Proof.
  unfold de_morgan_not_and_not.
  unfold classic.
  unfold not.
  intros H.
  intros P.
  intros N.
  apply P_or_false.
  apply H.
  intros R.
  apply N.
  intros P_.
  apply N.
  destruct R.
  apply H0.
Qed.

Theorem classic_implies_implies_to_or : classic -> implies_to_or.
Proof.
  unfold classic.
  intros CL.
  unfold implies_to_or.
  intros P Q.
  intros H.
  apply CL.
  unfold not.
  intros H1.
  apply H1.
  left.
  intros P_.
  apply H1.
  right.
  apply H.
  apply P_.
Qed.

Theorem implies_to_or_implies_excluded_middle :
  implies_to_or -> excluded_middle.
Proof.
  unfold implies_to_or.
  unfold excluded_middle.
  unfold not.
  intros ITO P.
  apply or_com.
  apply ITO.
  intros P_.
  apply P_.
Qed.

(* END classical_axioms. *)

(* Exercise: 2 stars (false_beq_nat) *)

Theorem false_beq_nat : forall n m : nat, n <> m ->  beq_nat n m = false.
Proof.
  intros n.
  induction n as [|n'].
  Case "n = 0".
    destruct m as [|m'].
    SCase "m = 0".
      intros H.
      unfold not in H.
      apply ex_falso_quodlibet.
      apply H.
      trivial.
    SCase "m = S m'".
      reflexivity.
  Case "n = S n'".
    destruct m as [|m'].
    SCase "m = 0".
      reflexivity.
    SCase "m = S m'".
      intros H.
      simpl.
      apply IHn'.
      unfold not.
      unfold not in H.
      intros n'm'.
      apply H.
      rewrite -> n'm'.
      reflexivity.
Qed.

(* END false_beq_nat. *)

(* Exercise: 2 stars, optional (beq_nat_false) *)

Theorem beq_nat_false : forall n m : nat, beq_nat n m = false -> n <> m.
Proof.
  intros n m H.
  unfold not.
  intros nm.
  rewrite -> nm in H.
  rewrite <- beq_nat_refl in H.
  inversion H.
Qed.

(* END beq_nat_false. *)


Require Import Classical.

Theorem Ex025 (A : Prop): A <-> ~~A.
Proof.
  split.
  + intro.
    intro.
    contradiction.
  + intro.
    apply NNPP.
    intro.
    contradiction.
Qed.

(*without NNPP*)

Theorem Ex025_2 (A : Prop): A <-> ~~A.
Proof.
  split.
  + intro.
    intro.
    contradiction.
  + intro.
    pose proof (classic A).
    destruct H0.
    - exact H0.
    - contradiction.
Qed.


(** TD1 *)

Set Universe Polymorphism. (* Indispensable pour [church_minus] (Exo 3) *)

(** Exo 1 *)

Definition compose {A B C} (f:B->C)(g:A->B) := fun x => f (g x).

Compute compose S pred 7.
Compute compose S pred 0.
Compute compose pred S 0.

(** Exo 2 *)

Definition mybool := forall X, X->X->X.

Definition mytrue : mybool := fun _ x y => x.
Definition myfalse : mybool := fun _ x y => y.

Definition myif : forall {Y}, mybool -> Y -> Y -> Y :=
 fun _ b x y => b _ x y.

Compute myif mytrue 0 1.
Compute myif myfalse 0 1.

(** Exo 3 *)

Definition church := forall X, (X->X)->(X->X).

Definition zero : church := fun _ f x => x.
Definition one : church := fun _ f x => f x.
Definition onebis : church := fun _ f => f.
Definition two : church := fun _ f x => f (f x).

Definition succ : church -> church :=
 fun n => fun _ f x => n _ f (f x).

Compute succ one.

Definition church2nat (n:church) := n _ S 0.

Compute church2nat zero.
Compute church2nat one.
Compute church2nat onebis.
Compute church2nat two.

Fixpoint nat2church (n:nat) :=
 match n with
 | O => zero
 | S m => succ (nat2church m)
 end.

Compute nat2church 3.
Compute church2nat (nat2church 100).

Definition church_plus (n m:church) : church :=
  fun _ f x => n _ f (m _ f x).

Compute church_plus one two.
Compute church2nat (church_plus (nat2church 13) (nat2church 10)).

Definition church_mult (n m:church) : church :=
 fun _ f =>  n _ (m _ f).

Compute church_mult one two.
Compute church2nat (church_mult (nat2church 13) (nat2church 10)).

Definition church_pow (n m:church) : church :=
 fun _ =>  m _ (n _).

Compute church_pow two two.
Compute church2nat (church_pow (nat2church 2) (nat2church 5)).

Definition is_zero (n : church) : bool :=
  n _ (fun _ => false) true.

Compute is_zero zero.
Compute is_zero one.

Compute church.

Definition church_pred (n:church) : church :=
 fun _ f x =>
   n _ (fun g h => h (g f)) (fun _ => x) (fun u => u).

Fail Compute (church church).

Compute church2nat (church_pred zero).
Compute church2nat (church_pred one).
Compute church2nat (church_pred (nat2church 13)).

(** Attention, donne [universe inconsistency] si les univers
    polymorphes ne sont pas activés. *)

Definition church_minus (n m : church) : church :=
  m _ church_pred n.

Definition f (x:False) : False := x.

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

Compute bool_rect.

Fail Inductive t :=
|c1 : (t -> t) -> t.

Compute church2nat (church_minus two two).
Compute church2nat (church_minus (nat2church 10) (nat2church 7)).

(** Exo 4 *)

Open Scope bool_scope.

Definition checktauto f := f true && f false.
Definition checktauto2 f := checktauto (compose checktauto f).
Definition checktauto3 f := checktauto (compose checktauto2 f).

Compute checktauto3
        (fun a b c => a || b || c || negb (a && b) || negb (a && c)).
Compute checktauto3 (fun a b c => a || b || c).

(** A revoir lors du cours sur les "types dépendants" :
    une généralisation de checktauto aux fonctions booléennes
    à n arguments. P.ex. nbool 2 = bool -> bool -> bool
    Et nchecktauto 2 se comportera comme le checktauto2 précédent. *)

Fixpoint nbool n :=
 match n with
 | 0 => bool
 | S n => bool -> nary n
 end.

Fixpoint nchecktauto n : nbool n -> bool :=
 match n with
 | 0 => fun b => b
 | S n => fun f => nchecktauto n (f true) && nchecktauto n (f false)
 end.

Compute nchecktauto 3
        (fun a b c => a || b || c || negb (a && b) || negb (a && c)).
Compute nchecktauto 3 (fun a b c => a || b || c).

(** Exo 5 *)

Require Import Arith.

Fixpoint add n m :=
 match n with
 | 0 => m
 | S n => S (add n m)
 end.

Compute add 3 7.

Fixpoint mul n m :=
 match n with
 | 0 => 0
 | S n => add m (mul n m)
 end.

Compute mul 3 7.

Fixpoint sub n m :=
 match n, m with
 | _,0 => n
 | 0,_ => n
 | S n, S m => sub n m
 end.

Compute sub 7 3.
Compute sub 3 7.

Fixpoint fact n :=
 match n with
 | 0 => 1
 | S m => mul n (fact m)
 end.

Compute fact 8.

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

Compute pow 2 10.

(* En Coq 8.4, ajouter:
Require Import NPeano.
Infix "=?" := Nat.eqb (at level 70, no associativity) : nat_scope.
*)

Fixpoint modulo_loop a b n :=
 match n with
 | 0 => 0
 | S n =>
   if a <? b then a
   else modulo_loop (sub a b) b n
 end.

Definition modulo a b := modulo_loop a b a.

Compute modulo 10 3.
Compute modulo 3 0.

Fixpoint gcd_loop a b n :=
  match n with
  | 0 => 0
  | S n =>
    if b =? 0 then a
    else gcd_loop b (modulo a b) n
  end.

Definition gcd a b := gcd_loop a b (S b).

Compute gcd 17 23.
Compute gcd 23 17.
Compute gcd 12 9.
Compute gcd 9 12.
Compute gcd 10 1.
Compute gcd 1 10.
Compute gcd 0 7.
Compute gcd 7 0.

(* ---------------------------------------- *)
Require Import List.
Import ListNotations.
Check [].


(**************************************
  Finish reading, Finish exercise
**************************************)

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

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

(** **** Exercise: 1 star (nandb)  *)
Definition nandb (b1: bool) (b2: bool): bool :=
  match b1, b2 with
  | true, true => false
  | _, _       => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star (andb3)  *)
Definition andb3 (b1:bool) (b2:bool) (b3:bool): bool :=
  match b1, b2, b3 with
  | true, true, true => true
  | _, _, _          => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.

Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.

Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.

Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star (factorial)  *)
Fixpoint factorial (n:nat): nat :=
  match n with
  | 0 => 1
  | S n => S n * factorial n
  end.

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

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

(** **** Exercise: 1 star (blt_nat)  *)
Definition blt_nat (n m: nat): bool := andb (leb n m) (negb (beq_nat n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. reflexivity. Qed.

Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. reflexivity. Qed.

Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. reflexivity. Qed.

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

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

(** **** Exercise: 2 stars (andb_true_elim2)  *)
Theorem andb_true_elim2: forall b c: bool, andb b c = true -> c = true.
Proof.
  intros [] [].
  - intros H.
    reflexivity.
  - simpl.
    intros H.
    rewrite H.
    reflexivity.
  - reflexivity.
  - simpl.
    intros H.
    rewrite H.
    reflexivity.
Qed.

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

(** **** Exercise: 2 stars, optional (decreasing)  *)
(*
Fixpoint func (n: nat) (c: bool): bool :=
  match n, c with
  | 0, false => false
  | 0, true  => true
  | 1, false => false
  | 1, true => true
  | S (S n'), false => func n' true
  | S (S n'), true => func (S n') false
  end.
*)

(** **** Exercise: 2 stars (boolean_functions)  *)
Theorem identity_fn_applied_twice:
  forall (f: bool -> bool),
  (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

(** **** Exercise: 2 stars (andb_eq_orb)  *)
Theorem andb_eq_orb: forall (b c : bool),
  (andb b c = orb b c)-> b = c.
Proof.
  intros [] [].
  - simpl.
    reflexivity.
  - simpl.
    intro H.
    rewrite -> H.
    reflexivity.
  - simpl.
    intro H.
    rewrite H.
    reflexivity.
  - reflexivity.
Qed.

(** **** Exercise: 3 stars (binary)  *)
Inductive bin: Type :=
  | zero: bin
  | twice: bin -> bin
  | extra: bin -> bin.

Fixpoint incr (b: bin): bin :=
  match b with
  | zero => extra zero
  | twice b' => extra b'
  | extra b' => twice (incr b')
  end.

Example test_bin_incr1: incr zero = extra zero.
Proof. reflexivity. Qed.

Example test_bin_incr2: incr (incr zero) = twice (extra zero).
Proof. reflexivity. Qed.

Example test_bin_incr3: incr (incr (incr zero)) = extra (extra zero).
Proof. reflexivity. Qed.

Example test_bin_incr4: incr (incr (incr (incr zero))) = twice (twice (extra zero)).
Proof. reflexivity. Qed.

Example test_bin_incr5: incr (incr (incr (incr (incr zero)))) = extra (twice (extra zero)).
Proof. reflexivity. Qed.

Fixpoint bin_to_nat (b: bin): nat :=
  match b with
  | zero => 0
  | twice b' => 2 * bin_to_nat b'
  | extra b' => 1 + 2 * bin_to_nat b'
  end.

Example test_bin_to_nat1: bin_to_nat zero = 0.
Proof. reflexivity. Qed.

Example test_bin_to_nat2: bin_to_nat (incr zero) = 1.
Proof. reflexivity. Qed.

Example test_bin_to_nat3: bin_to_nat (incr (incr zero)) = 2.
Proof. reflexivity. Qed.

Example test_bin_to_nat4: bin_to_nat (incr (incr (incr zero))) = 3.
Proof. reflexivity. Qed.

Example test_bin_to_nat5: bin_to_nat (incr (incr (incr (incr zero)))) = 4.
Proof. reflexivity. Qed.


(***************************************
    Definitions and facts about words
    on the alphabet {O, I}
***************************************)

Require Import Arith.

Section Definitions.

  Inductive char : Type :=
    | O
    | I.

  Inductive word : Type :=
    | Void
    | Concat: char -> word -> word.

  Fixpoint size (w:word) :=
    match w with
    | Void => 0
    | Concat _ w => 1 + size (w)
    end.

  Fixpoint concat_words w1 w2 :=
    match w1 with
    | Void => w2
    | Concat c w =>
      Concat c (concat_words w w2)
    end.

  Notation "a ^ b" := (concat_words a b).

End Definitions.

Section Facts.

  Notation "a ^ b" := (concat_words a b).

  Lemma concat_w_void :
    forall w, w ^ Void = w.
  Proof.
    intros.
    - induction w.
      + simpl. reflexivity.
      + simpl. rewrite IHw. reflexivity.
  Qed.

  Lemma concat_assoc:
    forall w1 w2 w3, w1 ^ w2 ^ w3 = (w1 ^ w2) ^ w3.
  Proof.
    intros.
    induction w1.
    + simpl. reflexivity.
    + simpl. rewrite IHw1. reflexivity.
  Qed.

  Lemma size_concat :
    forall w1 w2, size (w1 ^ w2) = (size w1) + (size w2).
  Proof.
    intros.
    induction w1 as [|c w IH].
    + simpl. reflexivity.
    + simpl. rewrite IH. reflexivity.
  Qed.

  Lemma concat_w_void_void :
    forall w, concat_words w Void = Void -> w = Void.
  Proof.
    intros.
    induction w.
    + auto.
    + simpl in H.
      discriminate H.
  Qed.

  Lemma concat_w_w_void:
    forall u v,  u ^ v = Void -> u = Void /\ v = Void.
  Proof.
    intros.
    split.
    + induction v.
      ++ apply concat_w_void_void. assumption.
      ++ induction u.
        * auto.
        * discriminate H.
    + induction u.
      simpl in H; assumption.
      ++ induction v.
        * auto.
        * discriminate H.
  Qed.

  Lemma concat_left_void :
    forall v w,
      v ^ w = v -> w = Void.
  Proof.
    intros.
    induction v.
    + apply H.
    + simpl in H.
      inversion H.
      apply IHv. assumption.
  Qed.

  Lemma eq_size:
    forall u v,
      u = v -> size(u) = size(v).
  Proof.
    intros [|u H1] [|v H2].
    + auto.
    + intros []. auto.
    + intros []. auto.
    + intros.
      inversion H.
      reflexivity.
  Qed.

  Lemma size_le_concat_l:
    forall u v, size(v) <= size(u ^ v).
  Proof.
    intros.
    induction u.
    + simpl. auto.
    + simpl. apply le_S. assumption.
  Qed.

  Lemma size_le_concat_r:
    forall u v, size(v) <= size(v ^ u).
  Proof.
    intros.
    induction v.
    + simpl. apply Nat.le_0_l.
    + simpl. apply le_n_S. apply IHv.
  Qed.

  Lemma size_0_iff:
    forall u, u = Void <-> size(u) = 0.
  Proof.
    intros.
    split.
    + intro. rewrite H. auto.
    + intro. induction u.
      * reflexivity.
      * discriminate H.
  Qed.

  Lemma size_concat_void_l:
    forall u v, size(u ^ v) = size(v) <-> u = Void.
  Proof.
    intros.
    split.
    + rewrite size_concat.
      intro.
      rewrite Nat.add_comm in H.
      rewrite <- Nat.add_0_r in H.
      apply plus_reg_l in H.
      apply size_0_iff in H. assumption.
    + intro.
      rewrite H.
      auto.
  Qed.

  Lemma size_concat_void_r:
    forall u v, size(v ^ u) = size(v) <-> u = Void.
  Proof.
    intros.
    split.
    + rewrite size_concat.
      intro.
      rewrite <- Nat.add_0_r in H.
      apply plus_reg_l in H.
      apply size_0_iff in H. assumption.
    + intro.
      rewrite H.
      rewrite concat_w_void.
      auto.
  Qed.

  Lemma concat_void_iff:
    forall u v, u ^ v = Void <-> u = Void /\ v = Void.
  Proof.
    intros.
    split; intro.
    - apply eq_size in H.
      rewrite size_concat in H.
      simpl in H.
      apply plus_is_O in H.
      inversion H.
      apply size_0_iff in H0.
      apply size_0_iff in H1.
      auto.
    - elim H.
      intros H2 H3.
      rewrite H2, H3.
      simpl. reflexivity.
  Qed.

  Lemma size_concat_void_lr:
    forall u v w, size(u ^ v ^ w) = size(v) <-> u = Void /\ w = Void.
  Proof.
    intros.
    split.
    + intros.
      induction v.
      - simpl in H. apply size_0_iff in H.
        apply concat_w_w_void in H. assumption.
      - rewrite size_concat in H.
        rewrite size_concat in H.
        simpl in H. rewrite Nat.add_comm in H.
        simpl in H.
        inversion H.
        apply IHv.
        rewrite size_concat.
        rewrite size_concat.
        rewrite Nat.add_comm.
        assumption.
    + intros.
      inversion H.
      rewrite H0, H1.
      simpl. rewrite concat_w_void. reflexivity.
  Qed.

End Facts.


From HoTT Require Import Basics Types Spaces.Nat.

(** * Monoids *)

(** This defines the type of monoids as a record, which is equvialent to a nested sigma-type but has the convenience of 'named projections' (explained below). *)

Record Monoid := {
    monoid_type : Type;
    monoid_ishset : IsHSet monoid_type;
    monoid_unit : monoid_type;
    monoid_op : monoid_type -> monoid_type -> monoid_type;
    monoid_op_assoc : forall x y z,
      monoid_op x (monoid_op y z) = monoid_op (monoid_op x y) z;
    monoid_left_identity : forall x, monoid_op monoid_unit x = x;
    monoid_right_identity : forall x, monoid_op x monoid_unit = x;
  }.

(** [monoid_type], [monoid_op], etc... are "named projections" or "accessors". Given [M : Monoid], the underlying type is [monoid_type M]. Simlarly, [monoid_op M] is the binary operation. *)
Check monoid_type.

(** If we have [M : Monoid], then to pick an element of [M] we have to write [x : monoid_type M]. This line lets us simply write [x : M] by making [monoid_type] a coercion. *)
Coercion monoid_type : Monoid >-> Sortclass.

(** We make the monoid an implicit argument to some of the accessors, as Coq can usually figure it out. *)
Arguments monoid_unit {_}.
Arguments monoid_op {_} _ _.
Arguments monoid_left_identity {_} _.
Arguments monoid_right_identity {_} _.

(** This adds the fact that monoids are sets to Coq's "typeclass database," which lets us apply results about sets to monoids without having to repeatedly prove to Coq that monoids are sets. *)
Local Existing Instance monoid_ishset.

(** Standard notation. *)
Local Notation "1" := monoid_unit.
Local Notation "x * y" := (monoid_op x y).

Record MonoidHom (M N : Monoid) := {
    monoidhom_fun : M -> N;
    monoidhom_unit : monoidhom_fun 1 = 1;
    monoidhom_op : forall x y : M,
      monoidhom_fun (x * y) = monoidhom_fun x * monoidhom_fun y;
  }.

Coercion monoidhom_fun : MonoidHom >-> Funclass.

(** ** Basics *)

Lemma unique_left_unit (M : Monoid) (u : M)
  : (forall x : M, u * x = x) -> (u = 1).
Proof.
  intro is_left_unit_u.
  pose (u1 := is_left_unit_u 1).
  refine (_ @ u1). (* the symbol [@] is for path concatenation *)
  exact (monoid_right_identity u)^. (* the hat [^] inverts a path *)
Defined.

Lemma unique_right_unit (M : Monoid) (u : M)
  : (forall x : M, x * u = x) -> (u = 1).
Proof.
  intro is_right_unit_u.
  pose (u' := is_right_unit_u 1).
  exact ((monoid_left_identity u)^ @ u').
Defined.

(** Next, state and prove the following:  for [x] in a monoid, if [y] is a left-inverse to [x] and [z] is a right-inverse to [x], then [y = z]. *)
(** It follows that two two-sided inverses are equal.  Do you think it is true that two left-inverses are necessarily equal? *)

Lemma inverses_coincide (M : Monoid) (x y z : M) : (y * x = 1) * (x * z = 1) -> (y = z).
Proof.
  intro pq; destruct pq as (p,q).
  pose (y_unit := (monoid_right_identity y)^).
  pose (z_unit := monoid_left_identity z).
  pose (y_path := y_unit @ (ap (monoid_op(y)) q)^ @ (monoid_op_assoc _ y x z)).
  exact (y_path @ (ap (fun m => m*z)) p @ z_unit).
Defined.

(** ** The two monoid structures on [Bool] *)

(** Look at the definition of [Bool] in Types/Bool. There are two monoid structures on [Bool], one using [andb] and one using [orb]. *)

Definition monoid_bool_orb : Monoid.
Proof.
  (* Coq automatically gives us a function [Build_Monoid] which lets us construct monoids. *)
  (* [srapply] is a custom tactic in the HoTT library which figures out how many arguments need to be supplied to a function and leaves those as goals for you to figure out. *)
  srapply (Build_Monoid Bool).
  - exact false.
  - intros b1 b2. exact (orb b1 b2).
  - simpl.
    induction x; induction y; reflexivity.
  - simpl. reflexivity.
  - simpl. induction x; reflexivity.
Defined.

Definition monoid_bool_andb : Monoid.
Proof.
  srapply (Build_Monoid Bool).
  - exact true.
  - intros b1 b2. exact (andb b1 b2).
  - induction x; induction y; reflexivity.
  - simpl. reflexivity.
  - simpl. induction x; reflexivity.
Defined.

(** The negation function [negb] defines a homomorphism between these monoid structures. *)

Definition monoid_negb : MonoidHom monoid_bool_andb monoid_bool_orb.
  srapply Build_MonoidHom.
  - intro b. induction b.
    + exact false.
    + exact true.
  - simpl. reflexivity.
  - simpl. induction x; reflexivity.
Defined.

(** ** The monoid structure on [nat] *)

(** Next show that set of natural numbers is a monoid. The natural numbers are defined in Basics/Overture (search for "Natural numbers"), and there are useful functions in Spaces/Nat. You can also use Coq's search functionality to find things, by giving the signature of the term that you want: *)
Search (nat -> nat -> nat).

Definition monoid_nat : Monoid.
Proof.
srapply (Build_Monoid nat).
- exact O.
- exact add.
- intros x y z. induction x.
  + reflexivity.
  + exact (ap (add 1) IHx).
- reflexivity.
- induction x.
  + reflexivity.
  + exact (ap (add 1) IHx).
Defined.

(* Need to prove that everything in the image of the proposed homomorphism below commutes, so I define it as a
   function of its underlying types first and check the identifications in the next Lemma. *)

(* Essentially exponentiation on x by natural numbers *)
Definition ptd_mon_function (M : Monoid) (x : M) : monoid_nat -> M.
Proof.
  - intro n. induction n.
    + exact 1.
    + exact (IHn * x).
Defined.

(* Is there a way to coerce Coq into understanding a different encoding for a function? Writing
   ptd_mon_function M x for each application is a bit cumbersome and obfuscates the code, but I wanted a
   descriptive name. *)
Lemma xy_paths_commute (M : Monoid) (x : M) : forall y, (ptd_mon_function _ x y)*x = x*(ptd_mon_function _ x y).
Proof.
  intro y. induction y.
  + cbn.
    pose (u1 := monoid_left_identity x).
    pose (u2 := (monoid_right_identity x)^).
    exact (u1 @ u2).
  + cbn.
    pose (ap_IH := ap (fun m => m*x) IHy).
    pose (assoc := monoid_op_assoc M x (ptd_mon_function M x y) x).
    exact (ap_IH @ assoc^).
Defined.

(** Next state and prove that if [M] is any monoid with a chosen element [x], there is a monoid homomorphism from [nat] to [M] sending [1] to [x]. *)

(* Jarl and I did a similar path concatenation on the board; is there a more concise way of making this proof go through? *)

Lemma pointed_monoid_from_nat (M : Monoid) (x : M) : MonoidHom monoid_nat M.
Proof.
srapply Build_MonoidHom.
- exact (ptd_mon_function M x).
- cbn. reflexivity.
- intros x0. cbn. induction x0.
  + intro y. cbn. symmetry. apply monoid_left_identity.
  + intro y. cbn.
    pose (ap_IH := ap (fun m => m*x) (IHx0 y)).
    pose (assoc := monoid_op_assoc M (ptd_mon_function M x x0) (ptd_mon_function M x y) x).
    pose (IH_assoc := ap_IH @ assoc^).
    pose (ap_comm_paths := ap (monoid_op (ptd_mon_function M x x0)) (xy_paths_commute M x y)).
    pose (IH_assoc_comm := IH_assoc @ ap_comm_paths).
    pose (assoc' := monoid_op_assoc M (ptd_mon_function M x x0) x (ptd_mon_function M x y)).
    exact (IH_assoc_comm @ assoc').
Defined.


(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    [Smallstep] chapter of _Programming Language Foundations_),
    so readers who are already comfortable with these ideas can safely
    skim or skip this chapter.  However, relations are also a good
    source of exercises for developing facility with Coq's basic
    reasoning facilities, so it may be useful to look at this material
    just after the [IndProp] chapter. *)

Set Warnings "-notation-overridden,-parsing".
Require Export IndProp.

(* ################################################################# *)
(** * Relations *)

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

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

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.
(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ################################################################# *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(* ----------------------------------------------------------------- *)
(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional (total_relation_not_partial)  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)

Check total_relation.
Search total_relation.
Theorem total_relation_not_partial :
  ~(partial_function total_relation).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply tot_rel.
    - apply tot_rel.
    }
  inversion Nonsense.   Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (empty_relation_partial)  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)

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

(* ----------------------------------------------------------------- *)
(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional (le_trans_hard_way)  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
    (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (lt_trans'')  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional (le_S_n)  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.

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

(** **** Exercise: 1 star, optional (le_Sn_n)  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(* ----------------------------------------------------------------- *)
(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional (le_not_symmetric)  *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional (le_antisymmetric)  *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  intros a b LH RH. inversion LH as [ | a1 Hab ].
  - reflexivity.
  - assert (S a1 <= a1).
    {
      apply le_trans with a.
      rewrite -> H.
      + assumption.
      + assumption.
    }
    apply le_Sn_n in H0.
    inversion H0.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (le_step)  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  intros n m p Hnm Hmp. unfold lt in Hnm.
  assert (S n <= S p).
  {
    apply le_trans with m.
    - assumption.
    - assumption.
  }
  apply le_S_n.
  assumption.
Qed.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* ----------------------------------------------------------------- *)
(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ################################################################# *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  intros X R  x y z Hxy Hyz.
  induction Hxy as [x| x y y' Rxy Hyy].
  - assumption.
  - apply rt1n_trans with y.
    + assumption.
    + apply IHHyy in Hyz. apply Hyz.
Qed.
(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)


Require Import init.

Require Export nat_base.
Require Export nat_plus.
Require Export nat_mult.
Require Export nat_order.
Require Export nat_binom.

Fixpoint nat_mult {U} `{Plus U, Zero U} (a : nat) (b : U) :=
    match a with
    | nat_zero => 0
    | nat_suc a' => b + nat_mult a' b
    end.
Infix "×" := nat_mult (at level 40, left associativity).
Arguments nat_mult : simpl never.

Fixpoint nat_pow {U} `{Mult U} `{One U} a b :=
    match b with
    | nat_zero => 1
    | nat_suc b' => nat_pow a b' * a
    end.
Infix "^" := nat_pow : nat_scope.
Arguments nat_pow : simpl never.

(* begin hide *)
Section NatAbstract.

Context {U} `{OrderedField U}.
Local Open Scope nat_scope.
(* end hide *)
Theorem nat_mult_lanni : ∀ a, 0 × a = 0.
Proof.
    reflexivity.
Qed.

Theorem nat_mult_suc : ∀ n a, (nat_suc n) × a = a + n × a.
Proof.
    reflexivity.
Qed.

Theorem nat_mult_ranni : ∀ a, a × 0 = 0.
Proof.
    intros a.
    nat_induction a.
    -   apply nat_mult_lanni.
    -   rewrite nat_mult_suc.
        rewrite plus_lid.
        exact IHa.
Qed.

Theorem nat_mult_lid : ∀ a, 1 × a = a.
Proof.
    intros a.
    rewrite <- nat_one_eq.
    rewrite nat_mult_suc, nat_mult_lanni.
    apply plus_rid.
Qed.

Theorem nat_mult_ldist : ∀ a b c, a × (b + c) = a × b + a × c.
Proof.
    intros a b c.
    nat_induction a.
    -   do 3 rewrite nat_mult_lanni.
        rewrite plus_lid.
        reflexivity.
    -   do 3 rewrite nat_mult_suc.
        do 2 rewrite <- plus_assoc.
        apply lplus.
        rewrite plus_assoc.
        rewrite (plus_comm (a × b) c).
        rewrite <- plus_assoc.
        apply lplus.
        exact IHa.
Qed.

Theorem nat_mult_rdist : ∀ a b c, (a + b) × c = a × c + b × c.
Proof.
    intros a b c.
    nat_induction a.
    -   rewrite nat_mult_lanni.
        do 2 rewrite plus_lid.
        reflexivity.
    -   rewrite nat_plus_lsuc.
        do 2 rewrite nat_mult_suc.
        rewrite IHa.
        apply plus_assoc.
Qed.

Theorem nat_mult_mult : ∀ a b c, a × (b × c) = (a * b) × c.
Proof.
    intros a b c.
    nat_induction a.
    -   rewrite mult_lanni.
        do 2 rewrite nat_mult_lanni.
        reflexivity.
    -   rewrite nat_mult_suc.
        rewrite nat_mult_lsuc.
        rewrite IHa.
        rewrite nat_mult_rdist.
        reflexivity.
Qed.

Theorem nat_mult_rneg : ∀ a b, -(a × b) = a × (-b).
Proof.
    intros a b.
    nat_induction a.
    -   do 2 rewrite nat_mult_lanni.
        apply neg_zero.
    -   do 2 rewrite nat_mult_suc.
        rewrite neg_plus.
        rewrite IHa.
        reflexivity.
Qed.

Theorem nat_pow_zero : ∀ a, a ^ 0 = 1.
Proof.
    reflexivity.
Qed.

Theorem nat_pow_suc : ∀ a n, a ^ (nat_suc n) = a^n * a.
Proof.
    reflexivity.
Qed.

Theorem zero_nat_pow : ∀ n, 0 ^ (nat_suc n) = 0.
Proof.
    intros n.
    rewrite nat_pow_suc.
    apply mult_ranni.
Qed.

Theorem nat_pow_one : ∀ a, a ^ 1 = a.
Proof.
    intros a.
    rewrite <- nat_one_eq.
    rewrite nat_pow_suc.
    rewrite nat_pow_zero.
    apply mult_lid.
Qed.

Theorem one_nat_pow : ∀ n, 1 ^ n = 1.
Proof.
    nat_induction n.
    -   apply nat_pow_zero.
    -   rewrite nat_pow_suc.
        rewrite IHn.
        apply mult_lid.
Qed.

Theorem nat_pow_plus : ∀ a m n, a ^ (m + n) = a ^ m * a ^ n.
Proof.
    intros a m n.
    nat_induction n.
    -   rewrite nat_pow_zero, mult_rid.
        rewrite plus_rid.
        reflexivity.
    -   rewrite nat_plus_rsuc.
        do 2 rewrite nat_pow_suc.
        rewrite IHn.
        rewrite mult_assoc.
        reflexivity.
Qed.

Theorem nat_pow_mult : ∀ a b n, (a * b) ^ n = a ^ n * b ^ n.
Proof.
    intros a b n.
    nat_induction n.
    -   do 3 rewrite nat_pow_zero.
        rewrite mult_lid.
        reflexivity.
    -   do 3 rewrite nat_pow_suc.
        rewrite IHn.
        do 2 rewrite <- mult_assoc.
        apply lmult.
        do 2 rewrite mult_assoc.
        apply rmult.
        apply mult_comm.
Qed.

Theorem nat_pow_pow : ∀ a m n, (a ^ m) ^ n = a ^ (m * n).
Proof.
    intros a m n.
    nat_induction n.
    -   rewrite mult_ranni.
        do 2 rewrite nat_pow_zero.
        reflexivity.
    -   rewrite nat_pow_suc.
        rewrite IHn.
        rewrite nat_mult_rsuc.
        rewrite nat_pow_plus.
        apply mult_comm.
Qed.

Theorem nat_pow_not_zero : ∀ a n, 0 ≠ a → 0 ≠ a ^ n.
Proof.
    intros a n a_nz eq.
    nat_induction n.
    -   rewrite nat_pow_zero in eq.
        exact (not_trivial_one eq).
    -   apply IHn.
        rewrite nat_pow_suc in eq.
        pose proof (mult_zero _ _ eq) as [an_z|a_z].
        +   exact an_z.
        +   contradiction.
Qed.

Theorem nat_pow_neg_even : ∀ n, (-1) ^ (2*n) = 1.
Proof.
    intros n.
    nat_induction n.
    -   rewrite mult_ranni.
        apply nat_pow_zero.
    -   rewrite nat_mult_rsuc.
        rewrite nat_pow_plus.
        rewrite IHn.
        rewrite mult_rid.
        rewrite nat_pow_plus.
        rewrite nat_pow_one.
        rewrite mult_neg_one.
        apply neg_neg.
Qed.

Theorem nat_pow_neg_odd : ∀ n, (-1) ^ (2*n + 1) = -1.
Proof.
    intros n.
    rewrite nat_pow_plus.
    rewrite nat_pow_neg_even.
    rewrite mult_lid.
    apply nat_pow_one.
Qed.

Theorem nat_pow_neg_binom2 : ∀ n,
    (-1) ^ binom (nat_suc (nat_suc n)) 2 = -(-1) ^ binom n 2.
Proof.
    intros n.
    change 2 with (nat_suc (nat_suc 0)) at 1.
    do 3 rewrite binom_suc.
    rewrite binom_zero.
    rewrite binom_one.
    rewrite <- plus_assoc.
    rewrite nat_pow_plus.
    rewrite nat_pow_one.
    rewrite mult_neg_one.
    rewrite plus_assoc.
    rewrite plus_two.
    rewrite nat_pow_plus.
    rewrite nat_pow_neg_even.
    rewrite mult_lid.
    reflexivity.
Qed.

Theorem nat_pow_pos : ∀ a n, 0 ≤ a → 0 ≤ a^n.
Proof.
    intros a n a_pos.
    nat_induction n.
    -   rewrite nat_pow_zero.
        apply one_pos.
    -   rewrite nat_pow_suc.
        apply le_mult; assumption.
Qed.

Theorem nat_pow_pos2 : ∀ a n, 0 < a → 0 < a^n.
Proof.
    intros a n a_pos.
    nat_induction n.
    -   rewrite nat_pow_zero.
        exact one_pos.
    -   rewrite nat_pow_suc.
        apply lt_mult; assumption.
Qed.

Theorem nat_pow_le : ∀ a m n, 1 ≤ a → m ≤ n → a^m ≤ a^n.
Proof.
    intros a m n a_ge mn.
    apply nat_le_ex in mn as [c eq]; subst.
    nat_induction c; [>rewrite plus_rid; apply refl|].
    rewrite nat_plus_rsuc.
    rewrite nat_pow_suc.
    apply (trans IHc).
    rewrite <- le_mult_1_a_b_ba_pos.
    +   exact a_ge.
    +   apply nat_pow_pos2.
        exact (lt_le_trans one_pos a_ge).
Qed.

Theorem nat_pow_lt : ∀ a m n, 1 < a → m < n → a^m < a^n.
Proof.
    intros a m n a_gt mn.
    assert (∀ n, a ^ n < a ^ n * a) as lemma.
    {
        clear m n mn.
        intros n.
        rewrite <- lt_mult_1_a_b_ba_pos.
        +   exact a_gt.
        +   apply nat_pow_pos2.
            exact (trans one_pos a_gt).
    }
    apply nat_lt_ex in mn as [c eq]; subst.
    rewrite nat_plus_rsuc.
    nat_induction c.
    -   rewrite plus_rid.
        apply lemma.
    -   rewrite nat_pow_suc.
        apply (trans IHc).
        rewrite nat_plus_rsuc.
        apply lemma.
Qed.

Theorem nat_pow_le_one : ∀ a n, 1 ≤ a → 1 ≤ a^n.
Proof.
    intros a n a_one.
    nat_induction n.
    -   rewrite nat_pow_zero.
        apply refl.
    -   rewrite nat_pow_suc.
        rewrite <- (mult_lid 1).
        apply le_lrmult_pos; [>
            apply one_pos|
            apply one_pos|
            exact IHn|
            exact a_one
        ].
Qed.

Theorem nat_pow_lt_one : ∀ a n, 1 < a → 1 < a^(nat_suc n).
Proof.
    intros a n a_one.
    nat_induction n.
    -   rewrite nat_pow_one.
        exact a_one.
    -   rewrite nat_pow_suc.
        rewrite <- (mult_lid 1).
        apply lt_lrmult_pos; [>
            apply one_pos|
            apply one_pos|
            exact IHn|
            exact a_one
        ].
Qed.
(* begin hide *)
End NatAbstract.
(* end hide *)


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

Require Import Logic.Fol.Syntax.
Require Import Logic.Fol.Functor.

Definition congruent (v:Type) (r:Rel (P v)) : Prop :=
    (forall (p1 p2 q1 q2:P v), r p1 q1 -> r p2 q2 -> r (Imp p1 p2) (Imp q1 q2)) /\
    (forall (x:v) (p1 q1:P v), r p1 q1 -> r (All x p1) (All x q1)).

Arguments congruent {v} _.

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

Arguments congruence {v} _.

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

(* Congruence relation generated by a given relation on P v.                    *)
Inductive Cong (v:Type) (r:Rel (P v)) : Rel (P v) :=
| CongBase  : forall (p q:P v), r p q -> Cong v r p q
| CongRefl  : forall (p:P v), Cong v r p p
| CongSym   : forall (p q:P v), Cong v r p q -> Cong v r q p
| CongTrans : forall (p q t:P v), Cong v r p q -> Cong v r q t -> Cong v r p t
| CongImp   : forall (p1 p2 q1 q2:P v),
    Cong v r p1 q1 ->
    Cong v r p2 q2 ->
    Cong v r (Imp p1 p2) (Imp q1 q2)
| CongAll   : forall (x:v) (p1 q1:P v),
    Cong v r p1 q1 ->
    Cong v r (All x p1 )(All x q1)
.

Arguments Cong      {v}.
Arguments CongBase  {v}.
Arguments CongRefl  {v}.
Arguments CongSym   {v}.
Arguments CongTrans {v}.
Arguments CongImp   {v}.
Arguments CongAll   {v}.

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

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

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

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

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

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

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

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


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rbasic_fun.
Require BuiltIn.
Require real.Real.

Import Rbasic_fun.

(* Why3 comment *)
(* abs is replaced with (Reals.Rbasic_fun.Rabs x) by the coq driver *)

(* Why3 goal *)
Lemma abs_def : forall (x:R), ((0%R <= x)%R ->
  ((Reals.Rbasic_fun.Rabs x) = x)) /\ ((~ (0%R <= x)%R) ->
  ((Reals.Rbasic_fun.Rabs x) = (-x)%R)).
split ; intros H.
apply Rabs_right.
now apply Rle_ge.
apply Rabs_left.
now apply Rnot_le_lt.
Qed.

(* Why3 goal *)
Lemma Abs_le : forall (x:R) (y:R), ((Reals.Rbasic_fun.Rabs x) <= y)%R <->
  (((-y)%R <= x)%R /\ (x <= y)%R).
intros x y.
unfold Rabs.
case Rcase_abs ; intros H ; (split ; [intros H0;split | intros (H0,H1)]).
rewrite <- (Ropp_involutive x).
now apply Ropp_le_contravar.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
apply Rle_trans with (2 := H0).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
now apply Rlt_le.
rewrite <- (Ropp_involutive y).
now apply Ropp_le_contravar.
apply Rge_le in H.
apply Rle_trans with (2 := H).
apply Rle_trans with (Ropp x).
now apply Ropp_le_contravar.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
exact H0.
exact H1.
Qed.

(* Why3 goal *)
Lemma Abs_pos : forall (x:R), (0%R <= (Reals.Rbasic_fun.Rabs x))%R.
exact Rabs_pos.
Qed.

(* Why3 goal *)
Lemma Abs_sum : forall (x:R) (y:R),
  ((Reals.Rbasic_fun.Rabs (x + y)%R) <= ((Reals.Rbasic_fun.Rabs x) + (Reals.Rbasic_fun.Rabs y))%R)%R.
exact Rabs_triang.
Qed.

(* Why3 goal *)
Lemma Abs_prod : forall (x:R) (y:R),
  ((Reals.Rbasic_fun.Rabs (x * y)%R) = ((Reals.Rbasic_fun.Rabs x) * (Reals.Rbasic_fun.Rabs y))%R).
exact Rabs_mult.
Qed.

(* Why3 goal *)
Lemma triangular_inequality : forall (x:R) (y:R) (z:R),
  ((Reals.Rbasic_fun.Rabs (x - z)%R) <= ((Reals.Rbasic_fun.Rabs (x - y)%R) + (Reals.Rbasic_fun.Rabs (y - z)%R))%R)%R.
intros x y z.
replace (x - z)%R with ((x - y) + (y - z))%R by ring.
apply Rabs_triang.
Qed.


Inductive month : Set :=
  | January  | February | March  | April     | May
  | June     | July    | August | September | October
  | November | December.

Print month_rect.
Print month_ind.
Print month_rec.

Inductive season : Set :=
  | Winter | Spring | Summer | Fall.

Print month_rec.

Definition season_for_month : month -> season
  := month_rec (fun _ => season)
               Winter Winter Winter
               Spring Spring Spring
               Summer Summer Summer
               Fall Fall Fall.

Print season_for_month.

Definition season_for_month' (m : month) : season :=
  match m with
      | January => Winter
      | February => Winter
      | March => Winter
      | April => Spring
      | May => Spring
      | June => Spring
      | July => Summer
      | August => Summer
      | September => Summer
      | October => Fall
      | November => Fall
      | December => Fall
  end.

Theorem month_equal :
  forall m : month, m = January \/ m = February \/ m = March     \/
                    m = April   \/ m = May      \/ m = June      \/
                    m = July    \/ m = August   \/ m = September \/
                    m = October \/ m = November \/ m = December.
Proof.
  intro m.
  pattern m.
  Check month_ind.
  apply month_ind.
  left. reflexivity.
  right. left. reflexivity.
  right. right. left. reflexivity.
  right. right. right. left. reflexivity.
  right. right. right. right. left. reflexivity.
  right. right. right. right. right. left. reflexivity.
  right. right. right. right. right. right. left. reflexivity.
  right. right. right. right. right. right. right. left. reflexivity.
  right. right. right. right. right. right. right. right. left. reflexivity.
  right. right. right. right. right. right. right. right. right. left. reflexivity.
  right. right. right. right. right. right. right. right. right.
  right. left. reflexivity.
  right. right. right. right. right. right. right. right. right.
  right. right. reflexivity.
Qed.

(* right? right. *)

Theorem bool_equal_0 : forall b : bool, b = true \/ b = false.
Proof.
  Check bool_ind.
  Check or_introl.
  Check or_intror.
  Check refl_equal.
  Check (bool_ind (fun b : bool => b = true \/ b = false)
                  (or_introl _ (refl_equal true))
                  (or_intror _ (refl_equal false))).
  exact (bool_ind (fun b : bool => b = true \/ b = false)
                  (or_introl _ (refl_equal true))
                  (or_intror _ (refl_equal false))).
Qed.

Theorem t : True \/ True.
Proof.
  Print or_introl.
  Print True.
  exact (or_introl True I).
Qed.

(* yep.. still don't know what I'm doing... :-[ *)

Theorem bool_equal_1 : forall b : bool, b = true \/ b = false.
Proof.
  intro b.
  pattern b.
  Check bool_ind.
  apply bool_ind.
  left.
  reflexivity.
  right.
  reflexivity.
Qed.

Definition f_0 (b : bool) :=
  match b with
  | true  => 1
  | false => 2
  end.

Print f_0.

Definition month_length (leap : bool) (m : month) : nat :=
  match m with
  | January  => 31
  | February => if leap then 29 else 28
  | March => 31
  | April => 30
  | May => 31
  | June => 30
  | July => 31
  | August => 31
  | September => 30
  | October => 31
  | November => 30
  | December => 31
  end.

Check month_rec.
Definition month_length' (leap : bool) : month -> nat :=
  month_rec (fun (m : month) => nat)
            31
            (if leap then 29 else 28)
            31
            30
            31
            30
            31
            31
            30
            31
            30
            31.

Definition month_length'' (leap : bool) (m : month) : nat :=
  match m with
  | February => if leap then 29 else 28
  | April => 30
  | June => 30
  | September => 30
  | November => 30
  | otherwise => 31
  end.

Eval compute in month_length'' false April.

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

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

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

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

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

  Theorem bool_xor_not_eq_iso : forall b1 b2 : bool,
                                     bool_xor b1 b2 = bool_not (bool_eq b1 b2).
  Proof.
    intros b1 b2.
    unfold bool_xor.
    unfold bool_not.
    unfold bool_eq.
    pattern b1.
    apply bool_ind.
    reflexivity.
    pattern b2.
    apply bool_ind.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

  Theorem bool_not_and_iso_or_not_not : forall b1 b2 : bool,
                                          bool_not (bool_and b1 b2) =
                                          bool_or (bool_not b1) (bool_not b2).
  Proof.
    intros b1 b2.
    unfold bool_or.
    pattern b1.
    apply bool_ind.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

  Theorem bool_not_not_iso : forall b : bool, bool_not (bool_not b) = b.
  Proof.
    apply bool_ind.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

  Theorem bool_or_not_iso_true : forall b : bool, bool_or b (bool_not b) = true.
  Proof.
    apply bool_ind.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

  Theorem bool_eq_iso_eq : forall b1 b2 : bool, b1 = b2 -> bool_eq b1 b2 = true.
  Proof.
    intros b1 b2.
    pattern b2.
    apply bool_ind.
    intros H_b1_eq_true.
    rewrite -> H_b1_eq_true.
    simpl bool_eq.
    reflexivity.
    intros H_b1_eq_false.
    rewrite -> H_b1_eq_false.
    simpl bool_eq.
    reflexivity.
  Qed.

  Theorem not_or_eq_and_not_not : forall b1 b2 : bool,
                                    bool_not (bool_or b1 b2) = bool_and (bool_not b1)
                                                                        (bool_not b2).
  Proof.
    intros b1 b2.
    pattern b1.
    apply bool_ind.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

  Theorem or_and_and_eq_and_or : forall b1 b2 b3 : bool,
                                   bool_or (bool_and b1 b3) (bool_and b2 b3) =
                                   bool_and (bool_or b1 b2) b3.
  Proof.
    intros b1 b2 b3.
    pattern b1.
    apply bool_ind.
    simpl.
    pattern b2.
    apply bool_ind.
    simpl.
    unfold bool_or.
    pattern b3.
    apply bool_ind.
    reflexivity.
    reflexivity.
    pattern b3.
    apply bool_ind.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.
End ex_6_6.

Require Import ZArith.

Inductive plane : Set := point : Z -> Z -> plane.

Print plane_ind.

Definition abscissa (p : plane) : Z :=
  match p with point x y => x end.

Reset plane.

Record plane : Set := point { abscissa : Z; ordinate : Z }.

Print plane.

Print abscissa.

Open Scope Z_scope.

Definition ex_6_8 (p : plane) : Z :=
  let (abscissa, ordinate) := p
  in Zabs abscissa + Zabs ordinate.

Eval compute in ex_6_8 (point 1 3).

Inductive vehicle : Set :=
  | bicycle   : nat -> vehicle
  | motorized : nat -> nat -> vehicle.

Print vehicle_ind.

Definition nb_wheels (v : vehicle) : nat :=
  match v with
  | bicycle _     => 2%nat
  | motorized _ n => n
  end.

Definition nb_seats (v : vehicle) : nat :=
  match v with
  | bicycle   n   => n
  | motorized n _ => n
  end.

Check vehicle_rec.

Definition nb_seats' (v : vehicle) : nat :=
  vehicle_rec (fun _   => nat)
              (fun n   => n)
              (fun n _ => n)
              v.

Print nb_seats'.

Open Scope nat_scope.

Theorem at_least_28 : forall (leap:bool) (m:month), 28 <= month_length leap m.
Proof.
  intros leap m.
  case m ; simpl ; auto with arith.
  case leap; simpl ; auto with arith.
Qed.

Reset at_least_28.

Theorem at_least_28 : forall (leap:bool) (m:month), 28 <= month_length leap m.
Proof.
  intros leap m.
  case m.
  simpl month_length.
  Check le_n.
  Check le_S.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  case leap.
  apply le_S.
  apply le_n.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_n.
  simpl month_length.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
Qed.

(* that was tiring *)
Print at_least_28.
Print le_S.

Definition next_month (m : month) : month :=
  match m with
      January => February | February  => March     | March     => April
  |   April   => May      | May       => June      | June      => July
  |   July    => August   | August    => September | September => October
  |   October => November | November  => December  | December  => January
  end.

(* this version is way less interesting. *)
Theorem next_auguest_then_july_boring :
  forall m : month, m = July -> next_month m = August.
Proof.
  intros m.
  intros H_m_eq_july.
  rewrite -> H_m_eq_july.
  simpl.
  reflexivity.
Qed.

Theorem next_august_then_july :
  forall m : month, next_month m = August -> m = July.
Proof.
  intros m.
  case m ; simpl ; intros H_next_eq; discriminate H_next_eq || reflexivity.
  (* The above was very compact, but I think some connectives would
improve understandably. *)
Qed.

(* I am having a hard time understanding the evidence function of this: *)
Print next_august_then_july.
(* a bit complex no? *)

Theorem not_January_eq_February : ~January = February.
Proof.
  unfold not.
  intros H_january_eq_february.
  change ((fun m:month => match m with January => True | _ => False end)
          February).
  rewrite <- H_january_eq_february.
  trivial.
Qed.

Print month_rect.

Definition is_January' (m:month) : Prop :=
  match m with
    January => True
  | _       => False
  end.

Definition is_January (m:month) : Prop :=
  month_rect (fun _ => Prop)
             True
             False
             False
             False
             False
             False
             False
             False
             False
             False
             False
             False
             m.

Eval compute in is_January January.
Eval compute in is_January March.

Theorem not_true_false : ~true = false.
Proof.
  unfold not.
  intros H_eq.
  change ((fun (v:bool) => match v with true => True | false => False end)
          false).
  rewrite <- H_eq.
  trivial.
Qed.

Print not_true_false.

Theorem not_bike_eq_moto : forall (n m : nat), ~(bicycle n = motorized n m).
Proof.
  intros n m.
  unfold not.
  intro H_eq.
  change ((fun (v : vehicle) => match v with
                                  bicycle _ => True
                                | motorized _ _ => False
                                end)
          (motorized n m)).
  rewrite <- H_eq.
  trivial.
Qed.

Theorem not_bike_eq_moto' : forall (n m : nat), ~(bicycle n = motorized n m).
Proof.
  intros n m.
  unfold not.
  intros H_eq.
  discriminate H_eq.
Qed.


(*|
#######################################
Coq: adding a "strong induction" tactic
#######################################

:Link: https://stackoverflow.com/q/20883855
|*)

(*|
Question
********

"Strong" (or "complete") induction on the natural number means that
when proving the induction step on ``n``, you can assume the property
holds for any ``k``
|*)

Require Import PeanoNat. (* .none *)
Theorem strong_induction :
  forall P : nat -> Prop,
    (forall n : nat, (forall k : nat, (k < n -> P k)) -> P n) ->
    forall n : nat, P n.

(*| .. coq:: none |*)

Proof.
  intros P H n. induction n; apply H; intros k H0.
  - contradiction (Nat.nlt_0_r k).
  - rewrite Nat.lt_succ_r, Nat.le_lteq in H0. destruct H0.
    + clear IHn. revert k H0. induction n; intros k H0.
      * contradiction (Nat.nlt_0_r k).
      * rewrite Nat.lt_succ_r, Nat.le_lteq in H0. destruct H0.
        -- exact (IHn _ H0).
        -- subst k. exact (H _ IHn).
    + now subst k.
Qed.

(*|
I have managed to prove this theorem without too many difficulties.
Now I want to use it in a new tactic, ``strong_induction``, which
should be similar to the standard ``induction n`` technique on the
natural numbers. Recall that when using ``induction n`` when ``n`` is
a natural number and the goal is ``P(n)``, we get two goals: one of
the form ``P(0)`` and the second of the form ``P(S(n))``, where for
the second goal we get ``P(n)`` as assumption.

So I want, when the current goal is ``P(n)``, to get one new goal,
also ``P(n)``, but the new assumption ``forall k : nat, (k < n ->
P(k)))``.

The problem is I don't know how to do it technically. My main problem
is this: suppose ``P`` is a complex statement, i.e.

.. coq:: none
|*)

Goal forall a b, exists q r : nat, a = b * q + r.
  intros a b.

(*||*)

  Show. (* .unfold .goals *)

(*|
with ``a b : nat`` in the context; how can I tell Coq to do the strong
induction on ``a`` and not on ``b``? Simply doing ``apply
strong_induction`` results in
|*)

  apply strong_induction; intros. (* .none *)
  Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
where the assumption is useless (since ``n`` does not relate to ``a``)
and I have no idea what the second goal means.
|*)

(*|
Answer
******

In this case, to ``apply strong_induction`` you need to ``change`` the
conclusion of the goal so that it better matches the conclusion of the
theorem.
|*)

Goal forall a b, b <> 0 -> exists ! q r, a = q * b + r /\ r < b.
  change (forall a, (fun c => forall b,
                         b <> 0 -> exists ! q r, c = q * b + r /\ r < b) a).
  eapply strong_induction.
Abort. (* .none *)

(*|
You could also use more directly the ``refine`` tactic. This tactic is
similar to the ``apply`` tactic.
|*)

Goal forall a b, b <> 0 -> exists ! q r, a = q * b + r /\ r < b.
  refine (strong_induction _ _).
Abort. (* .none *)

(*|
But the ``induction`` tactic already handles arbitrary induction
principles.
|*)

Goal forall a b, b <> 0 -> exists ! q r, a = q * b + r /\ r < b.
  induction a using strong_induction.

(*|
More on these tactics `here
<http://coq.inria.fr/refman/tactic-index.html>`__. You should probably
use ``induction`` before ``intro``-ing and ``split``-ing.

----

**Q:** ``induction a using strong_induction`` works great! On the
other hand, the ``change`` tactic fails with "Error: Not convertible."

**A:** when the change is too complex, you can try with the
``replace`` tactic, which will ask for a proof of equality. ``change``
is just ``replace`` when the proof is trivially reflexivity.
|*)


Require Import Arith.

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

Theorem sum_of_nat : forall n:nat, 2 * sum n = n * (n + 1).
Proof.
  intro n.
  induction n.
    simpl.
    reflexivity.

    unfold sum; fold sum.
    rewrite mult_plus_distr_l.
    rewrite IHn.
    ring.
Qed.


Require Import PeanoNat.
Require Import Hack.CMP.Arith.
Require Import Hack.CMP.Bounded.

Definition decr(f : nat -> nat) := forall n, f (S n) <= f n.

Theorem decr_estimate: forall f, decr f -> forall x y, x <= y -> f y <= f x.
Proof.
  intros f D x.
  induction y.
  + intro.
    rewrite (proj1 (Nat.le_0_r _) H).
    apply le_n.
  + intro.
    case (Nat.eq_dec x (S y)).
    - intro.
      rewrite e.
      apply le_n.
    - intro.
      pose (p := IHy (leq_and_not' _ _ H n)).
      pose (q := D y).
      Nat.order.
Qed.

Theorem decr_is_bounded: forall f, decr f -> bounded f.
Proof.
  intros.
  refine (ex_intro _ (f 0) _).
  unfold bounded_by.
  induction x.
  - exact (le_n (f 0)).
  - pose (p := H x).
    Nat.order.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Functions                                                               *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic.
Generalizable Variables A.

(* ********************************************************************** *)
(** * Function combinators *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of the combinators *)

(** Indentity function *)

Definition id {A} (x : A) :=
  x.

(** Constant function *)

Definition const {A B} (v : B) : A -> B :=
  fun _ => v.

(** Constant function of higher arities *)

Definition const1 :=
  @const.
Definition const2 {A1 A2 B} (v:B) : A1->A2->B :=
  fun _ _ => v.
Definition const3 {A1 A2 A3 B} (v:B) : A1->A2->A3->B :=
  fun _ _ _ => v.
Definition const4 {A1 A2 A3 A4 B} (v:B) : A1->A2->A3->A4->B :=
  fun _ _ _ _ => v.
Definition const5 {A1 A2 A3 A4 A5 B} (v:B) : A1->A2->A3->A4->A5->B :=
  fun _ _ _ _ _ => v.

(** Function application *)

Definition apply {A B} (f : A -> B) (x : A) :=
  f x.

Definition apply_to (A : Type) (x : A) (B : Type) (f : A -> B) :=
  f x.

(** Function composition *)

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

Notation "f1 \o f2" := (compose f1 f2)
  (at level 49, right associativity) : fun_scope.

Open Scope fun_scope.

(* ---------------------------------------------------------------------- *)
(** ** Properties of combinators *)

Section Combinators.
Variables (A B C D : Type).

Lemma compose_id_l : forall (f:A->B),
  id \o f = f.
Proof. intros. apply~ func_ext_1. Qed.

Lemma compose_id_r : forall (f:A->B),
  f \o id = f.
Proof. intros. apply~ func_ext_1. Qed.

Lemma compose_assoc : forall (f:C->D) (g:B->C) (h:A->B),
  (f \o g) \o h = f \o (g \o h).
Proof. intros. apply~ func_ext_1. Qed.

Lemma compose_eq_l : forall (f:B->C) (g1 g2:A->B),
  g1 = g2 -> f \o g1 = f \o g2.
Proof. intros. subst~. Qed.

Lemma compose_eq_r : forall (f:A->B) (g1 g2:B->C),
  g1 = g2 -> g1 \o f = g2 \o f.
Proof. intros. subst~. Qed.

End Combinators.

(* ---------------------------------------------------------------------- *)
(** ** Tactic for simplifying function compositions *)

Hint Rewrite compose_id_l compose_id_r compose_assoc : rew_compose.
Tactic Notation "rew_compose" :=
  autorewrite with rew_compose.
Tactic Notation "rew_compose" "in" "*" :=
  autorewrite with rew_compose in *.
Tactic Notation "rew_compose" "in" hyp(H) :=
  autorewrite with rew_compose in H.


Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

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

Fixpoint append(m n :natlist) : natlist :=
match m with
|[] => n
|a :: b => a::(append b n)
end.

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

Fixpoint snoc(m:natlist)(n:nat) :natlist:=
match m with
|[] => [n]
|a::b => a:: (snoc b n)
end.

Fixpoint reverse(n:natlist) : natlist :=
match n with
|[] => []
|a::b => snoc(reverse b) a
end.

Theorem appendEmptyList : forall list : natlist, list ++ [] = list.
Proof.
  intros.
    induction list as [| x xs].
    simpl.
    reflexivity.
    simpl.
    rewrite -> IHxs.
    reflexivity.
Qed.

Theorem rev_snoc : forall l :natlist, forall n:nat, reverse(snoc l n) = n :: reverse l.
Proof.
intros.
induction l.
simpl.
simpl. reflexivity.
simpl. rewrite -> IHl.
simpl. reflexivity.
Qed.

Theorem reverseInvolutive : forall list : natlist, reverse(reverse list) = list.
Proof.
intros.
induction list as [| x xs].
simpl. reflexivity.
simpl. rewrite -> rev_snoc.
rewrite IHxs.
reflexivity.
Qed.

Eval compute in ( reverseInvolutive [1;2;3;4;5]).