(** * Logic: Logic in Coq *)

Require Export MoreProp.

(** Coq's built-in logic is very small: the only primitives are
    [Inductive] definitions, universal quantification ([forall]), and
    implication ([->]), while all the other familiar logical
    connectives -- conjunction, disjunction, negation, existential
    quantification, even equality -- can be encoded using just these.

    This chapter explains the encodings and shows how the tactics
    we've seen can be used to carry out standard forms of logical
    reasoning involving these connectives. *)

(* ########################################################### *)
(** * Conjunction *)

(** The logical conjunction of propositions [P] and [Q] can be
    represented using an [Inductive] definition with one
    constructor. *)

Inductive and (P Q : Prop) : Prop :=
  conj : P -> Q -> (and P Q).

(** Note that, like the definition of [ev] in a previous
    chapter, this definition is parameterized; however, in this case,
    the parameters are themselves propositions, rather than numbers. *)

(** The intuition behind this definition is simple: to
    construct evidence for [and P Q], we must provide evidence
    for [P] and evidence for [Q].  More precisely:

    - [conj p q] can be taken as evidence for [and P Q] if [p]
      is evidence for [P] and [q] is evidence for [Q]; and

    - this is the _only_ way to give evidence for [and P Q] --
      that is, if someone gives us evidence for [and P Q], we
      know it must have the form [conj p q], where [p] is
      evidence for [P] and [q] is evidence for [Q].

   Since we'll be using conjunction a lot, let's introduce a more
   familiar-looking infix notation for it. *)

Notation "P /\ Q" := (and P Q) : type_scope.

(** (The [type_scope] annotation tells Coq that this notation
    will be appearing in propositions, not values.) *)

(** Consider the "type" of the constructor [conj]: *)

Check conj.
(* ===>  forall P Q : Prop, P -> Q -> P /\ Q *)

(** Notice that it takes 4 inputs -- namely the propositions [P]
    and [Q] and evidence for [P] and [Q] -- and returns as output the
    evidence of [P /\ Q]. *)

(** Besides the elegance of building everything up from a tiny
    foundation, what's nice about defining conjunction this way is
    that we can prove statements involving conjunction using the
    tactics that we already know.  For example, if the goal statement
    is a conjuction, we can prove it by applying the single
    constructor [conj], which (as can be seen from the type of [conj])
    solves the current goal and leaves the two parts of the
    conjunction as subgoals to be proved separately. *)

Theorem and_example :
  (beautiful 0) /\ (beautiful 3).
Proof.
  apply conj.
  Case "left". apply b_0.
  Case "right". apply b_3.  Qed.

(** Just for convenience, we can use the tactic [split] as a shorthand for
    [apply conj]. *)

Theorem and_example' :
  (ev 0) /\ (ev 4).
Proof.
  split.
    Case "left". apply ev_0.
    Case "right". apply ev_SS. apply ev_SS. apply ev_0.  Qed.

(** Conversely, the [inversion] tactic can be used to take a
    conjunction hypothesis in the context, calculate what evidence
    must have been used to build it, and add variables representing
    this evidence to the proof context. *)

Theorem proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HP.  Qed.

(** **** Exercise: 1 star, optional (proj2) *)
Theorem proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HQ.  Qed.
(** [] *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  (* WORKED IN CLASS *)
  intros P Q H.
  inversion H as [HP HQ].
  split.
    Case "left". apply HQ.
    Case "right". apply HP.  Qed.

(** **** Exercise: 2 stars (and_assoc) *)
(** In the following proof, notice how the _nested pattern_ in the
    [inversion] breaks the hypothesis [H : P /\ (Q /\ R)] down into
    [HP: P], [HQ : Q], and [HR : R].  Finish the proof from there: *)

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

(** **** Exercise: 2 stars (even__ev) *)
(** Now we can prove the other direction of the equivalence of [even]
   and [ev], which we left hanging in chapter [Prop].  Notice that the
   left-hand conjunct here is the statement we are actually interested
   in; the right-hand conjunct is needed in order to make the
   induction hypothesis strong enough that we can carry out the
   reasoning in the inductive step.  (To see why this is needed, try
   proving the left conjunct by itself and observe where things get
   stuck.) *)

Theorem even__ev : forall n : nat,
  (even n -> ev n) /\ (even (S n) -> ev (S n)).
Proof.
  (* Hint: Use induction on [n]. *)
  intros n. induction n as [| n'].
  Case "n = 0".
    split.
    SCase "left". intros H. apply ev_0.
    SCase "rigth". intros H. inversion H.
  Case "n = S n'".
    inversion IHn' as [H1 H2]. split.
    SCase "left". apply H2.
    SCase "right". intros H. apply ev_SS. apply H1. apply H.  Qed.
(** [] *)

(* ###################################################### *)
(** ** Iff *)

(** The handy "if and only if" connective is just the conjunction of
    two implications. *)

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.

Theorem iff_implies : forall P Q : Prop,
  (P <-> Q) -> P -> Q.
Proof.
  intros P Q H.
  inversion H as [HAB HBA]. apply HAB.  Qed.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  (* WORKED IN CLASS *)
  intros P Q H.
  inversion H as [HAB HBA].
  split.
    Case "->". apply HBA.
    Case "<-". apply HAB.  Qed.

(** **** Exercise: 1 star, optional (iff_properties) *)
(** Using the above proof that [<->] is symmetric ([iff_sym]) as
    a guide, prove that it is also reflexive and transitive. *)

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

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R H1 H2.
  inversion H1 as [HPQ HQP].
  inversion H2 as [HQR HRQ].
  split.
  Case "->". intros H. apply HPQ in H. apply HQR in H. apply H.
  Case "<-". intros H. apply HRQ in H. apply HQP in H. apply H.  Qed.

(** Hint: If you have an iff hypothesis in the context, you can use
    [inversion] to break it into two separate implications.  (Think
    about why this works.) *)
(** [] *)

(** Some of Coq's tactics treat [iff] statements specially, thus
    avoiding the need for some low-level manipulation when reasoning
    with them.  In particular, [rewrite] can be used with [iff]
    statements, not just equalities. *)

(* ############################################################ *)
(** * Disjunction *)

(** Disjunction ("logical or") can also be defined as an
    inductive proposition. *)

Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.

Notation "P \/ Q" := (or P Q) : type_scope.

(** Consider the "type" of the constructor [or_introl]: *)

Check or_introl.
(* ===>  forall P Q : Prop, P -> P \/ Q *)

(** It takes 3 inputs, namely the propositions [P], [Q] and
    evidence of [P], and returns, as output, the evidence of [P \/ Q].
    Next, look at the type of [or_intror]: *)

Check or_intror.
(* ===>  forall P Q : Prop, Q -> P \/ Q *)

(** It is like [or_introl] but it requires evidence of [Q]
    instead of evidence of [P]. *)

(** Intuitively, there are two ways of giving evidence for [P \/ Q]:

    - give evidence for [P] (and say that it is [P] you are giving
      evidence for -- this is the function of the [or_introl]
      constructor), or

    - give evidence for [Q], tagged with the [or_intror]
      constructor. *)

(** Since [P \/ Q] has two constructors, doing [inversion] on a
    hypothesis of type [P \/ Q] yields two subgoals. *)

Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q H.
  inversion H as [HP | HQ].
    Case "left". apply or_intror. apply HP.
    Case "right". apply or_introl. apply HQ.  Qed.

(** From here on, we'll use the shorthand tactics [left] and [right]
    in place of [apply or_introl] and [apply or_intror]. *)

Theorem or_commut' : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q H.
  inversion H as [HP | HQ].
    Case "left". right. apply HP.
    Case "right". left. apply HQ.  Qed.

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

(** **** 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. inversion H as [[H1P | H1Q] [H2P | H2R]].
  Case "PP". left. apply H1P.
  Case "PR". left. apply H1P.
  Case "QP". left. apply H2P.
  Case "QR". right. split.
    SCase "left". apply H1Q.
    SCase "right". apply H2R.  Qed.
(** [] *)

(** **** 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. split.
  Case "->". apply or_distributes_over_and_1.
  Case "<-". apply or_distributes_over_and_2.  Qed.
(** [] *)

(* ################################################### *)
(** ** Relating [/\] and [\/] with [andb] and [orb] (advanced) *)

(** We've already seen several places where analogous structures
    can be found in Coq's computational ([Type]) and logical ([Prop])
    worlds.  Here is one more: the boolean operators [andb] and [orb]
    are clearly analogs of the logical connectives [/\] and [\/].
    This analogy can be made more precise by the following theorems,
    which show how to translate knowledge about [andb] and [orb]'s
    behaviors on certain inputs into propositional facts about those
    inputs. *)

Theorem andb_prop : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  (* WORKED IN CLASS *)
  intros b c H.
  destruct b.
    Case "b = true". destruct c.
      SCase "c = true". apply conj. reflexivity. reflexivity.
      SCase "c = false". inversion H.
    Case "b = false". inversion H.  Qed.

Theorem andb_true_intro : forall b c,
  b = true /\ c = true -> andb b c = true.
Proof.
  (* WORKED IN CLASS *)
  intros b c H.
  inversion H.
  rewrite H0. rewrite H1. reflexivity. Qed.

(** **** Exercise: 2 stars, optional (bool_prop) *)
Theorem andb_false : forall b c,
  andb b c = false -> b = false \/ c = false.
Proof.
  intros b c H. destruct b.
  Case "b = true".
    destruct c.
    SCase "c = true". inversion H.
    SCase "c = false". right. reflexivity.
  Case "b = fasle".
    left. reflexivity.  Qed.

Theorem orb_prop : forall b c,
  orb b c = true -> b = true \/ c = true.
Proof.
  intros b c H. destruct b.
  Case "b = true".
    left. reflexivity.
  Case "b = false".
    destruct c.
    SCase "c = true". right. reflexivity.
    SCase "c = false". inversion H.  Qed.

Theorem orb_false_elim : forall b c,
  orb b c = false -> b = false /\ c = false.
Proof.
  intros b c H. destruct b.
  Case "b = true".
    inversion H.
  Case "b = false".
    destruct c.
    SCase "c = true". inversion H.
    SCase "c = false". split. reflexivity. reflexivity.  Qed.
(** [] *)

(* ################################################### *)
(** * Falsehood *)

(** Logical falsehood can be represented in Coq as an inductively
    defined proposition with no constructors. *)

Inductive False : Prop := .

(** Intuition: [False] is a proposition for which there is no way
    to give evidence. *)

(** Since [False] has no constructors, inverting an assumption
    of type [False] always yields zero subgoals, allowing us to
    immediately prove any goal. *)

Theorem False_implies_nonsense :
  False -> 2 + 2 = 5.
Proof.
  intros contra.
  inversion contra.  Qed.

(** How does this work? The [inversion] tactic breaks [contra] into
    each of its possible cases, and yields a subgoal for each case.
    As [contra] is evidence for [False], it has _no_ possible cases,
    hence, there are no possible subgoals and the proof is done. *)

(** Conversely, the only way to prove [False] is if there is already
    something nonsensical or contradictory in the context: *)

Theorem nonsense_implies_False :
  2 + 2 = 5 -> False.
Proof.
  intros contra.
  inversion contra.  Qed.

(** Actually, since the proof of [False_implies_nonsense]
    doesn't actually have anything to do with the specific nonsensical
    thing being proved; it can easily be generalized to work for an
    arbitrary [P]: *)

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P contra.
  inversion contra.  Qed.

(** The Latin _ex falso quodlibet_ means, literally, "from
    falsehood follows whatever you please."  This theorem is also
    known as the _principle of explosion_. *)

(* #################################################### *)
(** ** Truth *)

(** Since we have defined falsehood in Coq, one might wonder whether
    it is possible to define truth in the same way.  We can. *)

(** **** Exercise: 2 stars, advanced (True) *)
(** Define [True] as another inductively defined proposition.  (The
    intution is that [True] should be a proposition for which it is
    trivial to give evidence.) *)

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

(** However, unlike [False], which we'll use extensively, [True] is
    used fairly rarely. By itself, it is trivial (and therefore
    uninteresting) to prove as a goal, and it carries no useful
    information as a hypothesis. But it can be useful when defining
    complex [Prop]s using conditionals, or as a parameter to
    higher-order [Prop]s. *)

(* #################################################### *)
(** * Negation *)

(** The logical complement of a proposition [P] is written [not
    P] or, for shorthand, [~P]: *)

Definition not (P:Prop) := P -> False.

(** The intuition is that, if [P] is not true, then anything at
    all (even [False]) follows from assuming [P]. *)

Notation "~ x" := (not x) : type_scope.

Check not.
(* ===> Prop -> Prop *)

(** It takes a little practice to get used to working with
    negation in Coq.  Even though you can see perfectly well why
    something is true, it can be a little hard at first to get things
    into the right configuration so that Coq can see it!  Here are
    proofs of a few familiar facts about negation to get you warmed
    up. *)

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. inversion H.  Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
  (* WORKED IN CLASS *)
  intros P Q H. inversion H as [HP HNA]. unfold not in HNA.
  apply HNA in HP. inversion HP.  Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not. intros G. apply G. apply H.  Qed.

(** **** Exercise: 2 stars, advanced (double_neg_inf) *)
(** Write an informal proof of [double_neg]:

   _Theorem_: [P] implies [~~P], for any proposition [P].

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

(** **** Exercise: 2 stars (contrapositive) *)
Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  unfold not. intros P Q H1 H2 H3.
  apply H1 in H3. apply H2 in H3.
  inversion H3.  Qed.
(** [] *)

(** **** Exercise: 1 star (not_both_true_and_false) *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  unfold not. intros P H.
  inversion H. apply H1 in H0. inversion H0.  Qed.
(** [] *)

(** **** Exercise: 1 star, advanced (informal_not_PNP) *)
(** Write an informal proof (in English) of the proposition [forall P
    : Prop, ~(P /\ ~P)]. *)

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

Theorem five_not_even :
  ~ ev 5.
Proof.
  (* WORKED IN CLASS *)
  unfold not. intros Hev5. inversion Hev5 as [|n Hev3 Heqn].
  inversion Hev3 as [|n' Hev1 Heqn']. inversion Hev1.  Qed.

(** **** Exercise: 1 star (ev_not_ev_S) *)
(** Theorem [five_not_even] confirms the unsurprising fact that five
    is not an even number.  Prove this more interesting fact: *)

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
  unfold not. intros n H. induction H. (* not n! *)
  Case "ev_0".
    intros Hev1. inversion Hev1.
  Case "ev_SS".
    intros Hev3. inversion Hev3 as [|n' Hev1 Heqn'].
    apply IHev in Hev1. inversion Hev1.  Qed.
(** [] *)

(** Note that some theorems that are true in classical logic are _not_
    provable in Coq's (constructive) logic.  E.g., let's look at how
    this proof gets stuck... *)

Theorem classic_double_neg : forall P : Prop,
  ~~P -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not in H.
  (* But now what? There is no way to "invent" evidence for [~P]
     from evidence for [P]. *)
  Abort.

(** **** Exercise: 5 stars, advanced, optional (classical_axioms) *)
(** For those who like a challenge, here is an exercise
    taken from the Coq'Art book (p. 123).  The following five
    statements are often considered as characterizations of
    classical logic (as opposed to constructive logic, which is
    what is "built in" to Coq).  We can't prove them in Coq, but
    we can consistently add any one of them as an unproven axiom
    if we wish to work in classical logic.  Prove that these five
    propositions are equivalent. *)

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

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

(* ########################################################## *)
(** ** Inequality *)

(** Saying [x <> y] is just the same as saying [~(x = y)]. *)

Notation "x <> y" := (~ (x = y)) : type_scope.

(** Since inequality involves a negation, it again requires
    a little practice to be able to work with it fluently.  Here
    is one very useful trick.  If you are trying to prove a goal
    that is nonsensical (e.g., the goal state is [false = true]),
    apply the lemma [ex_falso_quodlibet] to change the goal to
    [False].  This makes it easier to use assumptions of the form
    [~P] that are available in the context -- in particular,
    assumptions of the form [x<>y]. *)

Theorem not_false_then_true : forall b : bool,
  b <> false -> b = true.
Proof.
  intros b H. destruct b.
  Case "b = true". reflexivity.
  Case "b = false".
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.   Qed.

(** **** Exercise: 2 stars (false_beq_nat) *)
Theorem false_beq_nat : forall n m : nat,
     n <> m ->
     beq_nat n m = false.
Proof.
  intros n m H. destruct (beq_nat n m) eqn:E.
  Case "E = true".
    unfold not in H. apply ex_falso_quodlibet.
    apply H. apply beq_nat_true. apply E.
  Case "E = false".
    reflexivity.  Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (beq_nat_false) *)
Theorem beq_nat_false : forall n m,
  beq_nat n m = false -> n <> m.
Proof.
  intros n m. destruct (beq_nat n m) eqn:E.
  Case "E = true".
    intros contra. inversion contra.
  Case "E = false".
    unfold not. intros eq1 eq2. rewrite -> eq2 in E.
    rewrite <- beq_nat_refl in E. inversion E.  Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (ble_nat_false) *)
Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
Proof.
  intros n m. destruct (ble_nat n m) eqn:E.
  Case "E = true".
    intros contra. inversion contra.
  Case "E = false".
    unfold not. intros eq1 eq2. apply le_ble_nat in eq2.
    rewrite -> eq2 in E. inversion E.  Qed.
(** [] *)

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

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

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

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

*)

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

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

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

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

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

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

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

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

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

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

(* FILL IN HERE *)

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

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  unfold not. intros X P H1 H2.
  inversion H2 as [x Hx]. apply Hx. apply H1.  Qed.
(** [] *)

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

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  intros Hem X P H x.
  assert (Hem': P x \/ ~ P x).
    apply Hem.
  inversion Hem' as [HP | HNP].
  Case "Hem' = P x".
    apply HP.
  Case "Hem' = ~ P x".
    apply ex_falso_quodlibet. apply H.
    exists x. apply HNP.  Qed.
(** [] *)

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

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q. split.
  Case "->".
    intros H. inversion H as [x Hx].
    inversion Hx as [HP | HQ].
    SCase "Hx = P x".
      left. exists x. apply HP.
    SCase "Hx = Q x".
      right. exists x. apply HQ.
  Case "<-".
    intros H. inversion H as [HP | HQ].
    SCase "H = HP".
      inversion HP as [x Hx]. exists x. left. apply Hx.
    SCase "H = HQ".
      inversion HQ as [x Hx]. exists x. right. apply Hx.  Qed.
(** [] *)

(* Print dist_exists_or. *)

(* ###################################################### *)
(** * Equality *)

(** Even Coq's equality relation is not built in.  It has (roughly)
    the following inductive definition. *)

(* (We enclose the definition in a module to avoid confusion with the
    standard library equality, which we have used extensively
    already.) *)

Module MyEquality.

Inductive eq {X:Type} : X -> X -> Prop :=
  refl_equal : forall x, eq x x.
(** Standard infix notation: *)

Notation "x = y" := (eq x y)
                    (at level 70, no associativity)
                    : type_scope.

(** The definition of [=] is a bit subtle.  The way to think about it
    is that, given a set [X], it defines a _family_ of propositions
    "[x] is equal to [y]," indexed by pairs of values ([x] and [y])
    from [X].  There is just one way of constructing evidence for
    members of this family: applying the constructor [refl_equal] to a
    type [X] and a value [x : X] yields evidence that [x] is equal to
    [x]. *)

(** **** Exercise: 2 stars (leibniz_equality) *)
(** The inductive definitions of equality corresponds to _Leibniz equality_:
   what we mean when we say "[x] and [y] are equal" is that every
   property on [P] that is true of [x] is also true of [y].  *)

Lemma leibniz_equality : forall (X : Type) (x y: X),
 x = y -> forall P : X -> Prop, P x -> P y.
Proof.
  intros X x y H P. inversion H as [z H1 H2].
  intros Py. apply Py.  Qed.
(** [] *)

(** We can use
    [refl_equal] to construct evidence that, for example, [2 = 2].
    Can we also use it to construct evidence that [1 + 1 = 2]?  Yes:
    indeed, it is the very same piece of evidence!  The reason is that
    Coq treats as "the same" any two terms that are _convertible_
    according to a simple set of computation rules.  These rules,
    which are similar to those used by [Eval compute], include
    evaluation of function application, inlining of definitions, and
    simplification of [match]es.
*)

Lemma four: 2 + 2 = 1 + 3.
Proof.
  apply refl_equal.
Qed.

(** The [reflexivity] tactic that we have used to prove equalities up
to now is essentially just short-hand for [apply refl_equal]. *)

End MyEquality.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(* ####################################################### *)
(** ** Inversion, Again (Advanced) *)

(** We've seen [inversion] used with both equality hypotheses and
    hypotheses about inductively defined propositions.  Now that we've
    seen that these are actually the same thing, we're in a position
    to take a closer look at how [inversion] behaves...

    In general, the [inversion] tactic

    - takes a hypothesis [H] whose type [P] is inductively defined,
      and

    - for each constructor [C] in [P]'s definition,

      - generates a new subgoal in which we assume [H] was
        built with [C],

      - adds the arguments (premises) of [C] to the context of
        the subgoal as extra hypotheses,

      - matches the conclusion (result type) of [C] against the
        current goal and calculates a set of equalities that must
        hold in order for [C] to be applicable,

      - adds these equalities to the context (and, for convenience,
        rewrites them in the goal), and

      - if the equalities are not satisfiable (e.g., they involve
        things like [S n = O]), immediately solves the subgoal. *)

(** _Example_: If we invert a hypothesis built with [or], there are two
   constructors, so two subgoals get generated.  The
   conclusion (result type) of the constructor ([P \/ Q]) doesn't
   place any restrictions on the form of [P] or [Q], so we don't get
   any extra equalities in the context of the subgoal.

   _Example_: If we invert a hypothesis built with [and], there is
   only one constructor, so only one subgoal gets generated.  Again,
   the conclusion (result type) of the constructor ([P /\ Q]) doesn't
   place any restrictions on the form of [P] or [Q], so we don't get
   any extra equalities in the context of the subgoal.  The
   constructor does have two arguments, though, and these can be seen
   in the context in the subgoal.

   _Example_: If we invert a hypothesis built with [eq], there is
   again only one constructor, so only one subgoal gets generated.
   Now, though, the form of the [refl_equal] constructor does give us
   some extra information: it tells us that the two arguments to [eq]
   must be the same!  The [inversion] tactic adds this fact to the
   context.  *)

(** **** Exercise: 1 star, optional (dist_and_or_eq_implies_and) *)
Lemma dist_and_or_eq_implies_and : forall P Q R,
       P /\ (Q \/ R) /\ Q = R -> P/\Q.
Proof.
  intros P Q R H.
  inversion H as [HP H'].
  inversion H' as [HQR H''].
  inversion HQR as [HQ | HR].
  Case "HQR = Q".
    split. apply HP. apply HQ.
  Case "HQR = R".
    split. apply HP. rewrite -> H''. apply HR.  Qed.
(** [] *)

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

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

Inductive all (X : Type) (P : X -> Prop) : list X -> Prop :=
  | all_nil : all X P nil
  | all_cons : forall x l, P x -> all X P l -> all X P (x :: l).

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

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

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

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

Theorem forallb_correct : forall X f l,
  all X (fun x => f x = true) l <-> forallb f l = true.
Proof.
  intros X f l. split.
  Case "->".
    intros H. induction H as [| x xs HP H' Hl].
    SCase "H = []".
      reflexivity.
    SCase "H = x :: xs".
      simpl. rewrite -> HP. rewrite -> Hl. reflexivity.
  Case "<-".
    intros H. induction l as [| x xs].
    SCase "l = []".
      apply all_nil.
    SCase "l = x :: xs".
      simpl in H. apply all_cons.
      SSCase "P x".
        apply andb_true_elim1 in H. apply H.
      SSCase "all X P l".
        apply IHxs. apply andb_true_elim2 in H. apply H.  Qed.
(** [] *)

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

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

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

Inductive merge {X : Type} : list X -> list X -> list X -> Prop :=
  | m_nil : forall (l : list X), merge [] [] []
  | m_1 : forall x xs ys l, merge xs ys l -> merge (x :: xs) ys (x :: l)
  | m_2 : forall y xs ys l, merge xs ys l -> merge xs (y :: ys) (y :: l).

Theorem filter_correct : forall X (l l1 l2: list X) (test : X -> bool),
  merge l1 l2 l ->
  all X (fun x => test x = true) l1 ->
  all X (fun x => test x = false) l2 ->
  filter test l = l1.
Proof.
  intros X l. induction l as [| z l'].
  Case "l = []".
    intros l1 l2 test H H1 H2.
    inversion H. reflexivity.
  Case "l = z :: l'".
    intros l1 l2 test H.
    inversion H.
    SCase "m_1".
      intros Hall1 Hall2. inversion Hall1.
      SSCase "all_cons".
        simpl. rewrite -> H7. apply f_equal.
        apply IHl' with (l2:=l2).
          apply H3. apply H8. apply Hall2.
    SCase "m_2".
      intros Hall1 Hall2. inversion Hall2.
      SSCase "all_cons".
        simpl. rewrite -> H7.
        apply IHl' with (l2:=ys).
          apply H3. apply Hall1. apply H8.  Qed.
(** [] *)

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

Inductive subseq {X : Type} : list X -> list X -> Prop :=
  | s_nil : forall l, subseq nil l
  | s_1 : forall x l1 l2, subseq l1 l2 -> subseq (x :: l1) (x :: l2)
  | s_2 : forall x l1 l2, subseq l1 l2 -> subseq l1 (x :: l2).

Theorem filter_challenge_2 : forall X (l k: list X) (test : X -> bool),
  subseq k l -> all X (fun x => test x = true) k -> subseq k (filter test l).
Proof.
  intros X l. induction l as [| x l'].
  Case "l = []".
    intros k test H Hall. simpl. apply H.
  Case "l = x :: l'".
    intros k test H.
    inversion H.
    SCase "s_nil".
      intros Hall. apply s_nil.
    SCase "s_1".
      intros Hall. simpl. inversion Hall. rewrite -> H6.
      apply s_1. apply IHl'. apply H2. apply H7.
    SCase "s_2".
      intros Hall. simpl. destruct (test x).
      SSCase "test x = true".
        apply s_2. apply IHl'. apply H2. apply Hall.
      SSCase "test x = false".
        apply IHl'. apply H2. apply Hall.  Qed.
(** [] *)

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

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

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

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

Lemma appears_in_app : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x (xs ++ ys) -> appears_in x xs \/ appears_in x ys.
Proof.
  intros X xs ys x H.
  induction xs as [| x' xs'].
  Case "xs = []".
    right. apply H.
  Case "xs = x' :: xs'".
    inversion H.
    SCase "ai_here".
      left. apply ai_here.
    SCase "ai_later".
      apply IHxs' in H1. inversion H1.
      SSCase "left".
        left. apply ai_later. apply H3.
      SSCase "right".
        right. apply H3.  Qed.

Lemma app_appears_in : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x xs \/ appears_in x ys -> appears_in x (xs ++ ys).
Proof.
  intros X xs ys x H. induction xs as [| x' xs'].
  Case "xs = []".
    inversion H as [Hleft | Hright].
    SCase "left". inversion Hleft.
    SCase "right". apply Hright.
  Case "xs = x' :: xs'".
    inversion H as [Hleft| Hright].
    SCase "left".
      inversion Hleft.
      SSCase "ai_here".
        apply ai_here.
      SSCase "ai_later".
        simpl. apply ai_later. apply IHxs'. left. apply H1.
    SCase "right".
      simpl. apply ai_later. apply IHxs'. right. apply Hright.  Qed.

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

Inductive disjoint {X : Type}: list X -> list X -> Prop :=
  | dj_nil: forall l, disjoint [] l
  | dj_cons: forall x l1 l2, ~ appears_in x l2 -> disjoint l1 l2 -> disjoint (x :: l1) l2.

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

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

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

Theorem nr_disjoint : forall X (l1 l2: list X),
  no_repeats (l1 ++ l2) -> disjoint l1 l2.
Proof.
  intros. induction l1 as [| x xs].
  Case "l1 = []".
    apply dj_nil.
  Case "l1 = x :: xs".
    apply dj_cons.
      unfold not. intros. inversion H. apply H3. apply app_appears_in. right. apply H0.
      apply IHxs. inversion H. apply H3.  Qed.
(** [] *)

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

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

Inductive nostutter:  list nat -> Prop :=
  | ns_nil : nostutter []
  | ns_singl : forall x, nostutter [x]
  | ns_cons : forall x y l, x <> y -> nostutter (y :: l) -> nostutter (x :: y :: l).

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

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

Example test_nostutter_1:      nostutter [3;1;4;1;5;6].
Proof. repeat constructor; apply beq_nat_false; auto. Qed.

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

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

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

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

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

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2. induction l1 as [| x xs].
  Case "l1 = []".
    reflexivity.
  Case "l2 = x :: xs".
    simpl. apply f_equal. apply IHxs.  Qed.

Lemma appears_in_app_split : forall (X:Type) (x:X) (l:list X),
  appears_in x l ->
  exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
  intros. induction H.
  Case "ai_here".
    exists []. exists l. reflexivity.
  Case "ai_later".
    inversion IHappears_in as [ms H1]. exists (b :: ms).
    inversion H1 as [ns H2]. exists ns.
    simpl. rewrite H2. reflexivity.  Qed.

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

Inductive repeats {X:Type} : list X -> Prop :=
  | rep_here: forall x xs, appears_in x xs -> repeats (x :: xs)
  | rep_later: forall x xs, repeats xs -> repeats (x :: xs).

(** Now here's a way to formalize the pigeonhole principle. List [l2]
   represents a list of pigeonhole labels, and list [l1] represents an
   assignment of items to labels: if there are more items than labels,
   at least two items must have the same label.  You will almost
   certainly need to use the [excluded_middle] hypothesis. *)

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

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)


(* Binary representation of the positive integers. *)

Inductive pos: Set :=
  | bI: pos
  | b0: pos -> pos
  | b1: pos -> pos.

(* For illustration, we can interpret these as naturals. *)

Fixpoint nat_of (p: pos): nat :=
  match p with
    | (* Initial one bit. *)
      bI => 1
    | (* Shift left plus zero. *)
      b0 p => 2 * nat_of p
    | (* Shift left plus one. *)
      b1 p => S (2 * nat_of p)
  end.

(* In this interpretation, we read bits right-to-left. *)

Example eg_11: nat_of (b1 (b1 (b0 bI))) = 11. simpl. reflexivity. Qed.
Example eg_12: nat_of (b0 (b0 (b1 bI))) = 12. simpl. reflexivity. Qed.
Example eg_13: nat_of (b1 (b0 (b1 bI))) = 13. simpl. reflexivity. Qed.

(* A successor function consistent with this interpretation. *)

Fixpoint succ (p: pos): pos :=
  match p with
    | (* Carry the one. *)
      bI => b0 bI
    | (* Increment the least-significant bit. *)
      b0 q => b1 q
    | (* Carry the one. *)
      b1 q => b0 (succ q)
  end.

(* Challenge: prove a nat-like induction principle for `pos`. *)
(* This is a bit tricky, so I've given you a head start. *)

Definition pos_succ_rect:
  forall (p: pos) (P: pos -> Type) (I: P bI) (S: forall p, P p -> P (succ p)), P p.
Proof.
  induction p; intros P I S.
  - (* Base case bI *)
    assumption.
  - (* Inductive case b0 *)
    (* Note: when we apply IHp, we implicitly instantiate its P
         with `fun p => P (b0 p)`! *)
    apply IHp.
    + (* Prove the first assumption of IHp, which corresponds to I,
           but with the specialised P. *)
      (* Look at the next sub-case for some hints. *)
      admit.
    + (* Prove the second assumption of IHp, which corresponds to S,
           but with the specialised P. *)
      intros q H.
      (* The `change` tactic replaces the current goal with another,
           provided it has the same normal form. *)
      (* Here, `P (succ (succ (b0 q)))` could be simplified
           to `P (b0 (succ q))`, so this `change` is allowed. *)
      change (P (succ (succ (b0 q)))).
      (* We use the S we were given to prove IHp's S, but since we
           have lifted IHp's P over b0, we need to apply S twice! *)
      apply S. apply S. apply H.
  - (* Inductive case b1 *)
    (* Should be somewhat similar to the b0 case! *)
    admit.
Defined.


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

Theorem even_0 : even 0.
Proof.
apply EvenO.
Qed.

Theorem even_4 : even 4.
Proof.
apply EvenSS.
apply EvenSS.
apply EvenO.
Qed.

Theorem even_4_1 : even 4.
Proof.
constructor. constructor. constructor.
Qed.

(*
Hint Resolve EvenO.
Hint Resolve EvenSS.
*)

Hint Constructors even.

Theorem even_4_2 : even 4.
Proof.
auto.
Qed.


(**
フィボナッチ数列の加法定理
========================

@suharahiromichi

2020/07/01
*)

From mathcomp Require Import all_ssreflect.
Require Import ssromega.
Require Import Recdef.                      (* Function *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
# はじめに

フィボナッチ ffibonacci 数列には、加法定理 addition theorem
(加法法則 addition law) が成り立ちます。 $ 1 \le m$ のとき、

$$ F_{n + m} = F_m F_{n+1} + F_{m-1} F_n $$

フィボナッチ数列の定義は、だれでも知っている単純なものですが、
1個前と2個前の項を参照する、という意味で、帰納法としては複雑なかたちをしています。

そこで、Coqの「特定の再帰関数に専用の帰納法」のための
コマンド ``functional induction`` を使って解いてみましょう。

このファイルは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_fib_add_law.v

また、

https://github.com/suharahiromichi/coq/blob/master/common/ssromega.v

も必要です。
 *)

Section Fib_2.

(**
# fibonacci 関数の定義

``functional induction`` を使うためには、
関数を``Fixpoint``ではなく、``Function``で定義する必要があります。
*)
  Function fib (n : nat) : nat :=
    match n with
    | 0 => 0
    | 1 => 1
    | (m.+1 as pn).+1 => fib m + fib pn (* fib n.-2 + fib n.-1 *)
    end.

(**
``Function``コマンドをで定義すると、``functional induction``を行うための``fib_ind``が定義されます。
 *)
  Check fib_ind
    : forall P : nat -> nat -> Prop,
      (forall m : nat, m = 0 -> P 0 0) ->
      (forall m : nat, m = 1 -> P 1 1) ->
      (forall m k : nat,
          m = k.+2 -> P k (fib k) -> P k.+1 (fib k.+1) -> P k.+2 (fib k + fib k.+1)) ->
      forall m : nat, P m (fib m).

(**
簡単にいうと、命題 P(m, F_m) に対して、次の帰納法で証明することができます。

- 命題が、P(0, F_0) で成り立つ場合を証明する。F_0 = 0 なので P(0, 0)
- 命題が、P(1, F_1) で成り立つ場合を証明する。F_1 = 1 なので P(1, 1)
- 命題が、P(k, F_k) と P(m=k+1, F_k+1) で成り立つと仮定して、P(m=k+2, F_k + F_k+1)
で成り立つこと証明する。
- 以上から、命題は、任意の P(m, F_m) で成り立つ。

つまり、フィボナッチ数列の定義そのものですね。
*)

(**
また、関数の展開をするための``fib_equation``が定義されます。
 *)
  Check fib_equation
    : forall n : nat,
      fib n = match n with
              | 0 => 0
              | 1 => 1
              | (m.+1 as pn).+1 => fib m + fib pn
              end.

(**
``Function`` で関数を定義すると、
関数を展開するunfoldタクティクが、事実上、使用不能になるため、
代わりに ``rewrite fib_equation`` による書き換えを可能にするためのものです。
なお、今回は使用しません。
*)

(**
# 補題

定義から導かれる、簡単な補題を証明しておきます。
*)
  Lemma fib_n n : fib n.+2 = fib n + fib n.+1.
  Proof.
    done.
  Qed.

(**
# フィボナッチ数列の加法定理

最初にCoqで扱い易い、引き算の無いかたちで証明します。
この場合 n、m とも任意の自然数でよいです。

$$ F_{n + m + 1} = F_{m + 1} F_{n+1} + F_m F_n $$
 *)
  Lemma fib_addition' n m :
    fib (n + m.+1) = fib m.+1 * fib n.+1 + fib m * fib n.
  Proof.
(**
F_m に対する帰納法をおおこなう。mだけの帰納法ではない。
*)
    functional induction (fib m).

(**
- P(m=0, F_0) を証明する。
*)
    - rewrite addn1.
      rewrite [fib 1]/= mul1n mul0n addn0.
      done.

(**
- P(m=1, F_1) を証明する。
*)
    - rewrite addn2.
      rewrite [fib 2]/= add0n 2!mul1n.
      rewrite addnC -fib_n.
      done.

(**
- IHn0 : P(m=m, F_m) で成り立つ。
- IHn1 : P(m=m+1, F_m+1) で成り立つ。
- Goal : P(m=m+2, F_m + F_m+1) で成り立つことを証明する。

前節での説明上の k が、ここでは m になっています。
*)
    - rewrite fib_n 2!mulnDl.

      (* F_(n + m.+1) の項をまとめて置き換える *)
      rewrite ?addnA [_ + fib m * fib n]addnC. (* この項を先頭に。 *)
      rewrite ?addnA [_ + fib m.+1 * fib n.+1]addnC ?addnA. (* この項を先頭に。 *)
      rewrite -IHn0.

      (* F_(n + m.+2) の項をまとめて置き換える *)
      rewrite ?addnA [_ + fib m.+1 * fib n]addnC. (* この項を先頭に。 *)
      rewrite ?addnA [_ + fib m.+2 * fib n.+1]addnC ?addnA. (* この項を先頭に。 *)
      rewrite -IHn1.

      have -> : n + m.+3 = (m + n).+3 by ssromega.
      have -> : n + m.+2 = (m + n).+2 by ssromega.
      have -> : n + m.+1 = (m + n).+1 by ssromega.
      rewrite fib_n.
      rewrite [fib (m + n).+2 + fib (m + n).+1]addnC.
      done.
  Qed.

(**
最後に、$1 \le m$ の条件のもとで、定理を証明します。

$$ F_{n + m} = F_m F_{n+1} + F_{m-1} F_n $$
*)
  Lemma fib_addition n m :
    1 <= m -> fib (n + m) = fib m * fib n.+1 + fib m.-1 * fib n.
  Proof.
    move=> H.
    have H' := fib_addition' n m.-1.
      by rewrite prednK in H'.
  Qed.

(**
``n - 1 + 1 = n`` をいうためには、``0 < n`` の条件が必要です。
これは、n が自然数の0のとき、``0 - 1 = 0`` となるためです。
*)

  Check prednK : forall n : nat, 0 < n -> n.-1.+1 = n.

End Fib_2.

(* END *)


Require Import vcfloat.VCFloat.
Require Import List.
Require Import common op_defs list_lemmas float_acc_lems.
Require Import FunctionalExtensionality.

Require Import Reals.
Open Scope R.

Import ListNotations.

Section DotProd.
Context {NAN : Nans} {t : type}.

(* Standard floating-point dot-product *)
Definition dotprod (v1 v2: list (ftype t)) : ftype t :=
  fold_left (fun s x12 => BPLUS (BMULT (fst x12) (snd x12)) s)
                (List.combine v1 v2) (Zconst t 0).

Inductive dot_prod_rel :
            list (ftype t * ftype t) -> ftype t -> Prop :=
| dot_prod_rel_nil  : dot_prod_rel  nil (Zconst t 0)
| dot_prod_rel_cons : forall l (xy : ftype t * ftype t) s,
    dot_prod_rel  l s ->
    dot_prod_rel  (xy::l) (BPLUS (BMULT  (fst xy) (snd xy)) s).

Lemma dot_prod_rel_fold_right :
forall (v1 v2: list (ftype t)),
    dot_prod_rel (rev (List.combine v1 v2)) (dotprod v1 v2).
Proof.
intros v1 v2.
 unfold dotprod; rewrite <- fold_left_rev_right.
induction (rev (List.combine v1 v2)).
{ simpl; auto. apply dot_prod_rel_nil. }
simpl. apply dot_prod_rel_cons. auto.
Qed.

End DotProd.

Section FMADotProd.
Context {NAN : Nans} {t : type}.

(* FMA dot-product *)
Definition fma_dotprod (v1 v2: list (ftype t)) : ftype t :=
  fold_left (fun s x12 => BFMA (fst x12) (snd x12) s)
                (List.combine v1 v2) (Zconst t 0).

Inductive fma_dot_prod_rel :
            list (ftype t * ftype t) -> ftype t -> Prop :=
| fma_dot_prod_rel_nil  : fma_dot_prod_rel nil (Zconst t 0)
| fma_dot_prod_rel_cons : forall l (xy : ftype t * ftype t) s,
    fma_dot_prod_rel  l s ->
    fma_dot_prod_rel  (xy::l) (BFMA (fst xy) (snd xy) s).

Lemma fma_dot_prod_rel_fold_right  :
forall (v1 v2: list (ftype t)),
    fma_dot_prod_rel (rev (List.combine v1 v2)) (fma_dotprod v1 v2).
Proof.
intros v1 v2.
 unfold fma_dotprod; rewrite <- fold_left_rev_right.
induction (rev (List.combine v1 v2)).
{ simpl; auto. apply fma_dot_prod_rel_nil. }
simpl. apply fma_dot_prod_rel_cons. auto.
Qed.

End FMADotProd.

Section RealDotProd.

(* Dot-product over the reals *)
Definition dotprodR l1 l2 : R :=
  fold_left Rplus (map (uncurry Rmult) (List.combine l1 l2)) 0%R.

Inductive R_dot_prod_rel :
            list (R * R) -> R -> Prop :=
| R_dot_prod_rel_nil  : R_dot_prod_rel  nil 0%R
| R_dot_prod_rel_cons : forall l xy s,
    R_dot_prod_rel  l s ->
    R_dot_prod_rel  (xy::l)  (fst xy * snd xy + s).

Lemma R_dot_prod_rel_eq :
  forall l a b
  (Ha: R_dot_prod_rel l a)
  (Hb: R_dot_prod_rel l b), a = b.
Proof.
induction l.
{ intros; inversion Ha; inversion Hb; auto. }
intros; inversion Ha; inversion Hb; subst; f_equal.
apply IHl; auto.
Qed.

Definition Rabsp p : R * R := (Rabs (fst p), Rabs (snd p)).

Definition FR2 {t: type} (x12: ftype t * ftype t) := (FT2R (fst x12), FT2R (snd x12)).

Lemma FT2R_FR2 t :
  (forall a a0 : ftype t, (FT2R a, FT2R a0) = FR2 (a, a0)) .
Proof. intros. unfold FR2; simpl; auto. Qed.

Definition sum_fold: list R -> R := fold_right Rplus 0%R.

Lemma dotprodR_nil_l u:
dotprodR nil u = 0%R.
Proof. simpl; auto. Qed.

Lemma dotprodR_nil_r u:
dotprodR u nil = 0%R.
Proof. unfold dotprodR; rewrite combine_nil; simpl; auto. Qed.

Lemma sum_rev l:
sum_fold l = sum_fold (rev l).
Proof.
unfold sum_fold.
rewrite fold_left_rev_right.
replace (fun x y : R => y + x) with Rplus
 by (do 2 (apply FunctionalExtensionality.functional_extensionality; intro); lra).
induction l; simpl; auto.
rewrite IHl.
rewrite <- fold_left_Rplus_0; f_equal; nra.
Qed.

Lemma dotprodR_rel :
forall (v1 v2: list R) ,
    R_dot_prod_rel ((List.combine v1 v2)) (dotprodR v1 v2).
Proof.
intros; unfold dotprodR;
induction (((combine v1 v2))).
{ simpl. apply R_dot_prod_rel_nil. }
destruct a; simpl.
unfold dotprodR. simpl.
rewrite fold_left_Rplus_Rplus.
apply R_dot_prod_rel_cons; auto.
Qed.

Lemma dotprodR_rev : forall (v1 v2: list R) ,
  length v1 = length v2 ->
  dotprodR v1 (rev v2) = dotprodR (rev v1) v2.
Proof.
intros; unfold dotprodR.
replace (combine v1 (rev v2)) with
  (rev (combine (rev v1) v2)).
rewrite <- fold_left_rev_right.
replace (fun x y : R => y + x) with Rplus
 by (do 2 (apply functional_extensionality; intro); lra).
symmetry.
induction (combine (rev v1) v2).
simpl; auto.
match goal with |- context [?A = ?B] =>
set (y:= B)
end.
simpl. subst y.
rewrite fold_left_Rplus_Rplus.
rewrite IHl.
rewrite !map_rev, !rev_involutive.
simpl; auto.
rewrite <- combine_rev, rev_involutive; auto.
rewrite rev_length; auto.
Qed.

Lemma R_dot_prod_rel_fold_right t :
forall (v1 v2: list (ftype t)) ,
   let prods := map (uncurry Rmult) (map FR2 (List.combine v1 v2)) in
    R_dot_prod_rel (rev (map FR2 (List.combine v1 v2))) (sum_fold prods).
Proof.
intros. subst prods. rewrite sum_rev. rewrite <- !map_rev.
induction (map FR2 (rev (combine v1 v2))).
{ simpl. apply R_dot_prod_rel_nil. }
destruct a; simpl. apply R_dot_prod_rel_cons; auto.
Qed.

Lemma R_dot_prod_rel_fold_right_Rabs t :
forall (v1 v2: list (ftype t)) ,
   let prods := map (uncurry Rmult) (map Rabsp (map FR2 (List.combine v1 v2))) in
    R_dot_prod_rel (rev (map Rabsp (map FR2 (List.combine v1 v2)))) (sum_fold prods).
Proof.
intros. subst prods. rewrite sum_rev. rewrite <- !map_rev.
induction (map Rabsp (map FR2 (rev (combine v1 v2)))).
{ simpl. apply R_dot_prod_rel_nil. }
destruct a; simpl. apply R_dot_prod_rel_cons; auto.
Qed.

Lemma R_dot_prod_rel_single rs a:
R_dot_prod_rel [a] rs -> rs = (fst a * snd a).
Proof.
intros.
inversion H.
inversion H3; subst; nra.
Qed.

Lemma R_dot_prod_rel_single' a:
R_dot_prod_rel [a] (fst a * snd a).
Proof.
replace (fst a * snd a) with (fst a * snd a + 0) by nra.
apply R_dot_prod_rel_cons; apply R_dot_prod_rel_nil.
Qed.

Lemma R_dot_prod_rel_Rabs_eq :
forall l s,
R_dot_prod_rel (map Rabsp l) s -> Rabs s = s.
Proof.
induction  l.
{ intros.
inversion H.
rewrite Rabs_R0.
nra. }
intros.
inversion H; subst; clear H.
unfold Rabsp. destruct a; simpl.
replace (Rabs(Rabs r * Rabs r0 + s0)) with
  (Rabs r * Rabs r0 + s0); try nra.
symmetry.
rewrite Rabs_pos_eq; try nra.
apply Rplus_le_le_0_compat.
apply Rmult_le_pos;
apply Rabs_pos.
rewrite <- IHl; try apply Rabs_pos; auto.
Qed.

Lemma dot_prod_sum_rel_R_Rabs :
forall l s1 s2,
R_dot_prod_rel l s1 -> R_dot_prod_rel (map Rabsp l) s2 -> Rabs s1 <= Rabs s2.
Proof.
induction l.
{ intros.
inversion H.
inversion H0.
nra. }
intros.
inversion H; subst; clear H.
inversion H0; subst; clear H0.
unfold Rabsp; destruct a; simpl.
eapply Rle_trans; [
apply Rabs_triang |].
replace (Rabs (Rabs r * Rabs r0 + s0)) with
  (Rabs r * Rabs r0 + s0).
eapply Rplus_le_compat; try nra.
rewrite Rabs_mult; nra.
rewrite <- (R_dot_prod_rel_Rabs_eq l); auto.
symmetry.
rewrite Rabs_pos_eq; try nra.
apply Rplus_le_le_0_compat.
apply Rmult_le_pos;
apply Rabs_pos.
rewrite <- (R_dot_prod_rel_Rabs_eq l); auto.
apply Rabs_pos.
Qed.

Lemma dot_prod_combine_map_Rmult a u v r:
length u = length v ->
R_dot_prod_rel (combine u v) r ->
R_dot_prod_rel (combine (map (Rmult a) u) v) (a * r).
Proof. revert u r. induction v.
{ intros. rewrite !combine_nil in *.
  inversion H0; subst; rewrite Rmult_0_r; apply R_dot_prod_rel_nil. }
destruct u.
  { intros; pose proof Nat.neq_0_succ (length v); try contradiction. }
  intros.   inversion H0. assert (Hlen: length u = length v) by (simpl in H; lia).
  specialize (IHv u s Hlen H4).
  simpl. replace (a * (r * a0 + s)) with
    (a * r * a0 + a * s) by nra. apply R_dot_prod_rel_cons; auto.
Qed.

Lemma dotprod_rel_R_exists {NAN: Nans}:
  forall (t : type) (l : list (ftype t * ftype t)) (fp : ftype t)
  (Hfp : dot_prod_rel l fp),
  exists rp, R_dot_prod_rel (map FR2 l) rp.
Proof.
intros ?. induction l.
{ simpl; exists 0. apply R_dot_prod_rel_nil. }
intros. inversion Hfp; subst.
destruct (IHl s H2) as (rs & Hrs); clear IHl.
exists (FT2R (fst a) * FT2R (snd a) + rs); simpl.
apply R_dot_prod_rel_cons; auto.
Qed.

Lemma dotprod_rel_R_exists_fma {NAN: Nans}:
  forall (t : type) (l : list (ftype t * ftype t)) (fp : ftype t)
  (Hfp : fma_dot_prod_rel l fp),
  exists rp, R_dot_prod_rel (map FR2 l) rp.
Proof.
intros ?. induction l.
{ simpl; exists 0. apply R_dot_prod_rel_nil. }
intros. inversion Hfp; subst.
destruct (IHl s H2) as (rs & Hrs); clear IHl.
exists (FT2R (fst a) * FT2R (snd a) + rs); simpl.
apply R_dot_prod_rel_cons; auto.
Qed.

Lemma sum_rel_R_abs_exists_fma {NAN: Nans}:
  forall (t : type) (l : list (ftype t * ftype t)) (fp : ftype t)
  (Hfp : fma_dot_prod_rel l fp),
  exists rp, R_dot_prod_rel (map Rabsp (map FR2 l)) rp.
Proof.
intros ?. induction l.
{ simpl; exists 0. apply R_dot_prod_rel_nil. }
intros. inversion Hfp; subst.
destruct (IHl s H2) as (rs & Hrs); clear IHl.
exists (Rabs (FT2R (fst a)) * Rabs (FT2R (snd a)) + rs); simpl.
apply R_dot_prod_rel_cons; auto.
Qed.

Lemma dotprodR_rel_bound'  :
  forall (t : type) (l : list (ftype t * ftype t)) (rp a: R)
  (Ha : 0 <= a)
  (Hrp : R_dot_prod_rel (map FR2 l) rp)
  (Hin : forall x, In x l -> Rabs (FT2R (fst x)) <= sqrt a /\ Rabs (FT2R (snd x)) <= sqrt a),
  Rabs rp <= INR (length l) * a.
Proof.
induction l; intros.
{ inversion Hrp; subst; simpl; rewrite Rabs_R0; nra. }
  inversion Hrp; subst.
  eapply Rle_trans; [apply Rabs_triang|].
  eapply Rle_trans; [apply Rplus_le_compat | ].
  rewrite Rabs_mult; apply Rmult_le_compat; try apply Rabs_pos.
  apply Hin; simpl; auto.
  apply Hin; simpl; auto.
  apply IHl; auto; [ apply Ha| intros; apply Hin; simpl; auto].
  rewrite sqrt_def; auto. apply Req_le;
  replace (length (a::l)) with ( S(length l)) by auto.
  rewrite S_INR; nra.
Qed.

Lemma dotprodR_rel_bound''  :
  forall (t : type) (l : list (ftype t * ftype t)) (rs_abs a: R)
  (Ha : 0 <= a)
  (Hrp : R_dot_prod_rel (map Rabsp (map FR2 l)) rs_abs)
  (Hin : forall x, In x l -> Rabs (FT2R (fst x)) <= sqrt a /\ Rabs (FT2R (snd x)) <= sqrt a),
  rs_abs <= INR (length l) * a.
Proof.
induction l; intros.
{ inversion Hrp; subst; simpl; nra. }
  inversion Hrp; subst.
  eapply Rle_trans; [ apply Rplus_le_compat | ].
  apply Rmult_le_compat;
  [ destruct a; simpl; apply Rabs_pos | destruct a; simpl; apply Rabs_pos | | ].
  apply Hin; simpl; auto.
  apply Hin; simpl; auto.
  apply IHl; auto; [ apply Ha| intros; apply Hin; simpl; auto].
  rewrite sqrt_def; auto. apply Req_le;
  replace (length (a::l)) with ( S(length l)) by auto.
  rewrite S_INR; nra.
Qed.

End RealDotProd.

Section NonZeroDP.
Context {NAN: Nans} {t : type}.

Variables (v1 v2 : list (ftype t)).
Hypothesis (Hlen : length v1 = length v2).

Notation v1R := (map FT2R v1).

Lemma dot_prod_rel_nnzR :
forall
(fp : ftype t)
(Hfp : dot_prod_rel (combine v1 v2) fp)
(Hfin: Binary.is_finite (fprec t) (femax t) fp = true),
nnzR v1R = 0%nat -> FT2R fp = 0.
Proof.
intros.
pose proof nnz_lemma _ _ v1R _ H.
revert H0 H Hfp Hlen Hfin. revert v2 fp.
induction v1; intros.
simpl in *; inversion Hfp; auto.
destruct v2; try discriminate; auto.
inversion Hfp; subst.
unfold fst, snd.
assert (Hin: forall x : R, In x (map FT2R l) -> x = 0).
{ intros. apply H0; simpl; auto. }
assert (Hlen1:  length l = length l0) by (simpl; auto).
assert (HFIN: Binary.is_finite (fprec t) (femax t) s = true).
{ simpl in Hfin. destruct (BMULT a f); destruct s;
  destruct s0; try discriminate; simpl in *; auto;
  destruct s; try discriminate; auto.
}
pose proof nnz_is_zero_cons _ (FT2R a) (map FT2R l) _ _ H as H1.
specialize (IHl l0 s Hin H1 H4 Hlen1 HFIN).
destruct (@BPLUS_accurate' t NAN (BMULT a f) s Hfin)
  as (d & _ & Hacc).
rewrite Hacc; clear Hacc.
rewrite IHl.
assert (HFIN2: Binary.is_finite (fprec t) (femax t) (BMULT a f) = true).
{ simpl in Hfin. destruct (BMULT a f); destruct s; try discriminate; auto. }
assert (Ha: FT2R a = 0).
apply H0; simpl; auto.
pose proof Bmult_0R _ _ HFIN2 Ha as H2; destruct H2; rewrite H2;
simpl; nra.
Qed.

Lemma fma_dot_prod_rel_nnzR :
forall
(fp : ftype t)
(Hfp : fma_dot_prod_rel (combine v1 v2) fp)
(Hfin: Binary.is_finite (fprec t) (femax t) fp = true),
nnzR v1R = 0%nat -> FT2R fp = 0.
Proof.
intros.
pose proof nnz_lemma _ _ v1R _ H.
revert H0 H Hfp Hlen Hfin. revert v2 fp.
induction v1; intros.
simpl in *; inversion Hfp; auto.
destruct v2; try discriminate; auto.
inversion Hfp; subst.
unfold fst, snd.
assert (Hin: forall x : R, In x (map FT2R l) -> x = 0).
{ intros. apply H0; simpl; auto. }
assert (Hlen1:  length l = length l0) by (simpl; auto).
assert (HFIN: Binary.is_finite (fprec t) (femax t) s = true).
{ simpl in Hfin. destruct a; destruct f; destruct s;
  destruct s0; destruct s1; destruct s; try discriminate; simpl in *; auto;
  try discriminate; auto. }
pose proof nnz_is_zero_cons _ (FT2R a) (map FT2R l) _ _ H as H1.
specialize (IHl l0 s Hin H1 H4 Hlen1 HFIN).
assert (Ha: FT2R a = 0).
apply H0; simpl; auto.
rewrite (Bfma_mult_0R a f s  Hfin Ha).
rewrite IHl; auto.
Qed.

Lemma R_dot_prod_rel_nnzR :
forall
(rp : R)
(Hrp  : R_dot_prod_rel (map FR2 (combine v1 v2)) rp),
nnzR v1R = 0%nat -> rp = 0.
Proof.
intros ? ? H.
pose proof nnz_lemma _ _ v1R _ H.
revert H0 H Hrp  Hlen. revert v2 rp.
induction v1; intros.
simpl in *; inversion Hrp; auto.
destruct v2; try discriminate; auto.
inversion Hrp; subst.
unfold FR2, fst, snd.
assert (Hin: forall x : R, In x (map FT2R l) -> x = 0).
{ intros. apply H0; simpl; auto. }
assert (Hlen1:  length l = length l0) by (simpl; auto).
pose proof nnz_is_zero_cons _ (FT2R a) (map FT2R l) _ _ H as H1.
specialize (IHl l0 s Hin H1 H4 Hlen1).
rewrite IHl.
specialize (H0 (FT2R a)).
rewrite H0; [|simpl;auto]; nra.
Qed.

Lemma R_dot_prod_rel_nnzR_abs :
forall
(rp_abs : R)
(Hra : R_dot_prod_rel (map Rabsp (map FR2 (combine v1 v2))) rp_abs),
nnzR v1R = 0%nat -> rp_abs = 0.
Proof.
intros ? ? H.
pose proof nnz_lemma _ _ v1R  _ H.
revert H0 H Hra  Hlen. revert v2 rp_abs .
induction v1; intros.
simpl in *. inversion Hra. auto.
destruct v2; try discriminate; auto.
inversion Hra; subst.
unfold FR2, Rabsp, fst, snd.
assert (Hin: forall x : R, In x (map FT2R l) -> x = 0).
{ intros. apply H0; simpl; auto. }
assert (Hlen1:  length l = length l0) by (simpl; auto).
pose proof nnz_is_zero_cons _ (FT2R a) (map FT2R l) _ _ H as H2.
specialize (IHl l0 s Hin H2 H4 Hlen1).
rewrite IHl.
pose proof in_map Rabs (map FT2R (a::l)).
specialize (H0  (FT2R a)).
rewrite H0; [|simpl;auto]. rewrite Rabs_R0. nra.
Qed.

End NonZeroDP.


Require Omega.
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.

Theorem ex_falso_quodlibet : forall (P:Set),
  False -> P.
Proof.  intros P contra.
  inversion contra.
Qed.

Inductive minimal_in_list : nat -> list nat -> Prop :=
  mil_Base : forall n, minimal_in_list n [n]
| mil_Head : forall n m tl, n <= m -> minimal_in_list m tl -> minimal_in_list n (n::tl)
| mil_Tail : forall n m tl, m <  n -> minimal_in_list m tl -> minimal_in_list m (n::tl).

(*
Program Fixpoint minimal1 (l : list nat) (_ : length l > 0) : { n | minimal_in_list n l} :=
  match l with
    [h] => h
  | h::tl => let m := minimal1 tl _ in if leb h m then h else m
  | _ => 0
  end.

Obligation 1. apply mil_Base. Qed.
Obligation 2. remember (H0 h). destruct tl. apply ex_falso_quodlibet. apply n. reflexivity.
                simpl. omega. Defined.
Obligation 3. admit. Defined.
Obligation 4. admit. Defined.
*)

(*Extraction "minimal1.ml" minimal1.*)

Ltac by_contradiction := try (simpl in *; omega; match goal with H:_ |- _ => inversion H end).

Hint Constructors minimal_in_list.
Theorem minimal :
  forall (l : list nat), length l > 0 -> { n | minimal_in_list n l}.
Proof.
  intros. induction l. by_contradiction.
    destruct l eqn: L.
      exists a. auto. (*apply mil_Base.*)
      assert (A: length (n::l0) > 0). simpl in *. omega.
      apply IHl in A. inversion A.
      remember (le_gt_dec a x) as A1.
      inversion A1. exists a. eauto. (*apply mil_Head with x; assumption.*)
                    exists x. eauto. (*apply mil_Tail; assumption. *)
Defined.

Extraction Language Ocaml.

Extraction "minimal.ml" minimal.

Print minimal.
Inductive list_sorted : list nat -> Prop :=
  ls_Nil  : list_sorted []
| ls_One  : forall n, list_sorted [n]
| ls_Cons : forall n m tl,
    list_sorted tl -> minimal_in_list m tl -> n <= m -> list_sorted (n::tl).

Inductive list_insert : nat -> list nat -> list nat -> Prop :=
  li_Head : forall n tl, list_insert n tl (n::tl)
| li_Tail : forall n m tl tl', list_insert n tl tl' -> list_insert n (m::tl) (m::tl').

Inductive list_permutation : list nat -> list nat -> Prop :=
  lp_Nil  : list_permutation [] []
| lp_Cons : forall n l l' m,
   list_permutation l' l -> list_insert n l' m -> list_permutation m (n::l).

Lemma minimal_in_sorted : forall n l,
  list_sorted (n::l) -> minimal_in_list n (n::l).
Proof.
  intros. destruct l.
    apply mil_Base.
    inversion H. apply mil_Head with m; assumption.
Qed.

Lemma minimal_in_inserted : forall l' n m l,
  minimal_in_list m l -> list_insert n l l' ->
  (m <= n /\ minimal_in_list m l') \/ (n < m /\ minimal_in_list n l').
Proof.
  intro l'. induction l'. intros. inversion H0.
    intros.
      remember (le_lt_dec m n) as A. clear HeqA. inversion A.
        clear A. left. split. assumption.
          inversion H0. rewrite <- H6. rewrite <- H5.
          apply le_lt_eq_dec in H1. inversion H1. apply mil_Tail. assumption. assumption.
            rewrite <- H4. apply mil_Head with m. omega. assumption.
          rewrite <- H4 in H. inversion H. rewrite <- H10 in H5.
            inversion H5. rewrite <- H9. rewrite <- H2. rewrite <- H9.
              apply mil_Head with n. assumption. apply mil_Base.
          remember (le_lt_dec m1 n) as A. clear HeqA. inversion A.
          apply (IHl' n m1 tl) in H11. inversion H11. inversion H13.
            rewrite <- H2. apply mil_Head with m1. omega. assumption.
            inversion H13. rewrite <- H2. apply mil_Head with n. omega. assumption.
              assumption.
          apply (IHl' n m1 tl) in H11. inversion H11. inversion H13.
            rewrite <- H2. apply mil_Head with m1. omega. assumption.
            inversion H13. rewrite <- H2. apply mil_Head with n. omega. assumption.
              assumption.
          apply (IHl' n m tl) in H11. inversion H11. inversion H12. rewrite <- H2.
            apply mil_Tail. assumption. assumption. inversion H12.
              apply lt_not_le in H13. apply ex_falso_quodlibet. apply H13. assumption.
              assumption.
        clear A. right. split. assumption.
          inversion H0. rewrite <- H6. rewrite <- H5. apply mil_Head with m. omega.
             assumption.
          rewrite <- H4 in H. inversion H. rewrite <- H10 in H5. inversion H5.
             apply mil_Tail. omega. apply mil_Base.
          remember (le_lt_dec n m1) as A. clear HeqA. inversion A.
          apply (IHl' n m1 tl) in H11. inversion H11. inversion H13.
             assert (HA: a < a). omega. remember (lt_irrefl a).
             apply ex_falso_quodlibet. apply n2. assumption.
             inversion H13. apply mil_Tail. omega. assumption. assumption.
          apply (IHl' n m1 tl) in H11. inversion H11. inversion H13.
             assert (HA: a < a). omega. remember (lt_irrefl a).
             apply ex_falso_quodlibet. apply n2. assumption.
             inversion H13. apply mil_Tail. omega. assumption. assumption.
          apply (IHl' n m tl) in H11. inversion H11. inversion H12.
             apply lt_not_le in H1. apply ex_falso_quodlibet. apply H1. assumption.
             inversion H12. apply mil_Tail. omega. assumption. assumption.
Qed.

Lemma minimal_in_inserted_preserve : forall l' n m l,
  minimal_in_list m l -> m <= n -> list_insert n l l' -> minimal_in_list m l'.
Proof.
  intros. apply (minimal_in_inserted l' n m l) in H.
   inversion H. inversion H2. assumption. inversion H2. apply lt_not_le in H3.
     apply ex_falso_quodlibet. apply H3. assumption. assumption.
Qed.

Lemma minimal_in_inserted_swap : forall n m l l',
  minimal_in_list m l -> n < m -> list_insert n l l' -> minimal_in_list n l'.
Proof.
  intros. apply (minimal_in_inserted l' n m l) in H.
    inversion H. inversion H2. apply lt_not_le in H0. apply ex_falso_quodlibet. apply H0.
      assumption. inversion H2. assumption. assumption.
Qed.

Lemma insert_sorted_exists :
  forall l n, list_sorted l -> {l' | list_insert n l l' & list_sorted l'}.
Proof.
  intros. induction l.
    exists [n]. apply li_Head. apply ls_One.
    remember (le_gt_dec n a) as A.
    inversion A.
      exists (n::a::l).
        apply li_Head.
        apply (ls_Cons n a (a::l)). assumption.
        apply minimal_in_sorted. assumption. assumption.
    assert (L: list_sorted l). inversion H. apply ls_Nil. assumption.
    apply IHl in L. inversion L.
      exists (a::x). apply li_Tail. assumption.
        inversion H. rewrite <- H5 in H1. inversion H1.
          apply ls_Cons with n. apply ls_One. apply mil_Base. omega.
          remember (le_gt_dec m n) as A1.
          inversion A1.
            assert (M: minimal_in_list m x).
              apply (minimal_in_inserted_preserve x n m l); assumption.
            apply ls_Cons with m; assumption.
            assert (M: minimal_in_list n x).
              apply (minimal_in_inserted_swap n m l x); assumption.
            apply ls_Cons with n; try assumption; omega.
Qed.

Theorem list_sort_exists : forall l, { l' | list_permutation l' l & list_sorted l'}.
Proof.
  intros. induction l.
    exists []. apply lp_Nil. apply ls_Nil.
    inversion IHl.
      apply (insert_sorted_exists x a) in H0. inversion H0.
      exists x0.
        apply lp_Cons with x; assumption. assumption.
Qed.

Inductive lists_merged : list nat -> list nat -> list nat -> Prop :=
  lm_LeftNil  : forall l, lists_merged [] l l
| lm_RightNil : forall l, lists_merged l [] l
| lm_Le       : forall m n l l' l'', m < n -> lists_merged l (n::l') l'' ->
                                              lists_merged (m::l) (n::l') (m::l'')
| lm_Gt       : forall m n l l' l'', n <= m -> lists_merged (m::l) l' l'' ->
                                               lists_merged (m::l) (n::l') (n::l'').

Lemma merge_sorted_exists : forall l l',
  list_sorted l -> list_sorted l' -> {l'' | lists_merged l l' l'' & list_sorted l''}.
Proof. admit. Qed.
(*
  intros l. induction l'.
    intros. exists l. apply lm_RightNil. assumption.
    intros. destruct l eqn: L.
      exists (a::l'). apply lm_LeftNil. assumption.
      remember (le_gt_dec a n) as A. clear HeqA. inversion A.
         apply IHl' in H. inversion H. exists (a::x). apply lm_Gt. assumption. assumption.
*)
Definition sort (l : list nat) : list nat :=
  match list_sort_exists l with exist2 r _ _ => r end.

Extraction Language Ocaml.

Set Extraction AccessOpaque.

Extraction "sort.ml" sort.

Theorem pred_exists : forall n, n > 0 -> {m | S m = n}.
Proof.
  intros. destruct n. omega.
  exists n. reflexivity.
Qed.

Definition pred (n : nat) : n > 0 -> nat := fun ev =>
  proj1_sig (pred_exists n ev).

Extraction "pred.ml" pred.

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

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
     left. rewrite Heq. reflexivity.
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

(** The following lemmas will be useful for rewriting terms involving [eq_id_dec]. *)

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x).
    reflexivity.
    apply ex_falso_quodlibet; apply n; reflexivity. Qed.

(** **** Exercise: 1 star, optional (neq_id) *)
Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
 intros.
 destruct (eq_id_dec x y). contradiction. reflexivity.
Qed.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if eq_id_dec x x' then n else st x'.

(** For proofs involving states, we'll need several simple properties
    of [update]. *)

(** **** Exercise: 1 star (update_eq) *)
Theorem update_eq : forall n x st,
  (update st x n) x = n.
Proof.
  intros. unfold update. apply eq_id.
Qed.

(** **** Exercise: 1 star (update_neq) *)
Theorem update_neq : forall x2 x1 n st,
  x2 <> x1 ->
  (update st x2 n) x1 = (st x1).
Proof.
  intros. unfold update. apply neq_id. assumption.
Qed.

(** **** Exercise: 1 star (update_example) *)
(** Before starting to play with tactics, make sure you understand
    exactly what the theorem is saying! *)

Theorem update_example : forall (n:nat),
  (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intros. unfold update. simpl. unfold empty_state. reflexivity.
Qed.

(** **** Exercise: 1 star (update_shadow) *)
Theorem update_shadow : forall n1 n2 x1 x2 (st : state),
   (update  (update st x2 n1) x2 n2) x1 = (update st x2 n2) x1.
Proof.
  intros. unfold update. destruct (eq_id_dec x2 x1) eqn:D.
    reflexivity.
    reflexivity.
Qed.

(** **** Exercise: 2 stars (update_same) *)
Theorem update_same : forall n1 x1 x2 (st : state),
  st x1 = n1 ->
  (update st x1 n1) x2 = st x2.
Proof.
  intros. unfold update. destruct (eq_id_dec x1 x2). rewrite <- e. symmetry. assumption.
  reflexivity.
Qed.

(** **** Exercise: 3 stars (update_permute) *)
Theorem update_permute : forall n1 n2 x1 x2 x3 st,
  x2 <> x1 ->
  (update (update st x2 n1) x1 n2) x3 = (update (update st x1 n2) x2 n1) x3.
Proof.
  intros. unfold update.
  destruct (eq_id_dec x1 x3) eqn: D1. rewrite e in H.
    destruct (eq_id_dec x2 x3) eqn: D2. contradiction. reflexivity.
    reflexivity.
Qed.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

Fixpoint s_execute (st : state) (stack : list nat)
                   (prog : list sinstr)
                 : list nat :=
match prog with
| [] => stack
| (SPush n)::prog' => s_execute st (n :: stack) prog'
| (SLoad i)::prog' => s_execute st (st i :: stack) prog'
| op::prog' =>
   match stack with
   | y::x::stack' =>
      s_execute
        st
        (((match op with
           | SPlus => plus
           | SMinus => minus
           | SMult => mult
           | _ => plus
           end) x y)::stack')
        prog'
   | _ => s_execute st stack prog'
   end
end.

Lemma s_execute_composition : forall p st s s' s'' p',
  s_execute st s p  = s' -> s_execute st s' p' = s'' -> s_execute st s (p ++ p') = s''.
Proof. admit. Qed.

Hint Resolve s_execute_composition.

Theorem compiler_exists :
  forall (e : aexp), {p : list sinstr | forall st s, s_execute st s p = (aeval st e)::s}.
Proof.
  intros. induction e.
    exists [SPush n]. eauto.
    exists [SLoad i]. eauto.
    inversion IHe1. inversion IHe2. exists (x ++ x0 ++ [SPlus]). eauto.
    inversion IHe1. inversion IHe2. exists (x ++ x0 ++ [SMinus]). eauto.
    inversion IHe1. inversion IHe2. exists (x ++ x0 ++ [SMult]). eauto.
Qed.

Definition compile (e : aexp) :=
  proj1_sig (compiler_exists e).

Extraction "compile.ml" compile.

Inductive snoc : nat -> list nat -> list nat -> Prop :=
  snoc_Nil  : forall n, snoc n [] [n]
| snoc_Cons : forall n m l l', snoc n l l' -> snoc n (m::l) (m::l').

Theorem snoc_exists : forall n l, {l' | snoc n l l'}.
Proof.
  intros. induction l.
  exists [n]. apply snoc_Nil.
  inversion IHl. exists (a::x). apply snoc_Cons. assumption.
Qed.

Inductive reverse : list nat -> list nat -> Prop :=
  reverse_Nil  : reverse [] []
| reverse_Cons : forall n l l' l'', reverse l l' -> snoc n l' l'' -> reverse (n::l) l''.

Theorem reverse_exists : forall l, {l' | reverse l l'}.
Proof.
  intros. induction l.
    exists []. apply reverse_Nil.
    inversion IHl. assert (S: {m | snoc a x m}). apply snoc_exists.
      inversion S. exists x0. apply reverse_Cons with x. assumption. assumption.
Qed.

Definition rev l := proj1_sig (reverse_exists l).

Extraction "rev.ml" rev.

Inductive counted (X : Set) : nat -> Set := count : forall n, X -> counted X n.

Definition ret  (X : Set) (x : X) : counted X 0 := count X 0 x.

Definition bind (X Y : Set) {n m : nat} : counted X n -> (X -> counted Y m) -> counted Y (m+n) :=
  fun c f =>
    match c with count n x =>
      match f x with count m y => count Y (m+n) y end
    end.

Definition increment (X : Set) {n : nat} : counted X n -> counted X (S n) := fun c =>
  match c with count n x => count X (S n) x end.

Notation "A >>= B" := (bind A B) (at level 90, right associativity).

Definition zero_counted := ret nat 80.

Print zero_counted.

Definition one_counted := increment nat zero_counted.

Print one_counted.

Fixpoint csum (n m : nat) : counted nat n :=
  match n with
  | 0    => ret nat m
  | S n' => increment nat (csum n' m)
  end.

Definition clength (X : Type) (l : list X) : counted nat (length l).
  destruct l; simpl; constructor; constructor.
Defined.

Extraction "clength.ml" clength.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
Classical logic is somewhat surprising!
Prove that given two arbitrary propositions
a and b, either a implies b or the converse *)

Lemma CL_is_wrong_and_boolrefl_is_nice (A B : ...) :
  (A -> B) \/ (B -> A).
Admitted.

(** Enrico is a lazy student.  When asked to reverse and filter
a list he comes up with the following ugly code. *)

Fixpoint filtrev T (p : pred T) (acc : seq T) (l : seq T) : seq T :=
  if l is x :: xs then
    if p x then filtrev p (x :: acc) xs
           else filtrev p       acc  xs
  else acc.

(**  The teacher asks him to prove that his ugly code is equivalent
 to the nicer code [[seq x <- rev l | p x]] he could have written
by reusing the seq library.

Such proof is not trivial:
  - [filtrev] has an accumulator, [rev] (at least apparently)
    does not.
  - which is the invariant linking the accumulator [acc] and [p]
    in the code of [filtrev]?  Depending on how you expose
    the accumulator on the right hand side of the goal,
    such invariant may need to be taken into account by the induction.

Relevant keywords for [Search] are: rev cons cat filter rcons
Hint: it is perfectly fine to state intermediate lemmas
*)

Lemma filterrev_ok T p (l : seq T) :
  filtrev p [::] l = [seq x <- rev l | p x ].
Proof.
Admitted.

(** Prove that if (s1 :|: s2) is disjoint from (s1 :|: s3) then
    s1 is empty *)
Lemma disjoint_setU2l (T : finType) (s1 s2 s3 : {set T}) :
   [disjoint s1 :|: s2 & s1 :|: s3] -> s1 = set0.
Admitted.

(** Prove the equivalence of these two sums.
    E.g. (n=8)
<<
    1 + 3 + 5 + 7 = 7-0 + 7-2 + 7-4 + 7-6
>>
*)
Lemma sum_odd n :
  ~~ odd n -> \sum_(i < n | odd i) i = \sum_(i < n | ~~ odd i) (n.-1 - i).
Proof.
Admitted.
(**

Now, some algebra.

*)
From mathcomp Require Import all_algebra.
From mathcomp Require Import algC.

Section AlgebraicHierarchy.
Section GaussIntegers.
Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.
(**

We remind what Gauss integer are and recall some theory about it.

*)
Definition gaussInteger := [qualify a x | ('Re x \in Cint) && ('Im x \in Cint)].
Axiom Cint_GI : forall (x : algC), x \in Cint -> x \is a gaussInteger.
Axiom GI_subring : subring_closed gaussInteger.

Fact GI_key : pred_key gaussInteger. Proof. by []. Qed.
Canonical GI_keyed := KeyedQualifier GI_key.
Canonical GI_opprPred := OpprPred GI_subring.
Canonical GI_addrPred := AddrPred GI_subring.
Canonical GI_mulrPred := MulrPred GI_subring.
Canonical GI_zmodPred := ZmodPred GI_subring.
Canonical GI_semiringPred := SemiringPred GI_subring.
Canonical GI_smulrPred := SmulrPred GI_subring.
Canonical GI_subringPred := SubringPred GI_subring.

Record GI := GIof {algGI : algC; algGIP : algGI \is a gaussInteger }.
Hint Resolve algGIP.

Canonical GI_subType := [subType for algGI].
Definition GI_eqMixin := [eqMixin of GI by <:].
Canonical GI_eqType := EqType GI GI_eqMixin.
Definition GI_choiceMixin := [choiceMixin of GI by <:].
Canonical GI_choiceType := ChoiceType GI GI_choiceMixin.
Definition GI_countMixin := [countMixin of GI by <:].
Canonical GI_countType := CountType GI GI_countMixin.
Definition GI_zmodMixin := [zmodMixin of GI by <:].
Canonical GI_zmodType := ZmodType GI GI_zmodMixin.
Definition GI_ringMixin := [ringMixin of GI by <:].
Canonical GI_ringType := RingType GI GI_ringMixin.
Definition GI_comRingMixin := [comRingMixin of GI by <:].
Canonical GI_comRingType := ComRingType GI GI_comRingMixin.

Lemma conjGIE x : (x^* \is a gaussInteger) = (x \is a gaussInteger).
Proof. by rewrite ![_ \is a _]qualifE algRe_conj algIm_conj rpredN. Qed.

Fact conjGI_subproof (x : GI) : (val x)^* \is a gaussInteger.
Proof. by rewrite conjGIE. Qed.

Canonical conjGI x := GIof (conjGI_subproof x).

Definition gaussNorm (x : algC) := x * x^*.

Axiom gaussNormE : forall x, gaussNorm x = `|x| ^+ 2.
Axiom gaussNormCnat : forall (x : GI), gaussNorm (val x) \in Cnat.
(**

Prove these two facts. (Hint: conjugation is a morphism)

*)
Lemma gaussNorm1 : gaussNorm 1 = 1.
Admitted.

Lemma gaussNormM : {morph gaussNorm : x y / x * y}.
Admitted.
(**

** Question: Prove that GI euclidean for the stasm gaussNorm.

 - i.e. ∀ (a, b) ∈ GI × GI*, ∃ (q, r) ∈ GI² s.t. a = q b + r and φ(r) < φ(b)
 - Suggested strategy: sketch the proof on a paper first, don't let Coq
   divert you from your proofsketch
 - We first sketch the "paper proof" here and then do it in Coq:
  - take a / b = x + i y
  - take u the closest integer to x, and v the closest integer to y
  - satisfy the existential with q = u + i v and r = a - q b,
    which are both Gauss integers.
  - We want to show that |a - q b|² < |b|².
  - It suffices to show |a / b - q|² < 1
  - But |a / b - q|² = (u - x)² + (v - x)² ≤ ½² + ½² < 1
 - Now we give a Coq proof with holes, fill in the holes.
*)
Lemma euclideanGI (a b : GI) : b != 0 ->
  exists2 qr : GI * GI, a = qr.1 * b + qr.2
                      & (gaussNorm (val qr.2) < gaussNorm (val b)).
Proof.
move=> b_neq0.

(* Trivial preliminaries *)
have oneV2 : 1 = 2%:R^-1 + 2%:R^-1 :> algC.
  by rewrite -mulr2n -[_ *+ 2]mulr_natr mulVf ?pnatr_eq0.
have V2ge0 : 0 <= 2%:R^-1 :> algC by admit.
have V2real : (2%:R^-1 : algC) \is Num.real by admit.

(* Closest integer to x, when x is real *)
pose approx (x : algC) : int :=
  floorC x + (if `|x - (floorC x)%:~R| <= 2%:R^-1 then 0 else 1).
have approxP x : x \is Creal -> `|x - (approx x)%:~R| <= 2%:R^-1.
  rewrite /approx => x_real; have /andP [x_ge x_le] := floorC_itv x_real.
  have [] // := @real_lerP _  `|_ - (floorC _)%:~R| _;
    first by rewrite addr0.
  rewrite [`|_ - (_ + 1)%:~R|]distrC !ger0_norm ?subr_ge0 //=;
     last by rewrite ltrW.
  move=> Dx1_gtV2; rewrite real_lerNgt ?rpredB // ?Creal_Cint ?Cint_int //.
  apply/negP=> /ltr_add /(_ Dx1_gtV2); rewrite -oneV2 !addrA addrNK.
  by rewrite [_ + 1]addrC rmorphD /= addrK ltrr.
have approxP2 x (_ : x \is Creal) : `|x - (approx x)%:~R| ^+ 2 < 2%:R^-1.
  rewrite (@ler_lt_trans _ (2%:R^-1 ^+ 2)) // ?ler_expn2r ?qualifE ?approxP //.
  by rewrite exprVn -natrX ltf_pinv ?qualifE ?ltr_nat ?ltr0n.

(* Proper proof *)
pose u := 'Re (val a / val b); pose v := 'Im (val a / val b).
have qGI : (approx u)%:~R + algCi * (approx v)%:~R \is a gaussInteger.
  (* Hint: use qualifE, alg*_rect and lemmas about Creal, Cint and _%:~R *)
  admit.
pose q := GIof qGI.
exists (q, a - q * b); first by rewrite addrC addrNK.
rewrite !gaussNormE /=.
rewrite -(@ltr_pmul2r _ (`|val b| ^-2)) ?invr_gt0 ?exprn_gt0 ?normr_gt0 //.
rewrite mulfV ?expf_eq0 /= ?normr_eq0 // -exprVn -exprMn.
rewrite -normfV -normrM mulrBl mulfK //.
suff uvP : `|u - (approx u)%:~R + 'i * (v - (approx v)%:~R)| ^+ 2 < 1.
  (* Hint: use algCrect and algebraic transformations *)
  admit.
set Du := _ - _; set Dv := _ - _.
have /andP [DuReal DvReal] : (Du \is Creal) && (Dv \is Creal).
(* Hint: use rpred*, Creal_*, normC2_rect, ream_normK and approxP2 *)
admit.
Admitted.

End GaussIntegers.
End AlgebraicHierarchy.

Section Polynomials.

Open Scope ring_scope.
Import GRing.Theory Num.Theory.

Variable n : nat.
Variables na nb: nat.
Hypothesis nbne0: nb != 0%N.

Definition a:rat := (Posz na)%:~R.
Definition b:rat :=(Posz nb)%:~R.

Definition pi := a / b.

Definition f :{poly rat} := (n`!)%:R^-1 *: ('X^n * (a%:P -  b*:'X)^+n).

Definition F :{poly rat} := \sum_(i:'I_n.+1) (-1)^i *: f^`(2*i).

Axiom derive_f_0_int: forall i, f^`(i).[0] \is a Qint.

(** Prove that F at 0 is a Qint.  Hint: relevant lemmas
are exprnP hornerE horner_sum and the rpred* family *)
Lemma F0_int : F.[0] \is a Qint.
Proof.
Admitted.

Axiom pf_sym:  f \Po (pi%:P -'X) = f.

(** Prove this equation by induction on [i].
Hint: relevant lemmas are scale* mulr* addr* expr* oppr* in ssralg,
derivnS derivZ deriv_comp derivE in poly *)
Lemma  derivn_fpix: forall i , (f^`(i)\Po(pi%:P -'X))= (-1)^+i *: f^`(i).
Proof.
Admitted.

(** Prove that F at pi is a Qint.
Hint: relevant lemmas are horner_comp sqrr_sign mulnC scale1r *)
Lemma FPi_int : F.[pi] \is a Qint.
Proof.
Admitted.

End Polynomials.

Section LinearAlgebra.
Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.
(**

* Endomorphisms u such that Ker u ⊕ Im u = E.

The endomorphisms of a space E of finite dimension n, such that u o v
= 0 and v + u is invertible are exactly the endomorphisms such that
Ker u ⊕ Im u = E.

 - Assume u o v = 0 and v + u is invertible,
  - we have rank (v + u) = n
  - we have rank v + rank u = n and we have Im v ⊂ Ker u
  - Hence we have Im v = Ker u
  - We deduce that Ker u ⊕ Im u = Im v ⊕ Im u = E

*)
Variables (F : fieldType) (n' : nat).
Let n := n'.+1.

Lemma ex_6_13 (u : 'M[F]_n):
  reflect (exists2 v : 'M_n, v * u = 0 & v + u \is a GRing.unit)
          ((kermx u + u == 1)%MS && mxdirect (kermx u + u)).
Proof.
(* Hint: use mxrank* lemmas and search on addsmx, submx and eqmx
sometimes. Don't forget about mxdirect_addsP and sub_kermxP. *)
apply: (iffP idP) => [|[v vMu vDu]]; last first.
  have rkvDu: \rank (v + u)%R = n by admit.
  have /eqP rkvDrku : (\rank v + \rank u)%N == n.
    by rewrite eqn_leq; admit.
  have sub_v_ku : (v <= kermx u)%MS by admit.
  have /eqmxP/eqmx_sym eq_vu: (v == kermx u)%MS.
    rewrite -(geq_leqif (mxrank_leqif_eq _)) //.
    admit.
  rewrite submx1 sub1mx -col_leq_rank mxdirectEgeq /=.
  (* use adds_eqmx to lift eq_vu to a sum *)
  (* Warning: - (u + v)%R  is a sum of matrices
              - (u + v)%MS is a sum of spaces
     use addmx_sub_adds and mxrankS
     to compare the rank (u + v) with dim (Im u + Im v) *)
  (* finish using hypothesis *)
  admit.
move=> /andP [/eqmxP kuDu_eq1 kvDu_direct].
pose v := proj_mx (kermx u) u; exists v.
  admit.
rewrite -row_free_unit -kermx_eq0.
apply/negP => /negP /rowV0Pn [x /sub_kermxP]; rewrite mulmxDr.
move=> /(canRL (addrK _)); rewrite sub0r => eq_xv_Nxu.
apply/negP; rewrite negbK; apply/eqP.
have : (x *m v <= kermx u :&: u)%MS.
(* Hint: use sub_*, proj_mx*, eqmx_*, mxdirect_addsP, *)
  admit.
Admitted.

End LinearAlgebra.


Require Import ZArith.

(* A temporal frame T=⟨T,≺⟩ defines the flow of time over
which the meanings of the tense operators are to be defined.
Note that, so far, no conditions like transitivity or irreflexivity on the "precedence"relation ≺ are imposed.*)
Parameter TemporalFrame: Set.

(* Logic of the future *)
Inductive LTTerm :=
| Atom: TemporalFrame -> LTTerm
| And: LTTerm -> LTTerm -> LTTerm
| Not: LTTerm -> LTTerm
| Globally: LTTerm -> LTTerm
| Future: LTTerm -> LTTerm
| Next: LTTerm -> LTTerm.

Definition Or a b := Not(And(Not a)(Not b)).
Definition Impl a b := Or (Not a) (b).
Definition Equiv a b := And (Impl a b) (Impl b a).

(*
  Hence □ and ◇ form a dual pair of operators.
  ◇p (future p) is equivalent to ¬□¬p ("not always not-p")
*)
(*Definition Future p := Not (Globally (Not p)).*)

(*
A temporal model for a set of atomic propositions PROP is a triple M=⟨T,≺,V⟩,
where ⟨T,≺⟩ is a temporal frame and V is a valuation assigning to every p∈PROP a set of time instants
V(p)⊆T at which p is declared true.

Equivalently, an interpretation of PROP in T is a mapping I : T × PROP → {true, false}
which assigns a truth value to each atomic proposition at each time instant in the temporal frame.
The truth of a formula of TL at a given time instant t
in a given temporal model M is defined inductively as follows:
M=⟨T,≺,V⟩
M,t ⊨p iff t∈V(p), for p ∈ PROP;
M,t ⊨¬ψ iff it is not the case that M,t⊨ψ;
M,t ⊨φ ∧ ψ iff M,t ⊨ φ and M,t ⊨ ψ;
M,t ⊨φ ∨ ψ iff M,t ⊨ φ or M,t ⊨ ψ;
M,t ⊨Gφ iff M,t'⊨φ for all time instants t' such that t≺t';
M,t ⊨Xφ iff M,succ(t) ⊨ φ;
M,t ⊨Fϕ iff M,h,t′⊨ϕ for some t' ∈ h such that t≺t'.
*)

Fixpoint eval (F :LTTerm) (t :nat) (valuation : TemporalFrame -> Prop) {struct F} : Prop :=
match F with
| Atom p => valuation p
| And a b => (eval a t valuation) /\ (eval b t valuation)
| Not p => not (eval p t valuation)
| Globally p => (forall t' , t' >= t -> (eval p t' valuation))
| Future p => (exists t' , t' >= t /\ (eval p t' valuation))
| Next p => (eval p (t + 1) valuation)
end.

(*
  Since ¬□¬p can be expressed by its dual ◇p, the Future evaluation
  can be expressed thanks to the Globally and the Not evaluation.
  This is illustrated by the following transformations and inductions:

  eval (Future p) t evaluation
  ⟺ not (eval (Globally (Not p)) t evaluation)                  [Equivalence]
  ⟺ not (forall t',  t'>=t -> (eval (Not p) t' valuation))      [Induction]
  ⟺ exists t', not(t'>=t -> (eval (Not p) t' valuation))        [Forall-Not]
  ⟺ exists t', not(not(t'>=t) \/ (eval (Not p) t' valuation))   [Equivalence]
  ⟺ exists t', t'>=t /\ not(eval (Not p) t' valuation)          [Not distribution]
  ⟺ exists t', t'>=t /\ not(not(eval p t' valuation))           [Induction]
  ⟺ exists t', t'>=t /\ eval p t' valuation                     [DoubleNot*]

  * This is possible since not works on boolean which relies on the law of excluded middle.
*)

(* Transitivity on order relation of TL ◇◇p → ◇p *)
Theorem future_trans: forall p t valuation, (eval (Future (Future p)) t valuation) -> (eval (Future p) t valuation).
Proof.
simpl;intros.
inversion H.
destruct H0.
inversion H1.
destruct H2.
exists x0.
split.
omega.
apply H3.
Qed.

(* Transitivity on order relation of TL ◇p → ◇◇p *)
Theorem future_trans2: forall p t valuation, (eval (Future p) t valuation) -> (eval (Future (Future p)) t valuation).
Proof.
simpl;intros.
inversion H.
destruct H0.
exists x.
intros; split.
apply H0.
exists x.
intros; split.
auto.
apply H1.
Qed.

(* Transitivity on order relation of TL □□p → □p *)
Theorem globally_trans: forall p t valuation, (eval (Globally (Globally p)) t valuation) -> (eval (Globally p) t valuation).
Proof.
  simpl.
  intros p t val H.
  apply H.
  omega.
Qed.

(* Transitivity on order relation of TL □p → □□p *)
Theorem globally_trans2: forall p t valuation, (eval (Globally p) t valuation) -> (eval (Globally (Globally p)) t valuation).
Proof.
  intros p t val H.
  simpl.
  intros.
  apply H.
  omega.
Qed.

(* Distributivity on next ◯(p ∨ q) → ◯p ∨ ◯q *)
Theorem next_distributivity_1: forall p q t valuation, (eval (Next (Or p q)) t valuation) -> (eval (Or (Next p) (Next q)) t valuation).
Proof.
simpl.
intros p q t val H.
assumption.
Qed.

(* Distributivity on next ◯p ∨ ◯q → ◯(p ∨ q) *)
Theorem next_distributivity_2: forall p q t valuation, (eval (Or (Next p) (Next q)) t valuation) -> (eval (Next (Or p q)) t valuation).
Proof.
simpl.
intros.
assumption.
Qed.

(* Distributivity on next ◯(p ∨ q) ≡ ◯p ∨ ◯q *)
Theorem next_distributivity: forall p q t valuation, (eval (Next (Or p q)) t valuation) <-> (eval (Or (Next p) (Next q)) t valuation).
Proof.
simpl.
intros.
split.
apply next_distributivity_1.
apply next_distributivity_2.
Qed.

(* Distributivity on globally □(p ∧ q) → □p ∧ □q *)
Theorem distributivity_globally_1: forall p q t valuation, (eval (Globally (And p q)) t valuation) -> (eval (And (Globally p) (Globally q)) t valuation).
Proof.
simpl.
intros p q t val H.
split.
intros.
apply H.
apply H0.
intros.
apply H.
apply H0.
Qed.

(* Distributivity on globally □p ∧ □q → □(p ∧ q) *)
Theorem distributivity_globally_2: forall p q t valuation, (eval (And (Globally p) (Globally q)) t valuation) -> (eval (Globally (And p q)) t valuation).
Proof.
simpl.
split.
intros.
apply H.
apply H0.
intros.
apply H.
apply H0.
Qed.

(* Distributivity on globally □(p ∧ q) ≡ □p ∧ □q *)
Theorem distributivity_globally: forall p q t valuation,  (eval (Globally (And p q)) t valuation) <-> (eval (And (Globally p) (Globally q)) t valuation).
Proof.
intros.
split.
apply distributivity_globally_1.
apply distributivity_globally_2.
Qed.

(* equiv globally *)

(* □p → ¬◇¬p *)
Theorem dual_nnpp_1: forall p t valuation, (eval (Globally p) t valuation) -> not (eval (Future (Not p)) t valuation).
Proof.
simpl.
intros p t valuation H H0.
inversion H0.
destruct H1.
apply H2.
apply H.
assumption.
Qed.

(* ¬◇¬p → □p *)
Theorem dual_nnpp_2: forall p t valuation, not (eval (Future (Not p)) t valuation) -> (eval (Globally p) t valuation).
Proof.
admit.
Admitted.

(* NNPP □p ≡ ¬◇¬p *)
Theorem nnpp: forall p t valuation, (eval (Globally p) t valuation) <-> not (eval (Future (Not p)) t valuation).
Proof.
admit.
Admitted.

(* equiv future *)

(* ◇p → ¬□¬p *)
Theorem dual_future_1: forall p t valuation, (eval (Future p) t valuation) -> not (eval (Globally (Not p)) t valuation).
Proof.
admit.
Admitted.

(* ¬□¬p → ◇p *)
Theorem dual_future_2: forall p t valuation, not (eval (Globally (Not p)) t valuation) -> (eval (Future p) t valuation).
Proof.
admit.
Admitted.

(* ◇p ≡ ¬□¬p *)
Theorem dual_future: forall p t valuation, (eval (Future p) t valuation) = not (eval (Globally (Not p)) t valuation).
Proof.
admit.
Admitted.

(* leads □p → ◇p *)
Theorem leads: forall p t valuation, (eval (Globally p) t valuation) -> (eval (Future p) t valuation).
Proof.
admit.
Admitted.