Require Export DMFP.Day11_propositions.

(** Today is a long day: we're going to teach you several tactics and
    proof methods. There are a few more exercises than usual, too. So:
    please start early and ask for help if you need it! *)

(* ################################################################# *)
(** * Proofs Within Proofs *)

(** In Coq, as in informal mathematics, large proofs are often
    broken into a sequence of theorems, with later proofs referring to
    earlier theorems.  But sometimes a proof will require some
    miscellaneous fact that is too trivial and of too little general
    interest to bother giving it its own top-level name.  In such
    cases, it is convenient to be able to simply state and prove the
    needed "sub-theorem" right at the point where it is used.  The
    [assert] tactic allows us to do this.  For example, our earlier
    proof of the [mult_0_plus] theorem referred to a previous theorem
    named [plus_O_n].  We could instead use [assert] to state and
    prove [plus_O_n] in-line: *)

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

(** The [assert] tactic introduces two sub-goals.  The first is
    the assertion itself; by prefixing it with [H:] we name the
    assertion [H].  (We can also name the assertion with [as] just as
    we did above with [destruct] and [induction], i.e., [assert (0 + n
    = n) as H].)  Note that we surround the proof of this assertion
    with curly braces [{ ... }], both for readability and so that,
    when using Coq interactively, we can see more easily when we have
    finished this sub-proof.  The second goal is the same as the one
    at the point where we invoke [assert] except that, in the context,
    we now have the assumption [H] that [0 + n = n].  That is,
    [assert] generates one subgoal where we must prove the asserted
    fact and a second subgoal where we can use the asserted fact to
    make progress on whatever we were trying to prove in the first
    place. *)

(* ################################################################# *)
(** * Unfolding Definitions *)

(** It sometimes happens that we need to manually unfold a Definition
    so that we can manipulate its right-hand side. We've already met
    the [unfold] tactic when talking about [not], but it's generally
    useful. For example, if we define... *)

Definition square n := n * n.

(** ... and try to prove a simple fact about [square]... *)

Lemma square_mult : forall n m,
    (forall n m o, n * (m * o) = (n * m) * o) -> (* we'll prove this later *)
    (forall n m, n * m = m * n) ->               (* same *)
    square (n * m) = square n * square m.
Proof.
  intros n m mult_assoc mult_comm.
  simpl.

(** ... we get stuck: [simpl] doesn't simplify anything at this point,
    and since we haven't proved any other facts about [square], there
    is nothing we can [apply] or [rewrite] with.

    To make progress, we can manually [unfold] the definition of
    [square]: *)

  unfold square.

(** Now we have plenty to work with: both sides of the equality are
    expressions involving multiplication, and we have lots of facts
    about multiplication at our disposal.  In particular, we know that
    it is commutative and associative, and from these facts it is not
    hard to finish the proof. *)

  rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
  { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.

(* ################################################################# *)
(** * Proof by Case Analysis *)

(** Of course, not everything can be proved by simple
    calculation and rewriting: In general, unknown, hypothetical
    values (arbitrary numbers, booleans, lists, etc.) can block
    simplification.  For example, if we try to prove the following
    fact using the [simpl] tactic as above, we get stuck.  (We then
    use the [Abort] command to give up on it for the moment.)*)

Theorem plus_1_neq_0_firsttry : forall n : nat,
  eqb (n + 1) 0 = false.
Proof.
  intros n.
  simpl.  (* does nothing! *)
Abort.

(** The reason for this is that the definitions of both
    [eqb] and [+] begin by performing a [match] on their first
    argument.  But here, the first argument to [+] is the unknown
    number [n] and the argument to [eqb] is the compound
    expression [n + 1]; neither can be simplified.

    To make progress, we need to consider the possible forms of [n]
    separately.  If [n] is [O], then we can calculate the final result
    of [eqb (n + 1) 0] and check that it is, indeed, [false].  And
    if [n = S n'] for some [n'], then, although we don't know exactly
    what number [n + 1] yields, we can calculate that, at least, it
    will begin with one [S], and this is enough to calculate that,
    again, [eqb (n + 1) 0] will yield [false].

    The tactic that tells Coq to consider, separately, the cases where
    [n = O] and where [n = S n'] is called [destruct]. *)

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

(** The [destruct] generates _two_ subgoals, which we must then
    prove, separately, in order to get Coq to accept the theorem. The
    annotation "[as [| n']]" is called an _intro pattern_.  It tells
    Coq what variable names to introduce in each subgoal.  In general,
    what goes between the square brackets is a _list of lists_ of
    names, separated by [|].  In this case, the first component is
    empty, since the [O] constructor is nullary (it doesn't have any
    arguments).  The second component gives a single name, [n'], since
    [S] is a unary constructor.

    It's worth contrasting intro patterns with _match patterns_, i.e.,
    what we write in [match] expressions. A match pattern in a branch
    of a [match] expression names each constructor and its arguments,
    with a [|] before each one, e.g.:

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

    In contrast, an intro pattern names only the arguments of each
    constructor, leaving out the constructor name itself, as in:

   destruct n as [| n'].

    You can nest patterns, e.g., to do case analysis on [n] and [n']
    simultaneously, write:

   destruct n as [| [| n']].

    There will be three subgoals: [n = O], [n = S O], and [n = S (S
    n')].
 *)

(** When doing case analysis with [destruct], in each subgoal, Coq
    remembers the assumption about [n] that is relevant for this
    subgoal -- either [n = 0] or [n = S n'] for some n'.  The [eqn:E]
    annotation tells [destruct] to give the name [E] to this equation.
    Leaving off the [eqn:E] annotation causes Coq to elide these
    assumptions in the subgoals.  This slightly streamlines proofs
    where the assumptions are not explicitly used, but it is better
    practice to keep them for the sake of documentation, as they can
    help keep you oriented when working with the subgoals.  *)

(** The [-] signs on the second and third lines are called
    _bullets_, and they mark the parts of the proof that correspond to
    each generated subgoal.  The proof script that comes after a
    bullet is the entire proof for a subgoal.  In this example, each
    of the subgoals is easily proved by a single use of [reflexivity],
    which itself performs some simplification -- e.g., the first one
    simplifies [eqb (S n' + 1) 0] to [false] by first rewriting [(S n'
    + 1)] to [S (n' + 1)], then unfolding [eqb], and then simplifying
    the [match].

    Marking cases with bullets is entirely optional: if bullets are
    not present, Coq simply asks you to prove each subgoal in
    sequence, one at a time. But it is a good idea to use bullets.
    For one thing, they make the structure of a proof apparent, making
    it more readable. Also, bullets instruct Coq to ensure that a
    subgoal is complete before trying to verify the next one,
    preventing proofs for different subgoals from getting mixed
    up. These issues become especially important in large
    developments, where fragile proofs lead to long debugging
    sessions.

    There are no hard and fast rules for how proofs should be
    formatted in Coq -- in particular, where lines should be broken
    and how sections of the proof should be indented to indicate their
    nested structure.  However, if the places where multiple subgoals
    are generated are marked with explicit bullets at the beginning of
    lines, then the proof will be readable almost no matter what
    choices are made about other aspects of layout.

    This is also a good place to mention one other piece of somewhat
    obvious advice about line lengths.  Beginning Coq users sometimes
    tend to the extremes, either writing each tactic on its own line
    or writing entire proofs on one line.  Good style lies somewhere
    in the middle.  One reasonable convention is to limit yourself to
    80-character lines.

    The [destruct] tactic can be used with any inductively defined
    datatype.  For example, we use it next to prove that boolean
    negation is involutive -- i.e., that negation is its own
    inverse.
- _Theorem_: For any natural number [n],

      eqb (n + 1) 0 = false.

    _Proof_: Let [n] be given ([intros n]).
    We go by cases on [n] ([destruct n as [| n']]):

      - First, suppose [n=0]. We must show that [eqb (0 + 1) 0 = false], which we have by
        definition ([reflexivity]).
      - Next, suppose [n=S n']. We must show that [eqb ((S n') + 1) 0 = false], which holds
        by the definition of [eqb] ([reflexivity]).

    _Qed_.

    Notice how the [destruct] lines up with what we say in the
    paper proof. We open with announcing our intention---to do case
    analysis on [n]. While Coq wants to know the names of any possible
    subparts of [n] up front, in the _[as] pattern_ of the destruct;
    in the paper proof, we find out the names when we write out which
    case we're in explicitly: each subcase is written as its own
    bullet, where we announce the case we're in.

    We've encounted our first significant divergence (of many!)
    between how Coq and paper proofs work. Coq keeps track of the
    context for you, so Coq proof scripts can leave quite a bit
    implicit. Paper proofs are meant to communicate an idea from one
    human to another, so it's important to check in and make sure
    everyone is on the same page---by, for example, saying what each
    case is up front.

    Finally, note that we're not "transliterating" the Coq: the two
    uses of reflexivity in each branch are written slightly
    differently in the paper proof.
 *)

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

(** Note that the [destruct] here has no [as] clause because
    none of the subcases of the [destruct] need to bind any variables,
    so there is no need to specify any names.  (We could also have
    written [as [ | ]], or [as []].)  In fact, we can omit the [as]
    clause from _any_ [destruct] and Coq will fill in variable names
    automatically.  This is generally considered bad style, since Coq
    often makes confusing choices of names when left to its own
    devices. In a paper proof, it'd be good to announce that [b=false]
    in the first case and [b=true] in the second case.

    It is sometimes useful to invoke [destruct] inside a subgoal,
    generating yet more proof obligations. In this case, we use
    different kinds of bullets to mark goals on different "levels."
    For example: *)

Print complement. (* Just to remind you. *)

Lemma complement_involutive : forall (b : base),
    complement (complement b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

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

(** Each pair of calls to [reflexivity] corresponds to the
    subgoals that were generated after the execution of the [destruct c]
    line right above it. *)

(** Besides [-] and [+], we can use [*] (asterisk) as a third kind of
    bullet.  We can also enclose sub-proofs in curly braces, which is
    useful in case we ever encounter a proof that generates more than
    three levels of subgoals: *)

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

(** Since curly braces mark both the beginning and the end of a
    proof, they can be used for multiple subgoal levels, as this
    example shows. Furthermore, curly braces allow us to reuse the
    same bullet shapes at multiple levels in a proof: *)

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

(** As you may have noticed, many proofs perform case analysis on a variable
    right after introducing it:

       intros x y. destruct y as [|y].

    This pattern is so common that Coq provides a shorthand for it: we
    can perform case analysis on a variable when introducing it by
    using an intro pattern instead of a variable name. For instance,
    here is a shorter proof of the [plus_1_neq_0] theorem above. *)

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

(** **** Exercise: 1 star, standard (minus_n_O) *)
Lemma minus_n_O : forall n : nat, n = n - 0.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.  Qed.
(** [] *)

(** If there are no arguments to name, we can just write [[]]. *)

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(** **** Exercise: 2 stars, standard (andb_true_elim2)

    Prove the following claim, marking cases (and subcases) with
    bullets when you use [destruct]. *)

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c h. destruct c eqn :Ec.
  - destruct b eqn: Eb.
    + apply h.
    + reflexivity.
  - destruct b eqn: Eb.
    + apply h.
    + apply h.
Qed.
(** [] *)

(** At this point, a deeper discussion of unfolding and simplification
    is in order.

    You may already have observed that tactics like [simpl],
    [reflexivity], and [apply] will often unfold the definitions of
    functions automatically when this allows them to make progress.  For
    example, if we define [foo m] to be the constant [5]... *)

Definition foo (x: nat) := 5.

(** then the [simpl] in the following proof (or the [reflexivity], if
    we omit the [simpl]) will unfold [foo m] to [(fun x => 5) m] and
    then further simplify this expression to just [5]. *)

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.

(** However, this automatic unfolding is rather conservative.  For
    example, if we define a slightly more complicated function
    involving a pattern match... *)

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

(** ...then the analogous proof will get stuck: *)

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl. (* Does nothing! *)
Abort.

(** The reason that [simpl] doesn't make progress here is that it
    notices that, after tentatively unfolding [bar m], it is left with
    a match whose scrutinee, [m], is a variable, so the [match] cannot
    be simplified further.  (It is not smart enough to notice that the
    two branches of the [match] are identical.)  So it gives up on
    unfolding [bar m] and leaves it alone.  Similarly, tentatively
    unfolding [bar (m+1)] leaves a [match] whose scrutinee is a
    function application (that, itself, cannot be simplified, even
    after unfolding the definition of [+]), so [simpl] leaves it
    alone. *)

(** At this point, there are two ways to make progress.  One is to use
    [destruct m] to break the proof into two cases, each focusing on a
    more concrete choice of [m] ([O] vs [S _]).  In each case, the
    [match] inside of [bar] can now make progress, and the proof is
    easy to complete. *)

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(** This approach works, but it depends on our recognizing that the
    [match] hidden inside [bar] is what was preventing us from making
    progress. *)

(** A more straightforward way to make progress is to explicitly tell
    Coq to unfold [bar]. *)

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.

  (** Now it is apparent that we are stuck on the [match] expressions on
    both sides of the [=], and we can use [destruct] to finish the
    proof without thinking too hard. *)

  destruct m.
  - reflexivity.
  - reflexivity.
Qed.

(** Finally, it's often useful to do the [unfold]/[fold] 1-2 punch:
    [unfold]ing a recursive definition and then immediately [fold]ing
    it back up will reveal the work one step of recursion is doing
    without doing any simplification. *)

Fixpoint funny_rec (n : nat) : nat :=
  match n with
  | O => 0
  | S n' => if evenb n then 0 else funny_rec n'
  end.

(** **** Exercise: 2 stars, standard (funny_rec_evenb_0)

    In the [n = S n'] case, notice that [simpl] gives you an annoying
    answer, but [unfold]/[fold] works a treat. *)
Lemma funny_rec_evenb_0 : forall n,
    evenb n = true ->
    funny_rec n = 0.
Proof.
  intros n H.
  unfold funny_rec.
  destruct n.
  - reflexivity.
  - rewrite -> H. reflexivity.
Qed.
(** [] *)

(** We can formalize this trick in a new tactic (yet another
    programming language inside of Coq!).  Now, we can say [step
    funny_rec] to go through one level of its recursion.

    [step] here does the work of [unfold] followed by [fold].
    The notations defined below mean we can also use [step] on hypotheses.
 *)

Ltac step_goal A := unfold A; fold A.
Ltac step_in A H := unfold A in H; fold A in H.
Tactic Notation "step" constr(A) := step_goal A.
Tactic Notation "step" constr(A) "in" hyp(H) := step_in A H.

(* ################################################################# *)
(** * Logical Connectives *)

(** Now that we've seen [destruct], we can do more with logical
    connectives. So far we've only _proved_ conjunctions and
    disjunctions. How do you use them? And what about negation? *)

(* ================================================================= *)
(** ** Conjunction *)

(** We've seen that proving a conjunction means using [split] to prove
    each part. To go in the other direction -- i.e., to _use_ a
    conjunctive hypothesis to help prove something else -- we employ
    the [destruct] tactic.

    If the proof context contains a hypothesis [H] of the form [A /\
    B], writing [destruct H as [HA HB]] will remove [H] from the
    context and add two new hypotheses: [HA], stating that [A] is
    true, and [HB], stating that [B] is true. *)

(** The following lemmas not only show the general idea, but they're
    generally useful: it's a common situation to know [A /\ B] but
    only really need just [A] (or just [B]). *)

Lemma proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q [HP HQ]. (* "Let P and Q be given, and assume P /\ Q." *)
  apply HP. (* "We have to show P; but we've just assumed P, so we're done." *)
Qed.

(** **** Exercise: 1 star, standard, optional (proj2) *)
Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we sometimes need to rearrange the order of conjunctions
    and/or the grouping of multi-way conjunctions.  The following
    commutativity and associativity theorems are handy in such
    cases. *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ].
  split.
    - (* left *) apply HQ.
    - (* right *) apply HP.  Qed.

(** **** Exercise: 2 stars, standard (and_assoc)

    (In the following proof of associativity, notice how the _nested_
    intro pattern 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 [HP [HQ HR]].
  split.
  - split.
    + apply HP.
    + apply HQ.
  - apply HR.
Qed.
(** [] *)

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

(** As usual, we can also destruct [H] right when we introduce it,
    instead of introducing and then destructing it: *)

Lemma and_example2' :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  (* "Let [n] and [m] be given, and assume [n = 0] and [m = 0].  We
     need to show [n + m = 0] " *)
  intros n m [Hn Hm].
  (* Since n is 0 and m is 0, showing [n + m = 0] means showing [0 + 0
     = 0], .... *)
  rewrite Hn. rewrite Hm.
  (* ... which is immediate by the definition of [plus]. *)
  reflexivity.
Qed.

(** You may wonder why we bothered packing the two hypotheses [n = 0]
    and [m = 0] into a single conjunction, since we could have also
    stated the theorem with two separate premises: *)

Lemma and_example2'' :
  forall n m : nat, n = 0 -> m = 0 -> n + m = 0.
Proof.
  intros n m Hn Hm.
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

(** For this theorem, both formulations are fine.  But it's
    important to understand how to work with conjunctive hypotheses
    because conjunctions often arise from intermediate steps in
    proofs, especially in bigger developments. We'll see an example on
    day 12. *)

(* ================================================================= *)
(** ** Disjunction *)

(** Another important connective is the _disjunction_, or _logical or_
    of two propositions: [A \/ B] is true when either [A] or [B] is.
    (Alternatively, we can write [or A B], where [or : Prop -> Prop ->
    Prop].)

    Recall that we used [left] and [right] to choose which branch of
    disjunction to prove. Just as for conjunction, we use [destruct]
    to ask: if we know [P \/ Q], which one holds?  *)

Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q HPQ. destruct HPQ as [HP | HQ].
  - (* left *) right. apply HP.
  - (* right *) left. apply HQ.  Qed.

Theorem or_commut' : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q [HP | HQ].
  - (* left *) right. apply HP.
  - (* right *) left. apply HQ.  Qed.

(** ... and a slightly more interesting example requiring both [left]
    and [right]: *)

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  (* WORKED IN CLASS *)
  intros [|n].
  - left. reflexivity.
  - right. reflexivity.
Qed.

(* ================================================================= *)
(** ** Falsehood and Negation

    So far, we have mostly been concerned with proving that certain
    things are _true_ -- addition is commutative, appending lists is
    associative, etc.  Of course, we may also be interested in
    _negative_ results, showing that certain propositions are _not_
    true. In Coq, such negative statements are expressed with the
    negation operator [~]. *)

(** To see how negation works, recall the discussion of the _principle
    of explosion_ from the [Tactics] chapter; it asserts that, if
    we assume a contradiction, then any other proposition can be
    derived.  Following this intuition, we could define [~ P] ("not
    [P]") as [forall Q, P -> Q].  Coq actually makes a slightly
    different choice, defining [~ P] as [P -> False], where [False] is
    a specific contradictory proposition defined in the standard
    library. *)

Module MyNot.

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

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

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

End MyNot.

(** PROP ::= EXPR1 = EXPR2
           | forall x : TYPE, PROP
           | PROP1 -> PROP2
           | PROP1 /\ PROP2
           | PROP1 \/ PROP2
           | True
           | ~ PROP
           | False
 *)

(** Since [False] is a contradictory proposition, the principle of
    explosion also applies to it. If we get [False] into the proof
    context, we can use [destruct] on it to complete
    any goal: *)

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

Theorem not_False :
  ~ False.
Proof.
  (* We must show [~ False].  Towards a contradiction, assume [False].  *)
  unfold not. intros H.
  (* But we've already assumed something impossible---that [False]
    holds!  By the principle of explosion, the original claim of [~
    False] must be true. *)
  destruct H. (* Or... [apply H]! *)
Qed.

(** The Latin _ex falso quodlibet_ means, literally, "from falsehood
    follows whatever you like"; this is another common name for the
    principle of explosion. *)

(** **** Exercise: 2 stars, standard, optional (not_implies_our_not)

    (Optionally) show that Coq's definition of negation implies the
    intuitive one mentioned above: *)

Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** Especially as you're getting used to our notion of negation, using
    the [unfold] tactic is helpful: it will turn a negation into an
    implication. (You can use [unfold] and its partner, [fold], on any
    [Definition] or [Fixpoint], not just [not]!) *)

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, standard (contrapositive) *)
Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H.
  unfold not.
  intros HQ HP.
  apply HQ.
  apply H.
  apply HP.
Qed.
(** [] *)

(* ################################################################# *)
(** * More Exercises *)

(** **** Exercise: 2 stars, standard, optional (boolean_functions)

    Use the tactics you have learned so far to prove the following
    theorem about boolean functions. *)

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

(** Now state and prove a theorem in Coq; call it
    [negation_fn_applied_twice]. It should be similar to the previous
    one but where the second hypothesis says that the function [f] has
    the property that [f x = negb x].

    Just like for definitions, the autograder will reject your program
    if you don't define this theorem at the correct type! If you're
    having trouble, talk to Prof. or a TA.  *)

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  unfold negb.
  intros f x b.
  destruct b  eqn : Eb.
  - rewrite x. rewrite x. reflexivity.
  - rewrite x. rewrite x. reflexivity.
Qed.
(* Do not modify the following line: *)
Definition manual_grade_for_negation_fn_applied_twice : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * The [injection] and [discriminate] Tactics *)

(** Recall the definition of natural numbers:

     Inductive nat : Type :=
       | O
       | S (n : nat).

    This definition asserts that every number has one of two forms:
    either it is the constructor [O] or it is built by applying the
    constructor [S] to another number.  But there is more here than
    meets the eye: implicit in the definition are two more facts:

    - The constructor [S] is _injective_, or _one-to-one_.  That is,
      if [S n = S m], it must be that [n = m].

    - The constructors [O] and [S] are _disjoint_.  That is, [O] is not
      equal to [S n] for any [n]. *)

(** Similar principles apply to all inductively defined types: all
    constructors are injective, and the values built from distinct
    constructors are never equal.  For lists, the [cons] constructor
    is injective and [nil] is different from every non-empty list.
    For booleans, [true] and [false] are different.  (Since [true] and
    [false] take no arguments, their injectivity is neither here
    nor there.)  And so on. *)

(** For example, we can prove the injectivity of [S] by using the
    [pred] function defined in [Basics.v]. *)

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  (* Our use of [assert] here 'captures' [n]: we're proving this just
     for the [n] we have, not for all [n] (though it's true for all
     [n]). *)
  assert (H2: n = pred (S n)). { reflexivity. }
  (* For "obvious" properties like this, we might prefer to write
     [assert (H2: n = pred (S n)) by reflexivity.], avoiding the
     nested proof. *)
  rewrite H2. rewrite H1. reflexivity.
Qed.

(** This technique can be generalized to any constructor by
    writing the equivalent of [pred] -- i.e., writing a function that
    "undoes" one application of the constructor. As a more convenient
    alternative, Coq provides a tactic called [injection] that allows
    us to exploit the injectivity of any constructor.  Here is an
    alternate proof of the above theorem using [injection]: *)

Theorem S_injective' : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.
(** By writing [injection H as Hmn] at this point, we are asking Coq
    to generate all equations that it can infer from [H] using the
    injectivity of constructors (in the present example, the equation
    [n = m]). Each such equation is added as a hypothesis (with the
    name [Hmn] in this case) into the context. *)
  injection H as Hnm. apply Hnm.
Qed.

(** Here's a more interesting example that shows how [injection] can
    derive multiple equations at once. *)

Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  (* WORKED IN CLASS *)
  injection H as H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

(** Alternatively, if you just say [injection H] with no [as] clause,
    then all the equations will be turned into hypotheses at the
    beginning of the goal. *)

Theorem injection_ex2 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  (* Let n, m, and o be given; assume [[n;m] = [o;o]]. *)
  intros n m o H.
  (* By this assumption and the injectivity of [cons], n must be o and
  m must also be o. *)
  injection H.
  (* WORKED IN CLASS *)
  intros H1 H2. rewrite H1. rewrite H2.
  (* So [[n] = [m]] is just [[o]=[o]], which is immediate. *)
  reflexivity.
Qed.

(** **** Exercise: 3 stars, standard, optional (injection_ex3) *)
Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  j = z :: l ->
  x = y.
Proof.
  intros X x y z l j H Hj.
  injection H.
  rewrite Hj.
  intros H1 H2.
  injection H1.
  intros H3.
  rewrite H2.
  rewrite H3.
  reflexivity.
Qed.
(** [] *)

(** So much for injectivity of constructors.  What about disjointness?

    The principle of disjointness says that two terms beginning with
    different constructors (like [O] and [S], or [true] and [false])
    can never be equal.  This means that, any time we find ourselves
    in a context where we've _assumed_ that two such terms are equal,
    we are justified in concluding anything we want, since the
    assumption is nonsensical. *)

(** The [discriminate] tactic embodies this principle: It is used on a
    hypothesis involving an equality between different
    constructors (e.g., [S n = O]), and it solves the current goal
    immediately.  Here is an example: *)

Theorem eqb_0_l : forall n,
   eqb 0 n = true -> n = 0.
Proof.
  intros n.

(** We can proceed by case analysis on [n]. The first case is
    trivial. *)

  destruct n as [| n'] eqn:E.
  - (* n = 0 *)
    intros H. reflexivity.

(** However, the second one doesn't look so simple: assuming [eqb 0
    (S n') = true], we must show [S n' = 0]!  The way forward is to
    observe that the assumption itself is nonsensical: *)

  - (* n = S n' *)
    simpl.

(** If we use [discriminate] on this hypothesis, Coq confirms
    that the subgoal we are working on is impossible and removes it
    from further consideration. *)

    intros H. discriminate H.
Qed.

(** The [discriminate] tactic is an instance of the logical principle
    we met earlier: the _principle of explosion_. *)

Theorem discriminate_ex1 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  (* Let n be given, and assume [S n = 0]. *)
  intros n contra.
  (* But by the disjointness of the constructors for [nat], this is
  impossible---[S] of anything can't possibly be [O].  So we have a
  contradition. *)
  discriminate contra. Qed.

Theorem discriminate_ex2 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros n m contra. discriminate contra. Qed.

(** If you find the principle of explosion confusing, remember
    that these proofs are _not_ showing that the conclusion of the
    statement holds.  Rather, they are showing that, _if_ the
    nonsensical situation described by the premise did somehow arise,
    _then_ the nonsensical conclusion would also follow, because we'd
    be living in an inconsistent universe where every statement is
    true.  We'll explore the principle of explosion in more detail in
    the next chapter, [Logic]. *)

(** **** Exercise: 1 star, standard (discriminate_ex3) *)
Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
  intros X x y z l j H.
  discriminate H.
Qed.
(** [] *)

(** This is how we use [not] to state that [0] and [1] are different
    elements of [nat]: *)

Theorem zero_not_one : ~(0 = 1).
Proof.
  (** The proposition [0 <> 1] is exactly the same as
      [~(0 = 1)], that is [not (0 = 1)], which unfolds to
      [(0 = 1) -> False]. (We use [unfold not] explicitly here
      to illustrate that point, but generally it can be omitted.) *)

  unfold not.

  (** To prove an inequality, we may assume the opposite
      equality... *)

  intros contra.

  (** ... and deduce a contradiction from it. Here, the
      equality [O = S O] contradicts the disjointness of
      constructors [O] and [S], so [discriminate] takes care
      of it. *)

  discriminate contra.
Qed.

(** Such inequality statements are frequent enough to warrant a
    special notation, [x <> y]: *)

Check (0 <> 1).
(* ===> Prop *)

Theorem zero_not_one' : 0 <> 1.
Proof.
  intros H. discriminate H.
Qed.

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

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  (* Let b be given, and assume [b <> true]. Observe that b is either true or false. *)
  intros b H. destruct b.
  - (* b = true *)
    (* If b is true, we must show [b = false]. But we've already
    assumed [b <> true], so this case will never arise. *)
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  - (* b = false *)
    (* If b is false, we have our goal of [b = false] immediately. *)
    reflexivity.
Qed.

(** Since reasoning with [ex_falso_quodlibet] is quite common, Coq
    provides a built-in tactic, [exfalso], for applying it. *)

Theorem not_true_is_false' : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - (* b = false *)

    unfold not in H.
    exfalso.                (* <=== *)
    apply H. reflexivity.
  - (* b = true *) reflexivity.
Qed.

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

(** **** Exercise: 1 star, standard, optional (not_both_true_and_false)

    Some (optional!) practice with logical connectives. *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Logical Equivalence *)

(** The handy "if and only if" a/k/a iff connective, which asserts
    that two propositions have the same truth value, is just the
    conjunction of two implications. *)

(** PROP ::= EXPR1 = EXPR2
           | forall x : TYPE, PROP
           | PROP1 -> PROP2
           | PROP1 /\ PROP2
           | PROP1 \/ PROP2
           | True
           | ~ PROP
           | False
           | PROP1 <-> PROP2
 *)

Module MyIff.

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

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

End MyIff.

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

(** **** Exercise: 1 star, standard, 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.
  (* FILL IN HERE *) Admitted.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Some of Coq's tactics treat [iff] statements specially, avoiding
    the need for some low-level proof-state manipulation.  In
    particular, [rewrite] and [reflexivity] can be used with [iff]
    statements, not just equalities.  To enable this behavior, we
    imported a "Setoid" Coq library on Day11. *)

(** Here is a simple example demonstrating how these tactics work with
    [iff].  First, let's prove a couple of basic iff equivalences... *)

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  (* We proceed by cases on b1. *)
  intros [].
  - (* Assuming [b1 = true], we must show [true || b2 = true <-> true = true \/ b2 = true]. *)
    (* By the definition of [orb], this is the same as showing [true = true <-> true = true \/ b2 = true]. *)
    simpl. intros b2.
    (* We will prove each direction of the biconditional. *)
    split.
    + (* Assume [true = true].  We must show [true = true \/ b2 = true], and the left disjunct is immediate from our assumption. *)
      intros _. left. reflexivity.
    + (* Now assume [true = true \/ b2 = true]. We must show [true = true]; but this is immediate anyhow. *)
      intros _. reflexivity.
  - (* Assuming [b1 = false], we must show [false || b2 = true <-> false = true \/ b2 = true].  By the definition of [orb] this is the same as showing [b2 = true <-> false = true \/ b2 = true]. *)
    simpl. intros []. (* We go by cases on b2. *)
    + (* If b2 is true, we must show [true = true <-> false = true \/ true = true].  We prove each direction separately. *)
      split.
      * (* Assuming [true = true], we must show [false = true \/ true = true].  The right hand of the disjunction is immediate. *)
        intros _. right. reflexivity.
      * (* Assuming [false = true \/ true = true], we must show [true = true], but that's immediate. *)
        intros _. reflexivity.
    + (* If b2 is false, we must show [false = true <-> false = true \/ false = true]. *)
      (* We prove each direction separately. *)
      split.
      * (* Assuming [false = true], we must show [false = true \/ false = true].  But we've just assumed that [false = true], which is a contradiction by the disjointness of the constructors of bool. *)
        intros H. discriminate H.
      * (* Now assume [false = true \/ false = true].  In either case we must prove [false = true], which is immediate by the (contradictory) assumption. *)
        intros [H | H].
        { apply H. }
        { apply H. }
Qed.

Lemma or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [H | [H | H]].
    + left. left. apply H.
    + left. right. apply H.
    + right. apply H.
  - intros [[H | H] | H].
    + left. apply H.
    + right. left. apply H.
    + right. right. apply H.
Qed.

(** We can now use these facts with [rewrite] and [reflexivity] to
    give smooth proofs of statements involving equivalences.  Here is
    a ternary version of the [orb_true_iff] result: *)

Lemma orb_true_3 :
  forall a b c : bool, a || b || c = true <-> a = true \/ b = true \/ c = true.
Proof.
  intros n m p.
  rewrite orb_true_iff. rewrite orb_true_iff. rewrite or_assoc.
  reflexivity.
Qed.

(** The [apply] tactic can also be used with [<->]. When given an
    equivalence as its argument, [apply] tries to guess which side of
    the equivalence to use. *)

Lemma apply_iff_example :
  forall a b : bool, a || b = true -> a = true \/ b = true.
Proof.
  intros n m H. apply orb_true_iff. apply H.
Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  (* WORKED IN CLASS *)
  intros b. split.
  - (* -> *) apply not_true_is_false.
  - (* <- *)
    intros H. rewrite H. intros H'. discriminate H'.
Qed.

(** It's common to use iff to relate functions to propositions---like
    we already saw for [orb_true_iff]. Here we relate the [eq_base]
    function to the [=] proposition. All of these are good practice,
    but we leave them optional. *)

(** **** Exercise: 1 star, standard, optional (eq_base_refl) *)
Lemma eq_base_refl : forall (b : base),
    eq_base b b = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (eq_base_true) *)
Lemma eq_base_true : forall (b1 b2 : base),
    eq_base b1 b2 = true -> b1 = b2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard, optional (eq_base_iff)

    Prove a theorem characterizing equality on DNA bases.

    Proofs relating equality predicates (i.e., functions) to the
    equality proposition tend to take this form: one direction is
    simply reflexivity (if [b1 = b2], then you need only show that
    [eq_blah b1 b1 = true]) and the other is more involved (if
    [eq_blah b1 b2 = true], then [b1 = b2] for real).  *)
Lemma eq_base_iff : forall (b1 b2 : base),
    eq_base b1 b2 = true <-> b1 = b2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (not_P__P_true)

    This lemma is particularly useful for when we have computational
    characterizations of interesting properties. *)
Lemma not_P__P_true : forall P b,
    b = true <-> P ->
    b = false <-> ~P.
Proof.
  intros P b H.
  split.
  - rewrite <-H. intros H1. rewrite H1. apply not_true_iff_false. reflexivity.
  - destruct b eqn: bc.
    + rewrite <-H. intros H1.  apply not_true_iff_false. apply H1.
    + rewrite <-H. intros H1.  apply not_true_iff_false. apply H1.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (andb_true_iff)

    The following lemma relates the conjunction to the corresponding
    boolean operations. *)
Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ################################################################# *)
(** * Using Tactics on Hypotheses *)

(** By default, most tactics work on the goal formula and leave
    the context unchanged.  However, many tactics also have a variant
    that performs a similar operation on a statement in the context.

    For example, the tactic [simpl in H] performs simplification in
    the hypothesis named [H] in the context. *)

Theorem S_inj : forall (n m : nat) (b : bool),
     eqb (S n) (S m) = b  ->
     eqb n m = b.
Proof.
  intros n m b H. simpl in H. apply H.  Qed.

(** Similarly, [apply L in H] matches some conditional statement
    [L] (of the form [L1 -> L2], say) against a hypothesis [H] in the
    context.  However, unlike ordinary [apply] (which rewrites a goal
    matching [L2] into a subgoal [L1]), [apply L in H] matches [H]
    against [L1] and, if successful, replaces it with [L2].

    In other words, [apply L in H] gives us a form of "forward
    reasoning": from [L1 -> L2] and a hypothesis matching [L1], it
    produces a hypothesis matching [L2].  By contrast, [apply L] is
    "backward reasoning": it says that if we know [L1->L2] and we are
    trying to prove [L2], it suffices to prove [L1].

    Here is a variant of a proof from above, using forward reasoning
    throughout instead of backward reasoning. *)

Theorem silly3' : forall (n : nat),
  (eqb n 5 = true -> eqb (S (S n)) 7 = true) ->
  true = eqb n 5  ->
  true = eqb (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.  Qed.

(** Forward reasoning starts from what is _given_ (premises,
    previously proven theorems) and iteratively draws conclusions from
    them until the goal is reached.  Backward reasoning starts from
    the _goal_, and iteratively reasons about what would imply the
    goal, until premises or previously proven theorems are reached.
    If you've seen informal proofs before (for example, in a math
    class), they probably used forward reasoning. They might have even
    told you that backward reasoning was wrong or not allowed! In
    general, idiomatic use of Coq tends to favor backward reasoning,
    but in some situations the forward style can be easier to think
    about. *)

(* ################################################################# *)
(** * Using [destruct] on Compound Expressions *)

(** We have seen many examples where [destruct] is used to
    perform case analysis of the value of some variable.  But
    sometimes we need to reason by cases on the result of some
    _expression_.  We can also do this with [destruct].

    Here are some examples: *)

Definition sillyfun (n : nat) : bool :=
  if eqb n 3 then false
  else if eqb n 5 then false
       else false.

Theorem sillyfun_false : forall (n : nat),
    sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (eqb n 3).
  - (* eqb n 3 = true *) reflexivity.
  - (* eqb n 3 = false *) destruct (eqb n 5).
    + (* eqb n 5 = true *) reflexivity.
    + (* eqb n 5 = false *) reflexivity.  Qed.

(** After unfolding [sillyfun] in the above proof, we find that
    we are stuck on [if (eqb n 3) then ... else ...].  But either [n]
    is equal to [3] or it isn't, so we can use [destruct (eqb n 3)] to
    let us reason about the two cases.

    Informally, we might read the proof above like so:

    We want to show that for any number n, [sillyfun n = false].  Let
    a number [n] be given.  Observe that [sillyfun] is defined so that
    when [eqb n 3 = true] the result is false, when [eqb n 5 = true]
    the result is false, and if both are false then the result is
    [false].  We handle each case in turn.

    First, suppose that [eqb n 3 = true].  Then we hit the first
    branch of [sillyfun] and return false, and [false = false] is
    immediate.

    Second, suppose that [eqb n 5 = true].  Then we hit the second
    branch of [sillyfun] and likewise return false.

    Finally, suppose that neither of those cases hold.  Then
    [sillyfun] also returns false and the same reasoning holds. *)

(** In general, the [destruct] tactic can be used to perform case
    analysis of the results of arbitrary computations.  If [e] is an
    expression whose type is some inductively defined type [T], then,
    for each constructor [c] of [T], [destruct e] generates a subgoal
    in which all occurrences of [e] (in the goal and in the context)
    are replaced by [c]. *)

(** More practically, we can use these case analyses to reason about
    the complex decisions made in programs.  As a rule of thumb, you
    will need this trick whenever you are stuck on a [match] or an
    [if] which depends on the result of some function call rather than
    some ready-to-hand value.

    Here's a function that computes the minimum of three
    arguments. First, let's make sure we have a good [leb] defined. *)

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

Definition min3 (n1 n2 n3 : nat) : nat :=
  if leb n1 n2
  then if leb n1 n3
       then n1
       else n3
  else if leb n2 n3
       then n2
       else n3.

Definition argmin3 {A:Type} (cost : A -> nat) (o1 o2 o3 : A) : A :=
  let c1 := cost o1 in
  let c2 := cost o2 in
  let c3 := cost o3 in
  if leb c1 c2
  then if leb c1 c3
       then o1
       else o3
  else if leb c2 c3
       then o2
       else o3.

(** **** Exercise: 2 stars, standard (argmin3_min3_eqs)

    Relate [min3] to [argmin3]. Your proof will need to navigate why
    [argmin3] should go one direction or another by using [destruct]
    with a compound term relevant to the decision-making process of
    [arg3min]. *)
Lemma argmin3_min3_eqs : forall {A:Type} (cost : A -> nat) (o1 o2 o3 : A) (n1 n2 n3 : nat),
    cost o1 = n1 ->
    cost o2 = n2 ->
    cost o3 = n3 ->
    cost (argmin3 cost o1 o2 o3) = min3 n1 n2 n3.
Proof.
  intros A cost o1 o2 o3 n1 n2 n3 H1 H2 H3.
  unfold argmin3.
  unfold min3.
  rewrite H1.
  rewrite H2.
  rewrite H3.
  destruct( leb n1 n2).
  -destruct (leb n1 n3).
   + apply H1.
   + apply H3.
  -destruct (leb n2 n3).
   + apply H2.
   + apply H3.
Qed.

(** To prove this one, you should be able to just use [argmin3_min3_eqs]. *)
Corollary argmin3_min3 : forall {A:Type} (cost : A -> nat) (o1 o2 o3 : A),
    cost (argmin3 cost o1 o2 o3) = min3 (cost o1) (cost o2) (cost o3).
Proof.
  intros A cost o1 o2 o3. apply argmin3_min3_eqs.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.
(** [] *)

(** However, [destruct]ing compound expressions requires a bit of
    care, as such [destruct]s can sometimes erase information we need
    to complete a proof.

    For example, suppose we define a function [sillyfun1] like
    this: *)

Definition sillyfun1 (n : nat) : bool :=
  if eqb n 3 then true
  else if eqb n 5 then true
       else false.

(** Now suppose that we want to convince Coq of the (rather
    obvious) fact that [sillyfun1 n] yields [true] only when [n] is
    odd.  By analogy with the proofs we did with [sillyfun] above, it
    is natural to start the proof like this: *)

Theorem sillyfun1_odd_FAILED : forall (n : nat),
    (forall n m, eqb n m = true -> n = m) ->
    sillyfun1 n = true ->
    oddb n = true.
Proof.
  intros n eqb_true eq. unfold sillyfun1 in eq.
  destruct (eqb n 3).
  (* stuck... *)
Abort.

(** We get stuck at this point because the context does not
    contain enough information to prove the goal!  The problem is that
    the substitution performed by [destruct] is too brutal -- it threw
    away every occurrence of [eqb n 3], but we need to keep some
    memory of this expression and how it was destructed, because we
    need to be able to reason that, since [eqb n 3 = true] in this
    branch of the case analysis, it must be that [n = 3], from which
    it follows that [n] is odd.

    What we would really like is to substitute away all existing
    occurences of [eqb n 3], but at the same time add an equation to
    the context that records which case we are in.  Recall that the
    [eqn:] qualifier allows us to introduce such an equation, giving
    it a name that we choose. *)

Theorem sillyfun1_odd : forall (n : nat),
    (forall n m, eqb n m = true -> n = m) ->
    sillyfun1 n = true ->
    oddb n = true.
Proof.
  (* Let n be given, and assume that for all n and m, if [eqb n m =
  true] then [n = m].  Also assume [sillyfun1 n = true].  *)
  intros n eqb_true eq. unfold sillyfun1 in eq.
  (* "Observe that [eqb n 3] is either true or false." *)
  destruct (eqb n 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got
     stuck above, except that the context contains an extra equality
     assumption, which is exactly what we need to make progress. *)
  - (* e3 = true *) apply eqb_true in Heqe3.
    (* If it is true, then we know that [n = 3] by our earlier assumption. *)
    rewrite -> Heqe3. reflexivity.
  - (* e3 = false *)
    (* Otherwise, [eqb n 5] is also either true or false. *)
    (* When we come to the second equality test in the body of
       the function we are reasoning about, we can use [eqn:] again in
       the same way, allow us to finish the proof. *)
    destruct (eqb n 5) eqn:Heqe5.
    + (* e5 = true *)
      (* If it is true, then we know [n = 5]. *)
      apply eqb_true in Heqe5.
      rewrite -> Heqe5. reflexivity.
    + (* e5 = false *)
      (* If [n] is neither 3 nor 5, [sillyfun1] could not possibly
         have returned true, so we have a contradiction in our
         assumptions. *)
      discriminate eq.  Qed.

(* 2021-10-04 14:37 *)


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.Ztestbit.
Require Import Crypto.Util.ZUtil.Testbit.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z_scope.

Module Z.
  Lemma pow2_mod_spec : forall a b, (0 <= b) -> Z.pow2_mod a b = a mod (2 ^ b).
  Proof.
    intros.
    unfold Z.pow2_mod.
    rewrite Z.land_ones; auto.
  Qed.
  Hint Rewrite <- Z.pow2_mod_spec using zutil_arith : convert_to_Ztestbit.

  Lemma pow2_mod_0_r : forall a, Z.pow2_mod a 0 = 0.
  Proof.
    intros; rewrite Z.pow2_mod_spec, Z.mod_1_r; reflexivity.
  Qed.

  Lemma pow2_mod_0_l : forall n, 0 <= n -> Z.pow2_mod 0 n = 0.
  Proof.
    intros; rewrite Z.pow2_mod_spec, Z.mod_0_l; try reflexivity; try apply Z.pow_nonzero; omega.
  Qed.

  Lemma pow2_mod_split : forall a n m, 0 <= n -> 0 <= m ->
                                       Z.pow2_mod a (n + m) = Z.lor (Z.pow2_mod a n) ((Z.pow2_mod (a >> n) m) << n).
  Proof.
    intros; cbv [Z.pow2_mod].
    apply Z.bits_inj'; intros.
    repeat progress (try break_match; autorewrite with Ztestbit zsimplify; try reflexivity).
    try match goal with H : ?a < ?b |- context[Z.testbit _ (?a - ?b)] =>
      rewrite !Z.testbit_neg_r with (n := a - b) by omega end.
    autorewrite with Ztestbit; reflexivity.
  Qed.

  Lemma pow2_mod_pow2_mod : forall a n m, 0 <= n -> 0 <= m ->
                                          Z.pow2_mod (Z.pow2_mod a n) m = Z.pow2_mod a (Z.min n m).
  Proof.
    intros; cbv [Z.pow2_mod].
    apply Z.bits_inj'; intros.
    apply Z.min_case_strong; intros; repeat progress (try break_match; autorewrite with Ztestbit zsimplify; try reflexivity).
  Qed.

  Lemma pow2_mod_pos_bound a b : 0 < b -> 0 <= Z.pow2_mod a b < 2^b.
  Proof.
    intros; rewrite Z.pow2_mod_spec by omega.
    auto with zarith.
  Qed.
  Hint Resolve pow2_mod_pos_bound : zarith.
End Z.


Module Nat.

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

Notation "1" := (S O).

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

Inductive Vector : Nat -> Type :=
  | vnil  : Vector O
  | vcons : forall n, Nat -> Vector n -> Vector (S n).

Fixpoint
  is_odd (n:Nat) : bool :=
    match n with
    | O    => false
    | S n' => is_even n'
    end
with
  is_even (n:Nat) : bool :=
    match n with
    | O    => true
    | S n' => is_odd n'
    end.

Lemma succ_pred_0 : forall n, n <> O -> S (pred n) = n.
Proof.
  intros n.
  unfold not.
  destruct n as [|n'].
    (* n = O *)
    intros O_neq_O.
    case (O_neq_O (eq_refl : O = O) : False).
    (* n = S n' *)
    intros H. simpl. reflexivity.
Qed.

Lemma succ_pred : forall n, S (pred (S n)) = S n.
Proof.
  intros n. simpl. reflexivity.
Qed.

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

Notation "m + n" := (add m n).

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

Notation "m * n" := (mult m n).

Lemma add_id_right : forall n, n + O = n.
Proof.
  intro n.
  induction n.
    (* base case: O *)
    simpl. reflexivity.
    (* inductive: S n *)
    simpl. rewrite IHn. reflexivity.
Qed.

Lemma succ_add_one : forall n, n + 1 = S n.
Proof.
  intros n.
  induction n as [|n'].
    simpl. reflexivity.
    simpl. rewrite IHn'. reflexivity.
Qed.

Lemma succ_associative_right : forall n m, S (n + m) = n + S m.
Proof.
  intros n m.
  induction n as [|n'].
    (* base case: n = O *)
    simpl. reflexivity.
    (* inductive: n = S n' *)
    simpl. rewrite IHn'. reflexivity.
Qed.

Lemma succ_associative_left : forall n m, S (n + m) = S n + m.
Proof.
  intros n m.
  induction n as [|n'].
    (* base case: n = O *)
    simpl. reflexivity.
    (* inductive: n = S n' *)
    simpl. rewrite IHn'. reflexivity.
Qed.

Lemma add_commutative : forall n m, n + m = m + n.
Proof.
  intros n m.
  induction n as [|n'].
    (* base case: n = O *)
    simpl. rewrite add_id_right. reflexivity.
    (* inductive: n = S n' *)
    simpl. rewrite IHn'. rewrite succ_associative_right. reflexivity.
Qed.

Lemma add_associative : forall n m o, (n + m) + o = n + (m + o).
Proof.
  intros n m o.
  induction n. induction m. induction o.
    simpl. reflexivity.
    simpl. reflexivity.
    simpl. reflexivity.
    simpl. rewrite IHn. reflexivity.
Qed.

Lemma mult_zero_right : forall n, n * O = O.
Proof.
  intro n.
  induction n.
    (* base case: O *)
    simpl. reflexivity.
    (* induction step: S n *)
    simpl. rewrite IHn. destruct n as [|n].
      simpl. reflexivity.
      simpl. reflexivity.
Qed.

Lemma mult_unit_right : forall n, n * 1 = n.
Proof.
  intro n.
  induction n.
    (* base case: O *)
    simpl. reflexivity.
    (* induction step: S n *)
    simpl. rewrite IHn. destruct n as [|n].
      simpl. reflexivity.
      simpl. reflexivity.
Qed.

Inductive Le (n n':Nat) : Type :=
  | le_b   : S n = n' -> Le n n'
  | le_r   : Le n (pred n') -> Le n n'.

Inductive Leeq (n n':Nat) : Type :=
  | leeq_b : n = n -> Leeq n n'
  | leeq_r : Leeq n (pred n') -> Leeq n n'.

Inductive Gr (n n':Nat) : Type :=
  | gr_b   : n = S n' -> Gr n n'
  | gr_r   : Gr n (S n') -> Gr n n'.

Inductive Greq (n n':Nat) : Type :=
  | greq_b : n = n' -> Greq n n'
  | greq_r : Greq n (S n') -> Greq n n'.

Notation "m <  n" := (Le   m n).
Notation "m <= n" := (Leeq m n).
Notation "m >  n" := (Gr   m n).
Notation "m >= n" := (Greq m n).

Lemma le_transitive : forall m n o, m < n -> n < o -> m < o.
Proof.
  intros m n o.
  intros m_le_n n_le_o.
  induction m.
    induction n.
      induction o.
        discriminate.

Lemma helper : forall n, S n <= pred (S (S n)).
Proof.
  intros n. simpl. exact (leeq_b (S n) (S n) eq_refl).
Qed.

Lemma leeq_succ : forall n, n <= S n.
Proof.
  intro n.
  induction n.
    exact (leeq_r O 1 (leeq_b O O eq_refl)).
    exact (leeq_r (S n) (S (S n)) (helper n)).
Qed.

Lemma leeq_succ_S : forall m n, m <= n -> m <= S n.
Proof.
  intros m n m_leeq_n.

Lemma lower_bound_O : forall n, O <= n.
Proof.
  induction n.
    exact (leeq_b O O eq_refl).
    destruct n.
    exact (leeq_succ O). exact (leeq_succ

Lemma add_leeq : forall m n, m <= n -> S m <= S n.
Proof.
  intros m n m_leeq_n.
  induction m.
    induction n.
      exact (leeq_b 1 1 eq_refl).
      exact (IHn ())


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) : natural :=
  plus Zero (mult (Succ y) (Succ x)).


Require Import ProofCheckingEuclid.euclidean_axioms.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_congruencesymmetric :
	forall A B C D,
	Cong A B C D ->
	Cong C D A B.
Proof.
	intros A B C D.
	intros Cong_AB_CD.
	assert (Cong A B A B) as Cong_AB_AB by (apply cn_congruencereflexive).
	pose proof (cn_congruencetransitive _ _ _ _ _ _ Cong_AB_CD Cong_AB_AB) as Cong_CD_AB.
	exact Cong_CD_AB.
Qed.

End Euclid.


(*
  Church Number in Coq.
*)

Definition apply3 {X : Type} (f : X -> X) (n : X) : X :=
  f (f (f n)).

Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition czero : cnat := fun (X : Type) (_ : X -> X) (x : X) => x.
Definition cone  : cnat := fun (X : Type) (f : X -> X) (x : X) => f x.
Definition ctwo  : cnat := fun _ f x => f (f x).
Definition cthree : cnat := @apply3.
(* Definition cthree       := fun _ f x => f (f (f x)).*)

Definition cadd (c1 c2 : cnat) : cnat := fun _ f x => c1 _ f (c2 _ f x).
Compute (cadd cone ctwo).

Definition cmul (c1 c2 : cnat) : cnat := fun _ f x => c1 _ (c2 _ f) x.
Compute (cmul (cadd cone ctwo) ctwo) _ S O.

Definition cpow (c1 c2 : cnat) : cnat := fun _ f x => (c2 _ (c1 _) f) x.
Compute (cpow ctwo cthree) _ S O.

(*
Definition cadd (c1 c2 : cnat) : cnat := fun f x => (c1 f (c2 f x)).
Compute (cadd cone ctwo) nat S O.
*)


Require Import Basics.Aux.
Require Import Basics.Identifier.
Require Import Languages.LC.Syntax.
Require Import Languages.LC.Semantics.

(* Variables. *)
Definition A := Identifier 0.
Definition B := Identifier 1.

Definition F := Identifier 2.
Definition G := Identifier 3.
Definition H := Identifier 4.

Definition M := Identifier 5.
Definition N := Identifier 6.

Definition P := Identifier 7.
Definition Q := Identifier 8.

Definition T := Identifier 9.
Definition U := Identifier 10.

Definition X := Identifier 11.
Definition Y := Identifier 12.
Definition Z := Identifier 13.

(* Church numerals. *)
Fixpoint natToChurch_aux (n:nat): exp :=
  match n with
  | O    => X
  | S n' => EApp F $ natToChurch_aux n'
  end.
Definition natToChurch (n:nat) :=
  EAbs F $ EAbs X $ natToChurch_aux n.

Definition zero  := natToChurch 0.
Definition one   := natToChurch 1.
Definition two   := natToChurch 2.
Definition three := natToChurch 3.

(* Church numeral arithmetic. *)
Definition add := EAbs M $ EAbs N $ EAbs F $ EAbs X $
  EApp (EApp M F) $ EApp (EApp N F) X.
Definition add' (m n:exp) :=
  EApp (EApp add m) n.

Definition succ := EAbs N $ EAbs F $ EAbs X $
  EApp F $ EApp (EApp N F) X.
Definition succ' (n:exp) :=
  EApp succ n.

Definition pred := EAbs N $ EAbs F $ EAbs X $
  EApp
    (EApp
      (EApp N $ EAbs G $ EAbs H $ EApp H (EApp G F))
      (EAbs U X))
    (EAbs U U).
Definition pred' (n:exp) :=
  EApp pred n.

Definition sub := EAbs M $ EAbs N $
  EApp (EApp N pred) M.
Definition sub' (m n:exp) :=
  EApp (EApp sub m) n.

(* Church predicates. *)
Definition true  := EAbs A $ EAbs B A.
Definition false := EAbs A $ EAbs B B.

Definition and := EAbs P $ EAbs Q $
  EApp (EApp P Q) P.
Definition and' (p q:exp) :=
  EApp (EApp and p) q.

Definition isZero := EAbs N $
  EApp (EApp N $ EAbs X false) true.
Definition isZero' (n:exp) :=
  EApp isZero n.

Definition leq := EAbs M $ EAbs N $
  isZero' $ sub' M N.
Definition leq' (m n:exp) :=
  EApp (EApp leq m) n.

Definition eq := EAbs M $ EAbs N $
  and' (leq' M N) (leq' N M).
Definition eq' (m n:exp) :=
  EApp (EApp eq m) n.

Definition ite := EAbs P $ EAbs A $ EAbs B $
  EApp (EApp P A) B.
Definition ite' (p a b:exp) :=
  EApp (EApp (EApp ite p) a) b.

(* Church pairs. *)
Definition pair := EAbs X $ EAbs Y $ EAbs Z $
  EApp (EApp Z X) Y.
Definition pair' (x y: exp) :=
  EApp (EApp pair x) y.

Definition fst := EAbs P $
  EApp P (EAbs X $ EAbs Y X).
Definition fst' (p:exp) :=
  EApp fst p.

Definition snd := EAbs P $
  EApp P (EAbs X $ EAbs Y Y).
Definition snd' (p:exp) :=
  EApp snd p.

(* Church lists. *)
Definition nil :=
  pair' true true.

Definition isNil :=
  fst.

Definition cons := EAbs H $ EAbs T $
  pair' false (pair' H T).
Definition cons' (h t:exp) :=
  EApp (EApp cons h) t.

Definition head := EAbs Z $
  fst' (snd' Z).
Definition head' (z:exp) :=
  EApp head z.

Definition tail := EAbs Z $
  snd' (snd' Z).
Definition tail' (z:exp) :=
  EApp tail z.

(* Auxiliary Church functions. *)
Definition listFromNToM_aux := EAbs F $ EAbs N $ EAbs M $
  ite' (leq' N M)
    (cons' N $ EApp (EApp F $ succ' N) M)
     nil.
Definition listFromNToM :=
  EApp listFromNToM_aux listFromNToM_aux.
Definition listFromNToM' (n m:exp) :=
  EApp (EApp listFromNToM n) m.

Definition sumFromNToM_aux := EAbs F $ EAbs N $ EAbs M $
  ite' (leq' N M)
    (add' N $ EApp (EApp F $ succ' N) M)
     zero.
Definition sumFromNToM :=
  EApp sumFromNToM_aux sumFromNToM_aux.
Definition sumFromNToM' (n m:exp) :=
  EApp (EApp sumFromNToM n) m.


Require Import nat.
Require Import inductive_prop.

Definition some_nat_is_even : ex ev := ex_intro ev 0 ev_0.
Definition some_nat_is_even': ex ev := ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
    ex_intro (fun n => ev (S n)) 1 (ev_SS 0 ev_0).


Inductive pos : Set :=
| SO : pos
| S : pos -> pos.

Fixpoint plus(n m:pos) : pos :=
  match n with
    | SO => S m
    | S p => S (p + m)
  end
    where "n + m" := (plus n m).

Infix "+" := plus.

Theorem plus_assoc : forall n m p, n + (m + p) = (n + m) + p.
Proof.
  intros.
  induction n.
  reflexivity.
  simpl.
  f_equal.
  assumption.
Qed.


Theorem first_proof: (forall A : Prop, A -> A).
Proof.
        intros A.
        intros proof_of_A.
        exact proof_of_A.
Qed.

Theorem forward_small : (forall A B : Prop, A -> (A->B) -> B).
Proof.
        intros A.
        intros B.
        intros proof_of_A.
        intros A_implies_B.
        pose (proof_of_B := A_implies_B proof_of_A).
        exact proof_of_B.
Qed.

Theorem backward_small : (forall A B : Prop, A -> (A->B)->B).
Proof.
        intros A B.
        intros proof_of_A A_implies_B.
       refine (A_implies_B _).
                exact proof_of_A.
Qed.

Theorem backward_large : (forall A B C : Prop, A -> (A -> B) -> (B -> C) -> C).
Proof.
        intros A B C.
        intros proof_of_A A_implies_B B_implies_C.
        refine (B_implies_C _).
                refine (A_implies_B _ ).
                        exact proof_of_A.
Qed.

Theorem backward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
                intros A B C.
                intros proof_of_A A_implies_B A_imp_B_imp_C.
                refine (A_imp_B_imp_C _ _).
                        exact proof_of_A.
                        refine (A_implies_B _).
                                exact proof_of_A.
Qed.

Theorem forward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
        intros A B C.
        intros proof_of_A A_implies_B A_imp_B_imp_C.
        pose (proof_of_B := A_implies_B proof_of_A).
        pose (proof_of_c := A_imp_B_imp_C proof_of_A proof_of_B).
        exact proof_of_c.
Show Proof.
Qed.


(*
Author: Lukasz Czajka

This file is in the public domain (no copyright).
*)

(* This is a readable Coq formalisation of two variants of
Diaconescu's theorem.

1. Predicate extensionality and the relativised axiom of choice
   together imply the excluded middle axiom.

2. Predicate extensionality and the axiom of choice together imply the
   excluded middle axiom.

The formalisation is based on the paper: N. Goodman, J. Myhill,
"Choice implies excluded middle", Zeitschrift für mathematische Logik
und Grundlagen der Mathematik 24:461 (1978)
 *)

(************************************************************************************)
(* Definitions *)

Definition AxiomOfChoice := forall (A B : Type) (R : A -> B -> Prop),
    (forall x : A, exists y : B, R x y) -> exists f : A -> B, forall x : A, R x (f x).

Definition RelativisedAxiomOfChoice :=
  forall (A B : Type) (Q : A -> Prop) (R : A -> B -> Prop),
    (forall x : A, Q x -> exists y : B, R x y) ->
    exists f : A -> B, forall x : A, Q x -> R x (f x).

Definition ExcludedMiddle := forall P : Prop, P \/ ~P.

Definition ProofIrrelevance := forall (P : Prop) (p q : P), p = q.

Definition PredicateExtensionality := forall (A : Type) (R1 R2 : A -> Prop),
    (forall x : A, R1 x <-> R2 x) -> R1 = R2.

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

(************************************************************************************)
(* Diaconescu's theorem from relativised choice and predicate extensionality        *)

Theorem pre_diaconescu_rel :
  RelativisedAxiomOfChoice -> forall A (a b : A), a = b \/ a <> b.
Proof.
  unfold RelativisedAxiomOfChoice.
  intros Hc.
  intros A a b.
  pose (Q := fun x : A => x = a \/ x = b).
  pose (R := fun (x : A) (y : bool) => (x = a /\ y = true) \/ (x = b /\ y = false)).
  assert (H : exists f : A -> bool, forall x : A, Q x -> R x (f x)).
  { apply Hc.
    unfold Q, R.
    intros x H.
    destruct H; eauto. }
  destruct H as [f H].
  unfold Q, R in H.
  generalize (H a).
  generalize (H b).
  intros Ha Hb.
  destruct Ha as [[? Ha]|[? Ha]]; auto.
  destruct Hb as [[? Hb]|[? Hb]]; auto.
  right.
  intro.
  subst.
  rewrite Ha in Hb.
  discriminate Hb.
Qed.

Theorem diaconescu_rel :
  PredicateExtensionality -> RelativisedAxiomOfChoice -> ExcludedMiddle.
Proof.
  unfold PredicateExtensionality, RelativisedAxiomOfChoice, ExcludedMiddle.
  intros He Hc P.
  pose (U := fun x => x = true \/ P).
  pose (V := fun x => x = false \/ P).
  assert (H: U = V \/ U <> V) by auto using pre_diaconescu_rel.
  destruct H as [H|H].
  - left.
    assert (Heq: U false = V false) by congruence.
    unfold U, V in Heq.
    enough (H1: false = true \/ P) by
        (destruct H1 as [H1|?]; [ discriminate H1 | auto ]).
    rewrite Heq.
    auto.
  - right.
    intro HP.
    apply H.
    apply He.
    intro x.
    unfold U, V.
    split; auto.
Qed.

(************************************************************************************)
(* Diaconescu's theorem (non-relativised version) *)

Theorem pre_diaconescu : ProofIrrelevance -> AxiomOfChoice -> forall A (a b : A), a = b \/ a <> b.
Proof.
  unfold ProofIrrelevance, AxiomOfChoice.
  intros Hi Hc.
  intros A a b.
  pose (A' := {x : A | x = a \/ x = b}).
  pose (R := fun (x : A') (y : bool) => (proj1_sig x = a /\ y = true) \/ (proj1_sig x = b /\ y = false)).
  assert (H : exists f : A' -> bool, forall x : A', R x (f x)).
  { apply Hc.
    unfold R.
    intro x.
    destruct x as [x H].
    simpl.
    destruct H; subst; eauto. }
  destruct H as [f H].
  unfold R in H.
  generalize (H ltac:(unfold A'; exists a; auto)).
  generalize (H ltac:(unfold A'; exists b; auto)).
  simpl.
  intros Ha Hb.
  destruct Ha as [[? Ha]|[? Ha]]; auto.
  destruct Hb as [[? Hb]|[? Hb]]; auto.
  right.
  intro; subst.
  assert (He: or_introl eq_refl = or_intror eq_refl :> (b = b \/ b = b)) by auto.
  rewrite He in Hb.
  rewrite Hb in Ha.
  discriminate Ha.
Qed.

Lemma lem_pred_to_prop : PredicateExtensionality -> PropositionalExtensionality.
Proof.
  unfold PredicateExtensionality, PropositionalExtensionality.
  intros H P Q H1.
  generalize (H bool (fun _ => P) (fun _ => Q)).
  intro H2.
  generalize (H2 (fun _ => H1)).
  intro H3.
  change ((fun _ => P) true = (fun _ => Q) true).
  rewrite H3.
  reflexivity.
Qed.

Lemma lem_prop_to_irrelev : PropositionalExtensionality -> ProofIrrelevance.
Proof.
  unfold PropositionalExtensionality, ProofIrrelevance.
  intros H P p q.
  unfold iff in H.
  assert (H1: P = True) by auto.
  subst.
  destruct p, q.
  reflexivity.
Qed.

Theorem diaconescu : PredicateExtensionality -> AxiomOfChoice -> ExcludedMiddle.
Proof.
  unfold PredicateExtensionality, AxiomOfChoice, ExcludedMiddle.
  intros He Hc P.
  pose (U := fun x => x = true \/ P).
  pose (V := fun x => x = false \/ P).
  assert (H: U = V \/ U <> V) by
      eauto using pre_diaconescu, lem_pred_to_prop, lem_prop_to_irrelev.
  destruct H as [H|H].
  - assert (Heq: U false = V false) by congruence.
    unfold U, V in Heq.
    enough (HH: false = true \/ P)
      by (destruct HH; [ easy | auto ]).
    rewrite Heq.
    auto.
  - enough (~P) by auto.
    intro H1.
    apply H.
    apply He.
    unfold U, V.
    tauto.
Qed.


(* Four different ways of proving the same theorem: evenb (double x 0) = true. *)

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

(* double: computes 2x using an accumulator *)
Fixpoint double (x y : nat) : nat :=
  match x with
    | O => y
    | S x' => double x' (S (S y))
  end.

Theorem even_double_1 : forall x:nat,
  evenb (double x 0) = true.
Proof.
  (* METHOD 1: PE with loop detection (automatic) *)
  intros.

  (* initial *)
  induction x.
  reflexivity.

  (* recursive case *)
  simpl.                        (* unable to use IHx *)
  induction x.
  reflexivity.

  (* back to the recursive case *)
  simpl.

  (* Now we know this is going to go on forever, we find that the only
  thing that is changing is the second argument to double (y). It
  changes from y to (S (S y)) at every iteration. *)

  assert (forall x y : nat,
    evenb (double x y) = evenb (double x (S (S y)))).
  induction x0.
  reflexivity.
  intros.
  apply IHx1.
  rewrite <- H.
  apply IHx.
  (* Done *)
Qed.

(* METHOD 2: use lemma even_ss extracted from METHOD 1 *)
Lemma even_ss :
  forall x y : nat,
    evenb (double x y) = evenb (double x (S (S y))).
Proof.
  induction x.
  reflexivity.

  intros y.
  simpl. apply IHx.
Qed.

Theorem even_double_2 :
  forall x : nat,
    evenb (double x 0) = true.
Proof.
  intros.
  induction x.
  reflexivity.
  simpl.
  rewrite <- even_ss.
  apply IHx.
Qed.

Lemma even_ss_b :
  forall x y : nat,
    evenb (double x y) = true -> evenb (double x (S (S y))) = true.
Proof.
  induction x.
  intros.
  simpl in *.
  apply H.

  simpl.
  intros y. apply IHx.
Qed.

Theorem even_double_2b :
  forall x : nat,
    evenb (double x 0) = true.
Proof.
  intros.
  induction x.
  reflexivity.
  simpl.
  apply even_ss2.
  apply IHx.
Qed.

(* METHOD 3: use lemma even_y *)
Lemma even_y :
  forall x y : nat,
    evenb y = true -> evenb (double x y) = true.
Proof.
  (* METHOD 1: the dumb way *)
  induction x; intros; simpl.
  apply H.
  apply IHx.
  simpl.
  apply H.

  (* METHOD 2: use ; and auto *)
  Restart.
  induction x; simpl; auto.
Qed.

Theorem even_double_3 :
  forall x : nat,
    evenb (double x 0) = true.
Proof.
  intros.
  apply even_y.
  reflexivity.
Qed.

(* By Rebecca Swords *)
Lemma double_s :
  forall x y : nat,
    double (S x) y = S (S (double x y)).
Proof.
  intros x.
  induction x.
  reflexivity.

  intros y.
  simpl in *.
  apply IHx.
Qed.

Theorem even_double_4 :
  forall x : nat,
    evenb (double x 0) = true.
Proof.
  induction x.
  reflexivity.

  rewrite double_s.
  simpl.
  apply IHx.
Qed.

(* proof terms

METHOD 1:
---------------------------------------------------------------
even_double_1 =
fun x : nat =>
nat_ind (fun x0 : nat => evenb (double x0 0) = true) eq_refl
  (fun (x0 : nat) (IHx : evenb (double x0 0) = true) =>
   nat_ind
     (fun x1 : nat =>
      evenb (double x1 0) = true -> evenb (double x1 2) = true)
     (fun _ : evenb (double 0 0) = true => eq_refl)
     (fun (x1 : nat)
        (_ : evenb (double x1 0) = true -> evenb (double x1 2) = true)
        (IHx1 : evenb (double (S x1) 0) = true) =>
      (fun
         H : forall x2 y : nat,
             evenb (double x2 y) = evenb (double x2 (S (S y))) =>
       eq_ind (evenb (double x1 2)) (fun b : bool => b = true) IHx1
         (evenb (double x1 4)) (H x1 2))
        (fun x2 : nat =>
         nat_ind
           (fun x3 : nat =>
            forall y : nat, evenb (double x3 y) = evenb (double x3 (S (S y))))
           (fun y : nat => eq_refl)
           (fun (x3 : nat)
              (IHx2 : forall y : nat,
                      evenb (double x3 y) = evenb (double x3 (S (S y))))
              (y : nat) => IHx2 (S (S y))) x2)) x0 IHx) x
     : forall x : nat, evenb (double x 0) = true

METHOD 2:
-----------------------------------------------------
even_double_2 =
fun x : nat =>
nat_ind (fun x0 : nat => evenb (double x0 0) = true) eq_refl
  (fun (x0 : nat) (IHx : evenb (double x0 0) = true) =>
   eq_ind (evenb (double x0 0)) (fun b : bool => b = true) IHx
     (evenb (double x0 2)) (even_ss x0 0)) x
     : forall x : nat, evenb (double x 0) = true

even_ss =
fun x : nat =>
nat_ind
  (fun x0 : nat =>
   forall y : nat, evenb (double x0 y) = evenb (double x0 (S (S y))))
  (fun y : nat => eq_refl)
  (fun (x0 : nat)
     (IHx : forall y : nat, evenb (double x0 y) = evenb (double x0 (S (S y))))
     (y : nat) => IHx (S (S y))) x
     : forall x y : nat, evenb (double x y) = evenb (double x (S (S y)))

METHOD 3:
------------------------------------------------------
even_double_3 =
fun x : nat => even_y x 0 eq_refl
     : forall x : nat, evenb (double x 0) = true

even_y =
fun x : nat =>
nat_ind
  (fun x0 : nat =>
   forall y : nat, evenb y = true -> evenb (double x0 y) = true)
  (fun (y : nat) (H : evenb y = true) => H)
  (fun (x0 : nat)
     (IHx : forall y : nat, evenb y = true -> evenb (double x0 y) = true)
     (y : nat) (H : evenb y = true) => IHx (S (S y)) H) x
     : forall x y : nat, evenb y = true -> evenb (double x y) = true

*)


(* Theorems about basic logic and lists. *)

Require Import PeanoNat.
From larith Require Import A_setup.

(******************************************************************************)
(* I. Laws of constructive propositional and predicate logic.                 *)
(******************************************************************************)
Section Laws_of_logic.

Section Propositions.

Variable P Q : Prop.

Theorem contra :
  (P -> Q) -> (¬Q -> ¬P).
Proof.
auto.
Qed.

Theorem and_remove_r :
  Q -> P /\ Q <-> P.
Proof.
easy.
Qed.

Theorem or_remove_r :
  ¬Q -> P \/ Q <-> P.
Proof.
intros nQ; split; intros.
now destruct H. now left.
Qed.

Theorem exfalso_iff :
  ¬P -> ¬Q -> P <-> Q.
Proof.
easy.
Qed.

Variable P_dec : {P} + {¬P}.
Variable Q_dec : {Q} + {¬Q}.

Theorem not_dec :
  {¬P} + {¬¬P}.
Proof.
destruct P_dec; auto.
Defined.

End Propositions.

Section Predicates.

Variable X Y : Type.
Variable P Q : X -> Prop.

Theorem ex_iff :
  (∀x, P x <-> Q x) -> (∃x, P x) <-> (∃x, Q x).
Proof.
intros H; split; intros [x Hx]; exists x; apply H, Hx.
Qed.

End Predicates.

End Laws_of_logic.

(******************************************************************************)
(* II. Lists witnessing a transitive path.                                    *)
(******************************************************************************)
Section Reflexive_transitive_closure.

Variable X : Type.
Variable R : X -> X -> Prop.

Inductive RTC : list X -> Prop :=
  | RTC_nil : RTC []
  | RTC_refl x : RTC [x]
  | RTC_cons x y l : RTC (y :: l) -> R x y -> RTC (x :: y :: l).

Theorem RTC_weaken x l :
  RTC (x :: l) -> RTC l.
Proof.
destruct l; intros.
constructor. inv H.
Qed.

Theorem RTC_trans l1 l2 d :
  RTC l1 -> RTC (last l1 d :: l2) -> RTC (l1 ++ l2).
Proof.
induction l1; simpl; intros. inv H0.
destruct l1; subst; simpl in *. easy.
inv H; apply RTC_cons. apply IHl1; easy. easy.
Qed.

Theorem RTC_app_inv l1 l2 :
  RTC (l1 ++ l2) -> RTC l1 /\ RTC l2.
Proof.
induction l1; simpl; intros.
split; [apply RTC_nil|easy]. inv H.
- apply eq_sym, app_eq_nil in H2 as [H1 H2]; subst.
  split; [apply RTC_refl|apply RTC_nil].
- rewrite H1 in H2; apply IHl1 in H2. split; [|easy].
  destruct l1; [apply RTC_refl|inv H1; apply RTC_cons; easy].
Qed.

End Reflexive_transitive_closure.

Arguments RTC {_}.

(******************************************************************************)
(* III. Various list utilities.                                               *)
(******************************************************************************)
Module ListUtils.

Theorem cons_app {X} (x : X) l :
  x :: l = [x] ++ l.
Proof.
easy.
Qed.

Theorem list_singleton {X} (l : list X) :
  length l = 1 -> ∃x, l = [x].
Proof.
intros. destruct l. easy. destruct l.
now exists x. easy.
Qed.

Theorem last_cons {X} (x d : X) l :
  last (x :: l) d = last l x.
Proof.
revert x d; induction l; simpl; intros.
easy. destruct l. easy. apply IHl.
Qed.

Theorem last_app {X} (x d : X) l1 l2 :
  last (l1 ++ x :: l2) d = last l2 x.
Proof.
revert d; induction l1; intros.
rewrite app_nil_l; apply last_cons.
rewrite <-app_comm_cons, last_cons; apply IHl1.
Qed.

Theorem split_list {X} (x : X) l :
  In x l -> ∃l1 l2, l = l1 ++ x :: l2.
Proof.
induction l; intros. easy. inv H.
- exists [], l; easy.
- apply IHl in H0 as [l1 [l2 H]].
  exists (a :: l1), l2; simpl; rewrite H; easy.
Qed.

Theorem Forall_incl {X} P (l l' : list X) :
  (∀x, In x l -> In x l') -> Forall P l' -> Forall P l.
Proof.
intros; apply Forall_forall; intros.
apply Forall_forall with (x:=x) in H0; auto.
Qed.

Notation lmax l := (fold_right max 0 l).

Theorem lmax_in n l :
  In n l -> n <= lmax l.
Proof.
induction l; simpl. easy.
intros [H|H]; subst. apply Nat.le_max_l.
apply Nat.max_le_iff; right; apply IHl, H.
Qed.

Section Forall2.

Section Type_agnostic.

Variable X Y Z : Type.
Variable R S : X -> Y -> Prop.

Theorem Forall2_eq (l l' : list X) :
  Forall2 eq l l' <-> l = l'.
Proof.
revert l'; induction l; destruct l'; try easy.
split; intros H; inv H. apply IHl in H5; now subst.
apply Forall2_cons, IHl; easy.
Qed.

Theorem Forall2_impl xs ys :
  Forall2 R xs ys -> (∀x y, R x y -> S x y) -> Forall2 S xs ys.
Proof.
intros HR HRS; induction HR. apply Forall2_nil.
apply Forall2_cons. apply HRS, H. apply IHHR.
Qed.

Theorem Forall2_map (f : Z -> Y) xs zs :
  Forall2 R xs (map f zs) <-> Forall2 (λ x z, R x (f z)) xs zs.
Proof.
revert zs; induction xs; destruct zs; simpl; intros; try easy.
split; intros H; inv H. all: apply Forall2_cons; [easy|now apply IHxs].
Qed.

End Type_agnostic.

Corollary Forall2_In_singleton {X} (l l' : list X) :
  Forall2 (@In _) l (map (λ x, [x]) l') <-> l = l'.
Proof.
rewrite Forall2_map, <-Forall2_eq. split; intros.
all: eapply Forall2_impl; [apply H|].
all: intros; simpl in *. inv H0. now left.
Qed.

End Forall2.

Section Mapping.

Variable X Y : Type.
Variable f : X -> Y.

Theorem map_map_singleton l :
  map (λ x, [f x]) l = map (λ y, [y]) (map f l).
Proof.
now rewrite map_map.
Qed.

Theorem flat_map_singleton l :
  flat_map (λ x, [f x]) l = map f l.
Proof.
induction l; simpl.
easy. now rewrite IHl.
Qed.

Theorem nth_map i l d x :
  nth i l d = x -> nth i (map f l) (f d) = f x.
Proof.
revert i; induction l; destruct i; simpl.
1-3: congruence. apply IHl.
Qed.

Hypothesis f_inj : ∀x x', f x = f x' -> x = x'.

Theorem nth_map_inj i l d x :
  nth i (map f l) (f d) = f x -> nth i l d = x.
Proof.
revert i; induction l; destruct i; simpl.
1-3: apply f_inj. apply IHl.
Qed.

End Mapping.

Section Double_mapping.

Variable X Y Z : Type.
Variable f : X -> Y -> Z.

Fixpoint map2 xs ys :=
  match xs, ys with
  | x :: xs', y :: ys' => f x y :: map2 xs' ys'
  | _, _ => []
  end.

End Double_mapping.

Section Strip_option_list.

Variable X : Type.

Fixpoint strip (l : list (option X)) :=
  match l with
  | [] => []
  | None :: l' => strip l'
  | Some x :: l' => x :: strip l'
  end.

Theorem strip_map_id l :
  strip (map Some l) = l.
Proof.
induction l; simpl.
easy. now rewrite IHl.
Qed.

Theorem strip_app l l' :
  strip (l ++ l') = strip l ++ strip l'.
Proof.
induction l as [|[x|] l]; simpl. easy.
now rewrite IHl. apply IHl.
Qed.

End Strip_option_list.

Section List_constructions_using_decidability.

Variable X : Type.
Hypothesis dec : ∀x y : X, {x = y} + {x ≠ y}.

Theorem split_at_last_instance (x : X) l :
  In x l -> ∃l1 l2, l = l1 ++ x :: l2 /\ ¬In x l2.
Proof.
induction l; intros. easy. inv H.
destruct (in_dec dec x l) as [H0|H0].
1,3: apply IHl in H0 as [l1 [l2 []]]; rewrite H.
1: exists (x :: l1), l2. 2: exists (a :: l1), l2. 3: exists [], l. all: easy.
Qed.

Section Filtering.

Variable P : X -> Prop.
Hypothesis P_dec : ∀x, {P x} + {¬P x}.

Fixpoint pfilter (l : list X) :=
  match l with
  | [] => []
  | x :: l' => if P_dec x then x :: pfilter l' else pfilter l'
  end.

Theorem pfilter_spec l x :
  In x (pfilter l) <-> In x l /\ P x.
Proof.
induction l; simpl. easy.
destruct (P_dec a); simpl; split; intros.
all: try split; repeat destruct H; subst.
all: try apply IHl in H; try easy; auto.
now right. right; apply IHl; easy. now right. now apply IHl.
Qed.

Theorem pfilter_length l :
  length (pfilter l) <= length l.
Proof.
induction l; simpl. easy.
destruct (P_dec a); simpl.
apply le_n_S, IHl. apply le_S, IHl.
Qed.

End Filtering.

Section Intersection_and_subtraction.

Section Definition_using_pfilter.

Variable l s : list X.

Definition intersect :=
  pfilter (λ x, In x s) (λ x, in_dec dec x s) l.

Definition subtract :=
  pfilter (λ x, ¬In x s) (λ x, not_dec _ (in_dec dec x s)) l.

Corollary intersect_spec x :
  In x intersect <-> In x l /\ In x s.
Proof.
apply pfilter_spec.
Qed.

Corollary subtract_spec x :
  In x subtract <-> In x l /\ ¬In x s.
Proof.
apply pfilter_spec.
Qed.

Theorem subtract_length :
  length subtract = length l - length intersect.
Proof.
unfold subtract, intersect; induction l; simpl pfilter. easy.
destruct (in_dec _), (not_dec _ _); try easy.
simpl length; rewrite IHl0; clear IHl0. remember (pfilter _ _ l0) as l1.
assert(length l1 <= length l0) by (subst; apply pfilter_length).
rewrite <-Nat.sub_succ_l. reflexivity. easy.
Qed.

Corollary intersect_length :
  length intersect = length l - length subtract.
Proof.
rewrite subtract_length.
assert(length intersect <= length l) by apply pfilter_length.
symmetry; apply Nat.add_sub_eq_l, Nat.sub_add, H.
Qed.

End Definition_using_pfilter.

Theorem subtract_length_le_cons_r x a b :
  length (subtract a (x :: b)) <= length (subtract a b).
Proof.
induction a; simpl. easy.
destruct (dec _), (in_dec _); simpl.
2: apply le_S. 4: apply le_n_S. all: apply IHa.
Qed.

Theorem length_subtract_le_incl_r a b c :
  (∀x, In x b -> In x c) ->
  length (subtract a c) <= length (subtract a b).
Proof.
induction a; simpl; intros. easy.
destruct (in_dec _), (in_dec _); simpl.
2: apply le_S. 4: apply le_n_S.
3: exfalso; apply n, H, i. all: apply IHa, H.
Qed.

Theorem subtract_length_lt_cons_r x a b :
  In x a -> ¬In x b ->
  length (subtract a (x :: b)) < length (subtract a b).
Proof.
induction a; simpl; intros. easy.
destruct H, (dec _), (in_dec _); subst; simpl; try easy.
apply Nat.lt_succ_r, subtract_length_le_cons_r.
1: apply Nat.lt_lt_succ_r. 3: apply Nat.lt_succ_r.
all: apply IHa; easy.
Qed.

End Intersection_and_subtraction.

End List_constructions_using_decidability.

Arguments map2 {_ _ _}.
Arguments strip {_}.
Arguments pfilter {_}.
Arguments intersect {_}.
Arguments subtract {_}.

End ListUtils.
Export ListUtils.


From HoTT Require Import Spaces.Pos Spaces.Int.
From HoTT Require Import Basics Types.
From HoTT Require Import Spaces.Circle.

Local Open Scope int_scope.

Context `{Univalence}.

(*
Here we defined the function helix from https://dl.acm.org/doi/abs/10.1145/3372885.3373825
In the HoTT book this is called code (Def. 8.1.1.)
 *)

Definition helix : Circle -> Set
  := Circle_rec Set Int (path_universe int_succ).

(*
If we input loop^n to winding, we get n. So it counts, how much we go around the circle.
*)

Definition winding (p : (base = base)): Int
  := transport helix p (zero).

(*
the function winding number does not compute, if you check the following proofs you will get an error
*)

Definition winding_at_3 : winding (loopexp loop 3) = 3.
Proof.
reflexivity.
Abort.

Definition winding_at_m1 : winding (loop^ @ loop @ loop^) = -1.
Proof.
reflexivity.
Abort.

(*
In the following we use two theorems from https://github.com/HoTT/Coq-HoTT/blob/master/theories/Spaces/Circle.v
to actually proof winding_at_3 and winding_at_m1
*)

Theorem transport_helix_loopV (z : Int)
    : transport helix loop^ z = int_pred z.
Proof.
    refine (transport_compose idmap helix loop^ z @ _).
    rewrite ap_V.
    unfold helix; rewrite Circle_rec_beta_loop.
    rewrite <- (path_universe_V int_succ).
    apply transport_path_universe.
Qed.

Theorem Circle_encode_loopexp (z:Int)
    : Circle_encode base (loopexp loop z) = z.
Proof.
    destruct z as [n | | n]; unfold Circle_encode.
    - induction n using pos_peano_ind; simpl in *.
      + refine (moveR_transport_V _ loop _ _ _).
        by symmetry; apply transport_Circle_code_loop.
      + unfold loopexp_pos.
        rewrite pos_peano_ind_beta_pos_succ.
        rewrite transport_pp.
        refine (moveR_transport_V _ loop _ _ _).
        refine (_ @ (transport_Circle_code_loop _)^).
        refine (IHn @ _^).
        rewrite int_neg_pos_succ.
        by rewrite int_succ_pred.
    - reflexivity.
    - induction n using pos_peano_ind; simpl in *.
      + by apply transport_Circle_code_loop.
      + unfold loopexp_pos.
        rewrite pos_peano_ind_beta_pos_succ.
        rewrite transport_pp.
        refine (moveR_transport_p _ loop _ _ _).
        refine (_ @ (transport_Circle_code_loopV _)^).
        refine (IHn @ _^).
        rewrite <- pos_add_1_r.
        change (int_pred (int_succ (pos n)) = pos n).
        apply int_pred_succ.
Qed.

Theorem p: Circle_encode base (loopexp loop 3) = transport helix (loopexp loop 3) 0.
Proof.
reflexivity.
Qed.

(*
Now we can proof, that winding actually computes the way we proposed.
*)

Definition winding_at_3  : winding (loopexp loop 3) = 3.
Proof.
unfold winding.
rewrite <- p.
rewrite Circle_encode_loopexp.
reflexivity.
Qed.

Definition winding_at_m1 : winding (loop^ @ loop @ loop^) = -1.
Proof.
unfold winding.
rewrite concat_Vp.
rewrite concat_1p.
rewrite transport_helix_loopV.
reflexivity.
Qed.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint even (even_arg0 : Nat) : bool
           := match even_arg0 with
              | zero => true
              | succ n => negb (even n)
              end.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : Nat
           := match len_arg0 with
              | nil => zero
              | cons x y => succ (len y)
              end.

Lemma lem: forall l1 l2 n, negb (even (len (append l1 l2))) = even (len (append l1 (cons n l2))).
Proof.
induction l1.
  - intros. simpl. rewrite (IHl1 l2 n0). reflexivity.
  - intros. simpl. reflexivity.
Qed.

Lemma lem3: forall l, append l nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (even (len (append x y))) (even (len (append y x))).
Proof.
induction x.
  - intros. simpl. rewrite <- lem. f_equal. rewrite IHx. reflexivity.
  - intros. simpl. rewrite lem3. reflexivity.
Qed.


(* Require Export Ring. *)
Set Implicit Arguments.
Section mat.                                (* matrices. *)
  Variables (A:Type)
            (zero one : A)
            (plus mult minus : A -> A -> A)
            (sym : A -> A).
  Notation "0" := zero.  Notation "1" := one.
  Notation "x + y" := (plus x y).
  Notation "x * y " := (mult x y).

  Structure M2 : Type := {c00 : A;  c01 : A;
                          c10 : A;  c11 : A}.

  Definition Zero2 : M2 := Build_M2 0 0 0 0.
  Definition Id2 : M2 := Build_M2  1 0 0 1.

  Definition M2_mult (m m':M2) : M2 :=
    Build_M2 (c00 m * c00 m' + c01 m * c10 m')
             (c00 m * c01 m' + c01 m * c11 m')
             (c10 m * c00 m' + c11 m * c10 m')
             (c10 m * c01 m' + c11 m * c11 m').

  Definition M2_plus (m m' : M2) : M2 :=
    @Build_M2 (c00 m + c00 m')
              (c01 m + c01 m')
              (c10 m + c10 m')
              (c11 m + c11 m').

  Lemma M2_eq_intros :
    forall m m':M2, c00 m = c00 m' ->
                    c01 m = c01 m' ->
                    c10 m = c10 m' ->
                    c11 m = c11 m' -> m = m'.
    destruct m;destruct m';simpl.
    intros H H1 H2 H3;rewrite H ,H1, H2, H3;trivial.
  Qed.
End mat.                                    (* matrices. *)


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

Definition not(x:bool):bool:=
match x with
|true => false
|false => true
end.

Definition and(x y : bool):bool:=
match x with
|true => y
|false => false
end.

Definition nand(x y : bool):bool:=
match x with
|true => not y
|false => true
end.

Definition or(x y : bool):bool:=
match x with
|true => true
|false => y
end.

Definition nor(x y : bool):bool:=
match x with
|true => false
|false => not y
end.

Theorem not_not: forall x:bool, not(not x) = x.
Proof.
intros.
destruct x.
simpl. reflexivity.
simpl. reflexivity.
Qed.

Example ex1 : (nor true false) = false.
Proof.
intros.
simpl. reflexivity.
Qed.


Require Import Arith Omega String.

Inductive exp : Set :=
| Var : string -> exp
| Const : nat -> exp
| Plus : exp -> exp -> exp
| Times : exp -> exp -> exp.

Fixpoint eval (e : exp) (f : string -> nat) : nat :=
  match e with
    | Var x => f x
    | Const n => n
    | Plus e1 e2 => eval e1 f + eval e2 f
    | Times e1 e2 => eval e1 f * eval e2 f
  end.

Fixpoint cfold (e : exp) : exp :=
  match e with
    | Var x => Var x
    | Const n => Const n
    | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
        | Const n1, Const n2 => Const (n1 + n2)
        | Const 0, _ => e2'
        | _, Const 0 => e1'
        | _,  _ => Plus e1' e2'
      end
    | Times e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
        | Const n1, Const n2 => Const (n1 * n2)
        | Const 1, _ => e2'
        | _, Const 1 => e1'
        | Const 0, _ => Const 0
        | _, Const 0 => Const 0
        | _,  _ => Times e1' e2'
      end
  end.

Fixpoint cfold' (e : exp) : exp :=
  match e with
    | Var x => Var x
    | Const n => Const n
    | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
        | Const n1, Const n2 => Const (n1 + n2)
        | Const 0, _ => e2'
        | _, Const 0 => e1'
        | _,  _ => Plus e1' e2'
      end
    | Times e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
        | Const n1, Const n2 => Const (n1 * n2)
        | Const 1, _ => e2'
        | _, Const 1 => e1'
        | Const 0, _ => Const 0
        | _, Const 0 => Const 0
        | _,  _ => Times e1' e2'
      end
  end.

Hint Extern 1 (_ = _) => omega.

Theorem cfold_ok : forall f e, eval (cfold e) f = eval e f.
Proof.
  induction e; simpl; intuition;
  repeat match goal with
           | [ |- context[match ?E with _ => _ end] ] =>
             destruct E; simpl in *; subst; auto
         end.
Qed.