(** * ProofObjects: The Curry-Howard Correspondence *)

(** "_Algorithms are the computational content of proofs_."  --Robert Harper *)

Require Export IndProp.

(** We have seen that Coq has mechanisms both for _programming_,
    using inductive data types like [nat] or [list] and functions over
    these types, and for _proving_ properties of these programs, using
    inductive propositions (like [ev]), implication, universal
    quantification, and the like.  So far, we have mostly treated
    these mechanisms as if they were quite separate, and for many
    purposes this is a good way to think.  But we have also seen hints
    that Coq's programming and proving facilities are closely related.
    For example, the keyword [Inductive] is used to declare both data
    types and propositions, and [->] is used both to describe the type
    of functions on data and logical implication.  This is not just a
    syntactic accident!  In fact, programs and proofs in Coq are
    almost the same thing.  In this chapter we will study how this
    works.

    We have already seen the fundamental idea: provability in Coq is
    represented by concrete _evidence_.  When we construct the proof
    of a basic proposition, we are actually building a tree of
    evidence, which can be thought of as a data structure.

    If the proposition is an implication like [A -> B], then its proof
    will be an evidence _transformer_: a recipe for converting
    evidence for A into evidence for B.  So at a fundamental level,
    proofs are simply programs that manipulate evidence. *)

(** Question: If evidence is data, what are propositions themselves?

    Answer: They are types!

    Look again at the formal definition of the [ev] property.  *)

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

(** Suppose we introduce an alternative pronunciation of "[:]".
    Instead of "has type," we can say "is a proof of."  For example,
    the second line in the definition of [ev] declares that [ev_0 : ev
    0].  Instead of "[ev_0] has type [ev 0]," we can say that "[ev_0]
    is a proof of [ev 0]." *)

(** This pun between types and propositions -- between [:] as "has type"
    and [:] as "is a proof of" or "is evidence for" -- is called the
    _Curry-Howard correspondence_.  It proposes a deep connection
    between the world of logic and the world of computation:

                 propositions  ~  types
                 proofs        ~  data values

    See [Wadler 2015] for a brief history and an up-to-date exposition.

    Many useful insights follow from this connection.  To begin with,
    it gives us a natural interpretation of the type of the [ev_SS]
    constructor: *)

Check ev_SS.
(* ===> ev_SS : forall n,
                  ev n ->
                  ev (S (S n)) *)

(** This can be read "[ev_SS] is a constructor that takes two
    arguments -- a number [n] and evidence for the proposition [ev
    n] -- and yields evidence for the proposition [ev (S (S n))]." *)

(** Now let's look again at a previous proof involving [ev]. *)

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

(** As with ordinary data values and functions, we can use the [Print]
    command to see the _proof object_ that results from this proof
    script. *)

Print ev_4.
(* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0)
     : ev 4  *)

(** As a matter of fact, we can also write down this proof object
    _directly_, without the need for a separate proof script: *)

Check (ev_SS 2 (ev_SS 0 ev_0)).
(* ===> ev 4 *)

(** The expression [ev_SS 2 (ev_SS 0 ev_0)] can be thought of as
    instantiating the parameterized constructor [ev_SS] with the
    specific arguments [2] and [0] plus the corresponding proof
    objects for its premises [ev 2] and [ev 0].  Alternatively, we can
    think of [ev_SS] as a primitive "evidence constructor" that, when
    applied to a particular number, wants to be further applied to
    evidence that that number is even; its type,

      forall n, ev n -> ev (S (S n)),

    expresses this functionality, in the same way that the polymorphic
    type [forall X, list X] expresses the fact that the constructor
    [nil] can be thought of as a function from types to empty lists
    with elements of that type. *)

(** You may recall (as seen in the [Logic] chapter) that we can
    use function application syntax to instantiate universally
    quantified variables in lemmas, as well as to supply evidence for
    assumptions that these lemmas impose. For instance: *)

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

(** We can now see that this feature is a trivial consequence of the
    status the Coq grants to proofs and propositions: Lemmas and
    hypotheses can be combined in expressions (i.e., proof objects)
    according to the same basic rules used for programs in the
    language. *)

(* ################################################################# *)
(** * Proof Scripts *)

(** The _proof objects_ we've been discussing lie at the core of how
    Coq operates.  When Coq is following a proof script, what is
    happening internally is that it is gradually constructing a proof
    object -- a term whose type is the proposition being proved.  The
    tactics between [Proof] and [Qed] tell it how to build up a term
    of the required type.  To see this process in action, let's use
    the [Show Proof] command to display the current state of the proof
    tree at various points in the following tactic proof. *)

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

(** At any given moment, Coq has constructed a term with some
    "holes" (indicated by [?1], [?2], and so on), and it knows what
    type of evidence is needed at each hole.  *)

(** Each of the holes corresponds to a subgoal, and the proof is
    finished when there are no more subgoals.  At this point, the
    evidence we've built stored in the global context under the name
    given in the [Theorem] command. *)

(** Tactic proofs are useful and convenient, but they are not
    essential: in principle, we can always construct the required
    evidence by hand, as shown above. Then we can use [Definition]
    (rather than [Theorem]) to give a global name directly to a
    piece of evidence. *)

Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

(** All these different ways of building the proof lead to exactly the
    same evidence being saved in the global environment. *)

Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)

(** **** Exercise: 1 star (eight_is_even)  *)
(** Give a tactic proof and a proof object showing that [ev 8]. *)

Theorem ev_8 : ev 8.
Proof.
  (* FILL IN HERE *) Admitted.

Definition ev_8' : ev 8
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.
(** [] *)

(* ################################################################# *)
(** * Quantifiers, Implications, Functions *)

(** In Coq's computational universe (where data structures and
    programs live), there are two sorts of values with arrows in their
    types: _constructors_ introduced by [Inductive]-ly defined data
    types, and _functions_.

    Similarly, in Coq's logical universe (where we carry out proofs),
    there are two ways of giving evidence for an implication:
    constructors introduced by [Inductive]-ly defined propositions,
    and... functions!

    For example, consider this statement: *)

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

(** What is the proof object corresponding to [ev_plus4]?

    We're looking for an expression whose _type_ is [forall n, ev n ->
    ev (4 + n)] -- that is, a _function_ that takes two arguments (one
    number and a piece of evidence) and returns a piece of evidence!
    Here it is: *)

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4'.
(* ===> ev_plus4' : forall n : nat, ev n -> ev (4 + n) *)

(** Recall that [fun n => blah] means "the function that, given [n],
    yields [blah]," and that Coq treats [4 + n] and [S (S (S (S n)))]
    as synonyms. Another equivalent way to write this definition is: *)

Definition ev_plus4'' (n : nat) (H : ev n) : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.
(* ===> ev_plus4'' : forall n : nat, ev n -> ev (4 + n) *)

(** When we view the proposition being proved by [ev_plus4] as a
    function type, one aspect of it may seem a little unusual. The
    second argument's type, [ev n], mentions the _value_ of the first
    argument, [n].  While such _dependent types_ are not found in
    conventional programming languages, they can be useful in
    programming too, as recent work in the functional programming
    community demonstrates.

    Notice that both implication ([->]) and quantification ([forall])
    correspond to functions on evidence.  In fact, they are really the
    same thing: [->] is just a shorthand for a degenerate use of
    [forall] where there is no dependency, i.e., no need to give a
    name to the type on the LHS of the arrow. *)

(** For example, consider this proposition: *)

Definition ev_plus2 : Prop :=
  forall n, forall (E : ev n), ev (n + 2).

(** A proof term inhabiting this proposition would be a function
    with two arguments: a number [n] and some evidence [E] that [n] is
    even.  But the name [E] for this evidence is not used in the rest
    of the statement of [ev_plus2], so it's a bit silly to bother
    making up a name for it.  We could write it like this instead,
    using the dummy identifier [_] in place of a real name: *)

Definition ev_plus2' : Prop :=
  forall n, forall (_ : ev n), ev (n + 2).

(** Or, equivalently, we can write it in more familiar notation: *)

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n + 2).

(** In general, "[P -> Q]" is just syntactic sugar for
    "[forall (_:P), Q]". *)

(* ################################################################# *)
(** * Connectives as Inductive Types *)

(** Inductive definitions are powerful enough to express most of the
    connectives and quantifiers we have seen so far.  Indeed, only
    universal quantification (and thus implication) is built into Coq;
    all the others are defined inductively.  We study these
    definitions in this section. *)

Module Props.

(** ** Conjunction

    To prove that [P /\ Q] holds, we must present evidence for both
    [P] and [Q].  Thus, it makes sense to define a proof object for [P
    /\ Q] as consisting of a pair of two proofs: one for [P] and
    another one for [Q]. This leads to the following definition. *)

Module And.

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

End And.

(** Notice the similarity with the definition of the [prod] type,
    given in chapter [Poly]; the only difference is that [prod] takes
    [Type] arguments, whereas [and] takes [Prop] arguments. *)

Print prod.
(* ===>
   Inductive prod (X Y : Type) : Type :=
   | pair : X -> Y -> X * Y. *)

(** This should clarify why [destruct] and [intros] patterns can be
    used on a conjunctive hypothesis.  Case analysis allows us to
    consider all possible ways in which [P /\ Q] was proved -- here
    just one (the [conj] constructor).  Similarly, the [split] tactic
    actually works for any inductively defined proposition with only
    one constructor.  In particular, it works for [and]: *)

Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
Qed.

(** This shows why the inductive definition of [and] can be
    manipulated by tactics as we've been doing.  We can also use it to
    build proofs directly, using pattern-matching.  For instance: *)

Definition and_comm'_aux P Q (H : P /\ Q) :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(** **** Exercise: 2 stars, optional (conj_fact)  *)
(** Construct a proof object demonstrating the following proposition. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.
(** [] *)

(** ** Disjunction

    The inductive definition of disjunction uses two constructors, one
    for each side of the disjunct: *)

Module Or.

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

End Or.

(** This declaration explains the behavior of the [destruct] tactic on
    a disjunctive hypothesis, since the generated subgoals match the
    shape of the [or_introl] and [or_intror] constructors.

    Once again, we can also directly write proof objects for theorems
    involving [or], without resorting to tactics. *)

(** **** Exercise: 2 stars, optional (or_commut'')  *)
(** Try to write down an explicit proof object for [or_commut] (without
    using [Print] to peek at the ones we already defined!). *)

Definition or_comm : forall P Q, P \/ Q -> Q \/ P
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.
(** [] *)

(** ** Existential Quantification

    To give evidence for an existential quantifier, we package a
    witness [x] together with a proof that [x] satisfies the property
    [P]: *)

Module Ex.

Inductive ex {A : Type} (P : A -> Prop) : Prop :=
| ex_intro : forall x : A, P x -> ex P.

End Ex.

(** This may benefit from a little unpacking.  The core definition is
    for a type former [ex] that can be used to build propositions of
    the form [ex P], where [P] itself is a _function_ from witness
    values in the type [A] to propositions.  The [ex_intro]
    constructor then offers a way of constructing evidence for [ex P],
    given a witness [x] and a proof of [P x].

    The more familiar form [exists x, P x] desugars to an expression
    involving [ex]: *)

Check ex (fun n => ev n).
(* ===> exists n : nat, ev n
        : Prop *)

(** Here's how to define an explicit proof object involving [ex]: *)

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(** **** Exercise: 2 stars, optional (ex_ev_Sn)  *)
(** Complete the definition of the following proof object: *)

Definition ex_ev_Sn : ex (fun n => ev (S n))
  (* REPLACE THIS LINE WITH   := _your_definition_ . *) . Admitted.
(** [] *)

(* ================================================================= *)
(** ** [True] and [False] *)

(** The inductive definition of the [True] proposition is simple: *)

Inductive True : Prop :=
  I : True.

(** It has one constructor (so every proof of [True] is the same, so
    being given a proof of [True] is not informative.) *)

(** [False] is equally simple -- indeed, so simple it may look
    syntactically wrong at first glance! *)

Inductive False : Prop :=.

(** That is, [False] is an inductive type with _no_ constructors --
    i.e., no way to build evidence for it. *)

End Props.

(* ################################################################# *)
(** * Programming with Tactics *)

(** If we can build proofs by giving explicit terms rather than
    executing tactic scripts, you may be wondering whether we can
    build _programs_ using _tactics_ rather than explicit terms.
    Naturally, the answer is yes! *)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Compute add1 2.
(* ==> 3 : nat *)

(** Notice that we terminate the [Definition] with a [.] rather than
    with [:=] followed by a term.  This tells Coq to enter _proof
    scripting mode_ to build an object of type [nat -> nat].  Also, we
    terminate the proof with [Defined] rather than [Qed]; this makes
    the definition _transparent_ so that it can be used in computation
    like a normally-defined function.  ([Qed]-defined objects are
    opaque during computation.)

    This feature is mainly useful for writing functions with dependent
    types, which we won't explore much further in this book.  But it
    does illustrate the uniformity and orthogonality of the basic
    ideas in Coq. *)

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

(** Even Coq's equality relation is not built in.  It has the
    following inductive definition.  (Actually, the definition in the
    standard library is a small variant of this, which gives an
    induction principle that is slightly easier to use.) *)

Module MyEquality.

Inductive eq {X:Type} : X -> X -> Prop :=
| eq_refl : forall x, eq x x.

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

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

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

Lemma leibniz_equality : forall (X : Type) (x y: X),
  x = y -> forall P:X->Prop, P x -> P y.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

    In tactic-based proofs of equality, the conversion rules are
    normally hidden in uses of [simpl] (either explicit or implicit in
    other tactics such as [reflexivity]).  But you can see them
    directly at work in the following explicit proof objects: *)

Definition four' : 2 + 2 = 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X:Set) (x:X), []++[x] = x::[]  :=
  fun (X:Set) (x:X) => eq_refl [x].

End MyEquality.

Definition quiz6 : exists x,  x + 3 = 4
  := ex_intro (fun z => (z + 3 = 4)) 1 (refl_equal 4).

(* ================================================================= *)
(** ** Inversion, Again *)

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

    In general, the [inversion] tactic...

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

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

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

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

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

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

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

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

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

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

(** $Date: 2016-07-14 17:02:35 -0400 (Thu, 14 Jul 2016) $ *)


Require Import Arith.

Fixpoint le_bool (n m: nat) {struct n}: bool :=
  match n, m with
  | O, _ => true
  | S n1, S m1 => le_bool n1 m1
  | _, _ => false
  end.

Theorem le_correct: forall n m, le_bool n m = true -> n <= m.
Proof. now induction n; destruct m; auto with arith. Qed.

Fixpoint lt_bool (n m: nat) {struct n}: bool :=
  match n, m with
  | O, S _ => true
  | S n1, S m1 => lt_bool n1 m1
  | _, _ => false
  end.

Theorem lt_correct: forall n m, lt_bool n m = true -> n <= m.
Proof. now induction n; destruct m; auto with arith. Qed.

Global Hint Extern 4 (?X1 <= ?X2)%nat =>
   exact (le_correct X1 X2 (refl_equal true)) : core.
Global Hint Extern 4 (?X1 < ?X2)%nat =>
   exact (lt_correct X1 X2 (refl_equal true)) : core.


Lemma silly_implication : (1 + 1) = 2 -> 0 * 3 = 0.
Proof. intros H. simpl. reflexivity. Qed.

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

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

Theorem and_example : (0 = 0) /\ (4 = mult 2 2).
Proof.

apply conj.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem proj1 : forall P Q : Prop, P /\ Q -> P.
Proof.
intros.
destruct H.
apply H.
Qed.

Theorem proj2 : forall P Q : Prop, P /\ Q -> Q.
Proof.
intros.
destruct H.
apply H0.
Qed.

Theorem and_commut : forall P Q : Prop, P /\ Q -> Q /\ P.
Proof.
intros.
split.
destruct H.
apply H0.
destruct H.
apply H.
Qed.

Theorem and_assoc : forall P Q R : Prop, P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
intros.
split.
destruct H.
split.
apply H.
destruct H0.
apply H0.
destruct H as [H1 H2].
destruct H2.
apply H0.
Qed.

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

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

Theorem iff_implies : forall P Q : Prop, (P <-> Q) -> P -> Q.
Proof.
intros P Q H.
destruct H.
apply H.
Qed.

Theorem iff_sym : forall P Q : Prop, (P <-> Q) -> (Q <-> P).
Proof.
intros.
destruct H.
split.
apply H0.
apply H.
Qed.

Theorem iff_refl : forall P : Prop, P <-> P.
Proof.
intros.
split.
intros H1.
apply H1.
intros H2.
apply H2.
Qed.

Theorem conj_trans : forall P Q R : Prop, P /\ Q -> Q /\ R -> P /\ R.
Proof.
intros.
split.
destruct H.
apply H.
destruct H0.
apply H1.
Qed.

Theorem iff_trans : forall P Q R : Prop, (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
intros P Q R HEPQ HEQR.
inversion  HEPQ as [HPQ HQP].
inversion HEQR as [HQR HRQ].
split.
intros HP.
apply HQR.
apply HPQ.
apply HP.
intros HR.
apply HQP.
apply HRQ.
apply HR.
Qed.

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

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

Theorem or_commut : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
intros.
destruct H as [H1 | H2].
apply or_intror.
apply H1.
apply or_introl.
apply H2.
Qed.

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

Theorem or_distributes_over_and_2 : forall P Q R : Prop, (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
intros P Q R H.
inversion H as [HPQ HPR].
inversion HPQ as [ HP | HQ ].
left.
apply HP.
inversion HPR as [HP | HR].
left.
apply HP.
right.
apply conj.
apply HQ.
apply HR.
Qed.

Theorem or_distributes_over_and : forall P Q R : Prop, P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
split.
apply or_distributes_over_and_1.
apply or_distributes_over_and_2.
Qed.

Theorem andb_prop : forall b c, andb b c = true -> b = true /\ c = true.
Proof.
intros b c H.
destruct b.
destruct c.
apply conj. reflexivity. reflexivity.
inversion H.
inversion H.
Qed.

Theorem andb_true_intro : forall b c, b = true /\ c = true -> andb b c = true.
Proof.
intros b c H.
destruct b.
destruct c.
simpl.
reflexivity.
simpl.
inversion H.
apply H1.
destruct c.
simpl.
inversion H.
apply H0.
simpl.
inversion H.
apply H0.
Qed.

Theorem andb_false : forall b c, andb b c = false -> b = false \/ c = false.
Proof.
intros b c H.
destruct b. destruct c.
left.
inversion H.
right.
reflexivity.
left.
reflexivity.
Qed.

Theorem orb_prop : forall b c, orb b c = true -> b = true \/ c = true.
Proof.
intros b c H.
destruct b.
left.
reflexivity.
destruct c.
right.
reflexivity.
simpl.
left.
apply H.
Qed.

Theorem orb_false_elim : forall b c, orb b c = false -> b = false /\ c = false.
Proof.
intros b c H.
destruct b.
split.
apply H.
destruct c.
apply H.
reflexivity.
split.
reflexivity.
destruct c.
apply H.
reflexivity.
Qed.

Inductive False : Prop := .

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

Theorem contradiction_implies_anything : forall P Q : Prop, (P /\ ~P) -> Q.
Proof.
intros.
destruct H.
unfold not in H0.
apply H0 in H.
inversion H.
Qed.

Theorem double_neg : forall P : Prop, P -> ~~P.
Proof.
intros.
unfold not.
intros.
apply H0 in H.
apply H.
Qed.

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

Theorem peirce : forall P Q: Prop,
  ((P -> Q) -> P) -> P.
intros.
apply H.

Theorem first_eq : forall P Q : Prop, ((P -> Q) -> P) -> P -> ~~P -> P.
Proof.
intros.
apply H0.
Qed.

Theorem excluded_middle_irrefutable: forall (P:Prop), ~~(P \/ ~ P).
Proof.
unfold not.
intros P f.
apply f.
right.
intro p.
apply f.
left.
apply p.
Defined.


Require Import List.
Import ListNotations.

Require Import injective.
Require Import incl.

Definition injective_on_list (v w:Type) (l:list v) (f:v -> w) : Prop :=
    forall (x y:v), In x l -> In y l -> f x = f y -> x = y.

Arguments injective_on_list {v} {w} _ _.

Lemma inj_is_inj_on_list : forall (v w:Type) (l:list v) (f:v-> w),
    injective f -> injective_on_list l f.
Proof.
    intros v w l f H. intros x y Hx Hy H'. apply H. assumption.
Qed.

Lemma injective_on_list_appl : forall (v w:Type) (l1 l2:list v) (f:v -> w),
    injective_on_list (l1 ++ l2) f -> injective_on_list l1 f.
Proof.
    intros v w l1 l2 f H x y Hx Hy H'.
    apply H; simpl.
    - apply in_or_app. left. assumption.
    - apply in_or_app. left. assumption.
    - assumption.
Qed.

Lemma injective_on_list_appr : forall (v w:Type) (l1 l2:list v) (f:v -> w),
    injective_on_list (l1 ++ l2) f -> injective_on_list l2 f.
Proof.
    intros v w l1 l2 f H x y Hx Hy H'.
    apply H; simpl.
    - apply in_or_app. right. assumption.
    - apply in_or_app. right. assumption.
    - assumption.
Qed.

Lemma injective_on_list_cons : forall (v w:Type) (a:v) (l:list v) (f:v -> w),
    injective_on_list (a :: l) f -> injective_on_list l f.
Proof.
    intros v w a l f H x y Hx Hy H'.
    apply H; simpl.
    - right. assumption.
    - right. assumption.
    - assumption.
Qed.

Lemma injective_incl : forall (v w:Type) (l l':list v) (f:v -> w),
    incl l l' -> injective_on_list l' f -> injective_on_list l f.
Proof.
    intros v w l l' f H0 H1 x y Hx Hy H. apply H1.
    - apply H0. assumption.
    - apply H0. assumption.
    - assumption.
Qed.

Lemma injective_not_in : forall (v w:Type) (f:v -> w),
    forall (x:v) (l:list v),
    injective_on_list (x :: l) f ->
    ~In x l ->
    ~In (f x) (map f l).
Proof.
    intros v w f x l. revert x.
    induction l as [|a l IH]; simpl; intros x H.
    - intros H0 H1. assumption.
    - intros Hp [Hq|Hq].
        { apply Hp. left. apply H.
            { right. left. reflexivity. }
            { left. reflexivity. }
            { assumption. }
        }
        { revert Hq. apply IH.
            { apply injective_incl with (x :: a :: l).
                { apply incl_cons2. apply incl_tl. apply incl_refl. }
                { assumption. }
            }
            { intros H'. apply Hp. right. assumption. }
        }
Qed.


(** This file contains several basic logical theorems such as De Morgan's laws.
*)

Require Export base_logic.

Ltac exfalso := elimtype False.

Theorem contrapositive : ∀ {A B : Prop}, (A → B) → (¬B → ¬A).
Proof.
    intros A B H b a.
    specialize (H a).
    contradiction (b H).
Qed.

Ltac contrapositive H := revert H; apply contrapositive.

Theorem not_not : ∀ P, (¬¬P) ↔ P.
Proof.
    intro P.
    split; intro PH.
    -   classic_case P as [PH'|PH'].
        +   exact PH'.
        +   contradiction (PH PH').
    -   intro PH'.
        contradiction (PH' PH).
Qed.
Ltac classic_contradiction_prop H := apply (land (not_not _)); intros H.

Theorem contrapositive_iff : ∀ {A B : Prop}, (A → B) ↔ (¬B → ¬A).
Proof.
    intros A B.
    split; [>apply contrapositive|].
    rewrite <- (not_not A) at 2.
    rewrite <- (not_not B) at 2.
    apply contrapositive.
Qed.

Theorem not_impl : ∀ A B : Prop, (¬(A → B)) ↔ (A ∧ ¬B).
Proof.
    intros A B.
    split.
    -   intros n.
        classic_case B as [BH|nBH].
        +   assert (A → B) by (intro; exact BH).
            contradiction.
        +   split; [>|exact nBH].
            classic_case A as [AH|nAH]; [>exact AH|].
            exfalso.
            apply n.
            intro; contradiction.
    -   intros [a b] ab.
        specialize (ab a).
        contradiction.
Qed.
Theorem not_and : ∀ A B, (¬(A ∧ B)) ↔ (¬A ∨ ¬B).
Proof.
    intros A B.
    split.
    -   intros n.
        classic_case A as [AH|nAH].
        +   right.
            intros b.
            apply n.
            split; assumption.
        +   left; exact nAH.
    -   intros [na|nb] [a b]; contradiction.
Qed.
Theorem not_or : ∀ A B, (¬(A ∨ B)) ↔ (¬A ∧ ¬B).
Proof.
    intros A B.
    rewrite <- (not_not (¬A ∧ ¬B)).
    rewrite not_and.
    do 2 rewrite not_not.
    reflexivity.
Qed.
Theorem not_ex : ∀ {U} (P : U → Prop), (¬(∃ a, P a)) ↔ (∀ a, ¬P a).
Proof.
    intros U P.
    split.
    -   intros not_ex a Pa.
        apply not_ex.
        exists a.
        exact Pa.
    -   intros all [a Pa].
        specialize (all a).
        contradiction.
Qed.

Theorem not_all : ∀ {U} (P : U → Prop), (¬(∀ a, P a)) ↔ (∃ a, ¬P a).
Proof.
    intros U P.
    rewrite <- (not_not (∃ a, ¬P a)).
    rewrite not_ex.
    split.
    all: intros not_all all.
    all: apply not_all.
    all: intros a.
    -   rewrite <- not_not.
        apply all.
    -   rewrite not_not.
        apply all.
Qed.

Theorem not_and_impl : ∀ A B, (¬(A ∧ B)) ↔ (A → ¬B).
Proof.
    intros A B.
    rewrite <- (not_not (A → ¬B)).
    rewrite not_impl.
    rewrite not_not.
    reflexivity.
Qed.

Theorem and_assoc : ∀ A B C, A ∧ (B ∧ C) ↔ (A ∧ B) ∧ C.
Proof.
    intros A B C.
    split.
    -   intros [P1 [P2 P3]].
        split; [>split|]; assumption.
    -   intros [[P1 P2] P3].
        split; [>|split]; assumption.
Qed.

Theorem or_assoc : ∀ A B C, A ∨ (B ∨ C) ↔ (A ∨ B) ∨ C.
Proof.
    intros A B C.
    split.
    -   intros [P1|[P2|P3]].
        +   left; left; exact P1.
        +   left; right; exact P2.
        +   right; exact P3.
    -   intros [[P1|P2]|P3].
        +   left; exact P1.
        +   right; left; exact P2.
        +   right; right; exact P3.
Qed.

Theorem and_comm : ∀ A B, (A ∧ B) ↔ (B ∧ A).
Proof.
    intros A B.
    split.
    all: intros [P1 P2].
    all: split; assumption.
Qed.

Theorem or_comm : ∀ A B, (A ∨ B) ↔ (B ∨ A).
Proof.
    intros A B.
    split.
    all: intros [P1|P2].
    -   right; exact P1.
    -   left; exact P2.
    -   right; exact P1.
    -   left; exact P2.
Qed.

Theorem and_or_ldist : ∀ A B C, (A ∧ (B ∨ C)) ↔ ((A ∧ B) ∨ (A ∧ C)).
Proof.
    intros A B C.
    split.
    -   intros [PA [PB|PC]].
        +   left; split; assumption.
        +   right; split; assumption.
    -   intros [[PA PB]|[PA PC]].
        all: split; try assumption.
        +   left; exact PB.
        +   right; exact PC.
Qed.
Theorem and_or_rdist : ∀ A B C, ((A ∨ B) ∧ C) ↔ ((A ∧ C) ∨ (B ∧ C)).
Proof.
    intros A B C.
    do 3 rewrite (and_comm _ C).
    apply and_or_ldist.
Qed.

Theorem or_and_ldist : ∀ A B C, (A ∨ (B ∧ C)) ↔ ((A ∨ B) ∧ (A ∨ C)).
Proof.
    intros A B C.
    split.
    -   intros [PA|[PB PC]].
        +   split; left; exact PA.
        +   split; right; assumption.
    -   intros [[PA|PB] [PA2|PC]].
        all: try (left; assumption).
        right; split; assumption.
Qed.
Theorem or_and_rdist : ∀ A B C, ((A ∧ B) ∨ C) ↔ ((A ∨ C) ∧ (B ∨ C)).
Proof.
    intros A B C.
    do 3 rewrite (or_comm _ C).
    apply or_and_ldist.
Qed.

Theorem or_to_strong : ∀ P Q, P ∨ Q → {P} + {Q}.
Proof.
    intros P Q PQ.
    apply indefinite_description.
    destruct PQ as [PQ|PQ].
    -   split; left.
        exact PQ.
    -   split; right.
        exact PQ.
Qed.
Theorem or_from_strong : ∀ P Q, {P} + {Q} → P ∨ Q.
Proof.
    intros P Q [PQ|PQ].
    -   left; exact PQ.
    -   right; exact PQ.
Qed.

Theorem or_lfalse : ∀ P, False ∨ P ↔ P.
Proof.
    intros P.
    split.
    -   intros [H|H].
        +   contradiction H.
        +   exact H.
    -   intros H.
        right.
        exact H.
Qed.

Theorem or_rfalse : ∀ P, P ∨ False ↔ P.
Proof.
    intros P.
    rewrite or_comm.
    apply or_lfalse.
Qed.

Theorem or_ltrue : ∀ P, True ∨ P ↔ True.
Proof.
    intros P.
    split.
    -   intro; exact true.
    -   intros; left; exact true.
Qed.

Theorem or_rtrue : ∀ P, P ∨ True ↔ True.
Proof.
    intros P.
    rewrite or_comm.
    apply or_ltrue.
Qed.

Theorem and_lfalse : ∀ P, False ∧ P ↔ False.
Proof.
    intros P.
    split.
    -   intros [H PH].
        exact H.
    -   intros H.
        contradiction H.
Qed.

Theorem and_rfalse : ∀ P, P ∧ False ↔ False.
Proof.
    intros P.
    rewrite and_comm.
    apply and_lfalse.
Qed.

Theorem and_ltrue : ∀ P, True ∧ P ↔ P.
Proof.
    intros P.
    split.
    -   intros [H PH].
        exact PH.
    -   intros H.
        split.
        +   exact true.
        +   exact H.
Qed.

Theorem and_rtrue : ∀ P, P ∧ True ↔ P.
Proof.
    intros P.
    rewrite and_comm.
    apply and_ltrue.
Qed.

Theorem or_idemp : ∀ P, P ∨ P ↔ P.
Proof.
    intros P.
    split.
    -   intros [H|H]; exact H.
    -   intros H.
        left; exact H.
Qed.

Theorem and_idemp : ∀ P, P ∧ P ↔ P.
Proof.
    intros P.
    split.
    -   intros [H H'].
        exact H.
    -   intros H.
        split; exact H.
Qed.

Theorem or_both : ∀ P, (P ∨ ¬P) ↔ True.
Proof.
    intros P.
    split; [>intro; exact true|].
    intros I.
    apply em.
Qed.

Theorem and_both : ∀ P, (P ∧ ¬P) ↔ False.
Proof.
    intros P.
    split; [>|intro; contradiction].
    intros [H nH].
    contradiction.
Qed.

Theorem not_true : (¬True) = False.
Proof.
    apply propositional_ext; split.
    -   intro H; apply H; exact true.
    -   contradiction.
Qed.

Theorem not_false : (¬False) = True.
Proof.
    apply propositional_ext; split.
    -   intro H; exact true.
    -   intros H H2; contradiction.
Qed.

Theorem not_not_type : ∀ P : Type, ((P → False) → False) → P.
Proof.
    intros P Ps.
    assert (∃ p : P, True).
    {
        rewrite <- (not_not (∃ _ : P, True)).
        intros contr.
        rewrite not_ex in contr.
        rewrite not_true in contr.
        exact (Ps contr).
    }
    destruct (ex_to_type H) as [p pH].
    exact p.
Qed.
Ltac classic_contradiction H :=
    classic_contradiction_prop H ||
    (apply not_not_type; intros H).

Theorem prop_eq_true : ∀ P : Prop, P = (P = True).
Proof.
    intros P.
    apply propositional_ext; split.
    -   intro p.
        apply propositional_ext; split; trivial.
    -   intros P_eq.
        rewrite P_eq.
        exact true.
Qed.
Theorem prop_eq_false : ∀ P, (¬P) = (P = False).
Proof.
    intros P.
    apply propositional_ext; split.
    -   intros nP.
        apply propositional_ext; split; contradiction.
    -   intro eq.
        rewrite eq.
        rewrite not_false.
        exact true.
Qed.

Theorem neq_true_false : ∀ P, (P ≠ True) = (P = False).
Proof.
    intros P.
    rewrite <- prop_eq_true.
    rewrite prop_eq_false.
    reflexivity.
Qed.
Theorem neq_false_true : ∀ P, (P ≠ False) = (P = True).
Proof.
    intros P.
    rewrite <- prop_eq_false.
    rewrite not_not.
    apply prop_eq_true.
Qed.

Theorem prop_split : ∀ P, {P = True} + {P = False}.
Proof.
    intros P.
    rewrite <- prop_eq_true.
    rewrite <- prop_eq_false.
    apply sem.
Qed.

Theorem prop_neq : True ≠ False.
Proof.
    intros eq.
    rewrite <- eq.
    exact true.
Qed.

Theorem any_prop_neq : ∀ P, P ≠ (¬P).
Proof.
    intros P eq.
    destruct (prop_split P); subst.
    -   rewrite not_true in eq.
        rewrite <- eq.
        exact true.
    -   rewrite eq.
        rewrite not_false.
        exact true.
Qed.

Theorem not_eq_eq : ∀ A B, (¬A) = (¬B) → A = B.
Proof.
    intros A B eq.
    apply (f_equal not) in eq.
    do 2 rewrite not_not in eq.
    exact eq.
Qed.

Theorem not_eq_iff : ∀ A B, (A ↔ B) ↔ (¬A ↔ ¬B).
Proof.
    intros A B.
    split.
    -   intros AB.
        apply propositional_ext in AB.
        rewrite AB.
        reflexivity.
    -   intros AB.
        apply propositional_ext in AB.
        apply not_eq_eq in AB.
        rewrite AB.
        reflexivity.
Qed.

Theorem prop_is_true : ∀ {P : Prop}, P → P = True.
Proof.
    intros P H.
    rewrite <- prop_eq_true.
    exact H.
Qed.

Theorem prop_is_false : ∀ {P : Prop}, ¬P → P = False.
Proof.
    intros P H.
    rewrite <- prop_eq_false.
    exact H.
Qed.

Theorem eq_iff {U} : ∀ a b : U, a = b ↔ b = a.
Proof.
    intros a b.
    split; intro eq; symmetry; exact eq.
Qed.

Theorem or_left : ∀ A B : Prop, (¬B → A) → A ∨ B.
Proof.
    intros A B H.
    classic_case B as [BH|BH].
    -   right; exact BH.
    -   left; exact (H BH).
Qed.

Theorem or_right : ∀ A B : Prop, (¬A → B) → A ∨ B.
Proof.
    intros A B H.
    classic_case A as [AH|AH].
    -   left; exact AH.
    -   right; exact (H AH).
Qed.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat.

(* motivating example *)

Goal forall n, n + n = 2 * n.
elim.
  by rewrite addn0 muln0.
move=> n IH.
rewrite addSn.
rewrite addnS.
rewrite IH.
rewrite mulnS.
rewrite -addn2.
rewrite addnC.
done.
Qed.

(* a note an unification *)

Goal forall a b c d,
  a < b ->
  a < b + c + d.
move=> a b c d.
(*
ltn_addr : forall m n p : nat, m < n -> m < n + p
*)
Fail apply ltn_addr.
(* Error: Impossible to unify "b + c" with "b". *)
(* match m<->a, n<->b, p<->d and thus b + c<->n !!! *)
rewrite -addnA.
apply ltn_addr.
Qed.

Goal False.
evar (x : nat).
have : 2 + x = 4 + 5.
  rewrite /x.
  apply refl_equal.
rewrite /= in x *.
Abort.

Print nat.

Print nat_rect.
Print nat_ind.
Print nat_rec.

Definition mynat_ind_proof := fun (P : nat -> Prop) (f : P 0) (f0 : forall n : nat, P n -> P n.+1) =>
fix F (n : nat) : P n :=
  match n as n0 return (P n0) with
  | 0 => f
  | n0.+1 => f0 n0 (F n0)
  end.

Lemma mynat_ind : forall (P : nat -> Prop), P 0 ->
  (forall n : nat, P n -> P n.+1) ->
  forall n, P n.
exact mynat_ind_proof.
Qed.

(* le vs. leq *)

Print le.
Print leq.

Goal forall n, 0 <= n.
done.
Show Proof.
Qed.

(* compare with: *)
Print Le.le_0_n.

Goal forall n m, n.+1 <= m.+1 -> n <= m.
done.
Show Proof.
Qed.

(* compare with: *)
Print le_S_n.
Print le_pred.

Goal forall n, n <= n.
done.
Qed.

Goal forall n, n <= n.+1.
done.
Qed.

Goal forall n, n < n = false.
by elim.
Qed.

(* 加算の可換性: prove in one line (without using addnC of course) *)

Lemma exo16 n m : m + n = n + m.
Proof.
Abort.

(* about leqP *)

Goal forall n : nat, (n <= 5 \/ 5 < n)%coq_nat.
move=> n.
destruct (Compare_dec.le_gt_dec n 5).
(* NB: does not replace n <= 5 with True *)
auto.
auto.
Show Proof.
Qed.

Goal forall n : nat, (n <= 5) || (5 < n).
move=> n.
case H : (n <= 5).
done.
move/negbT : H.
rewrite -ltnNge.
move=> ->.
done.
(* pros: replace (n <= 5) by true, etc.
   cons: rewrite in the 2nd branch because of mismatch with standard library,
     does not scale to three way case analysis *)
Qed.

Goal forall n : nat, (n <= 5) || (5 < n).
move=> n.
case: (leqP n 5).
done.
done.
Qed.

 (* sum は (_ + _)%type *)
Definition rgb := sum unit bool.            (* (unit + bool)%type *)
Definition red : rgb := inl tt.
Definition green : rgb := inr false.
Definition blue : rgb := inr true.

Print rgb.                                  (* (unit + bool)%type *)
Definition nop (c : rgb) : rgb :=
  match c with
  | inl _ => red
  | inr false => green
  | inr true => blue
  end.
Compute nop red = red.
Compute nop green = green.
Compute nop blue = blue.

Definition shift (c : rgb) : rgb :=
  match c with
  | inl _ => green
  | inr false => blue
  | inr true => red
  end.

(* Prove the following: *)
Lemma exo17 c : shift (shift (shift c)) = c.
Proof.
Abort.

CoInductive rgb_spec : rgb -> bool -> bool -> bool -> Prop :=
| red_spec : rgb_spec red true false false
| green_spec : rgb_spec green false true false
| blue_spec : rgb_spec blue false false true.

(* Prove the following: *)
Lemma rgbP c : rgb_spec c (c == red) (c == green) (c == blue).
Proof.
Abort.

(* same as exo17 but this time using rgbP: *)
Lemma exo18 c : shift (shift (shift c)) = c.
Proof.
Abort.

(* END *)


Require Coq.QArith.QArith.

Module Quaternions.

    Import Coq.QArith.QArith.

    Inductive H : Set :=
        H_make (w x y z : Q) : H.

    Definition H_from (w : Q) :=
        H_make (w) (0) (0) (0).

    Definition H_zero := H_from (0).
    Definition H_one := H_from (1).
    Definition H_neg_one := H_from (-1).

    Definition i := H_make (0) (1) (0) (0).
    Definition j := H_make (0) (0) (1) (0).
    Definition k := H_make (0) (0) (0) (1).

    Definition Re (left : H) :=
        match (left) with H_make (w) (x) (y) (z) => w end.

    Definition Icoeff (left : H) :=
        match (left) with H_make (w) (x) (y) (z) => x end.

    Definition Jcoeff (left : H) :=
        match (left) with H_make (w) (x) (y) (z) => y end.

    Definition Kcoeff (left : H) :=
        match (left) with H_make (w) (x) (y) (z) => z end.

    Definition H_plus (left: H) (right : H) : H
        := match (left)
        with H_make (wl) (xl) (yl) (zl)
        => match (right)
        with H_make (wr) (xr) (yr) (zr)
        => H_make (wl + wr) (xl + xr) (yl + yr) (zl + zr)
        end end.

    Definition H_opp (right: H) : H
        := match (right) with H_make (wr) (xr) (yr) (zr)
        => H_make (- wr) (- xr) (- yr) (- zr) end.

    Definition H_conj (right: H) : H
        := match (right) with H_make (wr) (xr) (yr) (zr)
        => H_make (wr) (- xr) (- yr) (- zr) end.

    Definition H_norm_squared (right: H) : Q
        := match (right)
        with H_make (wr) (xr) (yr) (zr)
        => (wr * wr) + (xr * xr)
            + (yr * yr) + (zr * zr) end.

    Definition H_mul (left: H) (right : H) : H
        := match (left)
        with H_make (wl) (xl) (yl) (zl)
        => match (right)
        with H_make (wr) (xr) (yr) (zr)
        => H_make ((wl * wr) - (xl * xr)
                             - (yl * yr) - (zl * zr))
                  ((wl * xr) + (xl * wr)
                             + (yl * zr) - (zl * yr))
                  ((wl * yr) - (xl * zr)
                             + (yl * wr) + (zl * xr))
                  ((wl * zr) + (xl * yr)
                             - (yl * xr) + (zl * wr)) end end.

    Definition H_inv (left: H) : H
        := match (left)
        with H_make (0) (0) (0) (0) => H_zero
        | H_make (wl) (xl) (yl) (zl)
        =>  let den := wl * wl + xl * xl + yl * yl + zl * zl
            in H_make (wl / den) (- xl / den)
                (- yl / den) (- zl / den)
        end.

    Definition H_eq (left: H) (right: H) : Prop
        := match (left)
        with H_make (wl) (xl) (yl) (zl)
        => match (right)
        with H_make (wr) (xr) (yr) (zr)
        => (and (and (Qeq (wl) (wr))
                     (Qeq (xl) (xr)))
                (and (Qeq (yl) (yr))
                     (Qeq (zl) (zr)))) end end.

    Section Required_properties.

        Definition Q_zero_times_zero_equals_zero
            : Qeq (Qmult (0%Q) (0%Q)) (0%Q)
            := Qmult_0_l (0%Q).

        Definition Q_zero_equals_zero_times_zero
            : Qeq (0%Q) (Qmult (0%Q) (0%Q))
            := Qeq_sym (Qmult (0%Q) (0%Q))
                (0%Q)
                (Q_zero_times_zero_equals_zero).

        Definition Q_zero_times_one_equals_zero
            : Qeq (Qmult (0%Q) (1%Q)) (0%Q)
            := Qmult_0_l (1%Q).

        Definition Q_zero_equals_zero_times_one
            : Qeq (0%Q) (Qmult (0%Q) (1%Q))
            := Qeq_sym (Qmult (0%Q) (1%Q))
                (0%Q)
                (Q_zero_times_one_equals_zero).

        Definition Q_one_times_zero_equals_zero
            : Qeq (Qmult (1%Q) (0%Q)) (0%Q)
            := Qmult_1_l (0%Q).

        Definition Q_zero_equals_one_times_zero
            : Qeq (0%Q) (Qmult (1%Q) (0%Q))
            := Qeq_sym (Qmult (1%Q) (0%Q))
                (0%Q)
                (Q_one_times_zero_equals_zero).

        Definition Q_one_times_one_equals_one
            : Qeq (Qmult (1%Q) (1%Q)) (1%Q)
            := Qmult_1_l (1%Q).

        Definition Q_one_equals_one_times_one
            : Qeq (1%Q) (Qmult (1%Q) (1%Q))
            := Qeq_sym (Qmult (1%Q) (1%Q))
                (1%Q)
                (Q_one_times_one_equals_one).

        Lemma i_squared_equals_negative_one
            : H_eq (H_mul i i) (H_neg_one).
        Proof.
            assert (Real_part := eq_refl
                : 0*0 - 1*1 - 0*0 - 0*0 == -1).

            assert (I_coeff_part := eq_refl
                : 0*1 + 1*0 + 0*0 - 0*0 == 0).

            assert (J_coeff_part := eq_refl
                : 0*0 - 1*0 + 0*0 + 0*1 == 0).

            assert (K_coeff_part := eq_refl
                : 0*0 + 1*0 - 0*1 + 0*1 == 0).

            exact (conj (conj (Real_part)
                              (I_coeff_part))
                        (conj (J_coeff_part)
                              (K_coeff_part))).
        Qed.

        Theorem Add_is_commutative :
            forall (left : H) (right : H),
            H_eq (H_plus left right)
                 (H_plus right left).
        Proof.
            intro left.
            destruct left as [w_left x_left y_left z_left].
            intro right.
            destruct right as [w_right x_right y_right z_right].

            exact (conj (conj (Qplus_comm (w_left) (w_right))
                              (Qplus_comm (x_left) (x_right)))
                        (conj (Qplus_comm (y_left) (y_right))
                              (Qplus_comm (z_left) (z_right)))).
        Qed.
(*
    Theorem Add_is_associative:
        forall (left: H) (middle: H) (right: H),
        eq (Add left (Add middle right))
           (Add (Add left middle) right).
    Proof.
        intro left.
        destruct left as [w_left x_left y_left z_left].
        intro middle.
        destruct middle as [w_middle x_middle y_middle z_middle].
        intro right.
        destruct right as [w_right x_right y_right z_right].
        unfold Add.
        unfold Re.
        unfold Icoeff.
        unfold Jcoeff.
        unfold Kcoeff.
        rewrite (Reals.Add_is_associative (w_left) (w_middle) (w_right)).
        rewrite (Reals.Add_is_associative (x_left) (x_middle) (x_right)).
        rewrite (Reals.Add_is_associative (y_left) (y_middle) (y_right)).
        rewrite (Reals.Add_is_associative (z_left) (z_middle) (z_right)).
        reflexivity.
    Qed.

    Theorem Add_identity_is_zero:
        forall (right: H), eq (Add zero right) (right).
    Proof.
        intro right.
        destruct right as [w_right x_right y_right z_right].
        unfold Add.
        unfold zero.
        unfold Re.
        unfold Icoeff.
        unfold Jcoeff.
        unfold Kcoeff.
        rewrite (Reals.Add_identity_is_zero (w_right)).
        rewrite (Reals.Add_identity_is_zero (x_right)).
        rewrite (Reals.Add_identity_is_zero (y_right)).
        rewrite (Reals.Add_identity_is_zero (z_right)).
        reflexivity.
    Qed.

    Axiom Zero_is_add_identity:
        forall (left: H), eq (Add left zero) (left).

    Axiom Add_real_to_Neg_real:
        forall (x : H), eq (Add (x) (Neg x)) (zero).

    Axiom Add_Neg_real_to_real:
        forall (x : H), eq (Add (Neg x) (x)) (zero).

    Axiom Zero_is_Neg_zero: eq (zero) (Neg zero).

    Axiom Neg_zero_is_zero: eq (Neg zero) (zero).

    Axiom Mul_unique_left:
        forall (left1: H) (left2: H) (right: H)
        (sums_are_equal : eq (Mul left1 right) (Mul left2 right)),
        eq left1 left2.

    Axiom Mul_unique_right:
        forall (left: H) (right1: H) (right2: H)
        (sums_are_equal : eq (Mul left right1) (Mul left right2)),
        eq right1 right2.

    Axiom Mul_unique_product:
        forall (left: H) (right: H) (product1: H) (product2: H)
        (eq1: eq (Mul left right) product1)
        (eq2: eq (Mul left right) product2),
        eq product1 product2.

    Axiom Mul_is_commutative:
        forall (left: H) (right: H),
        eq (Mul left right) (Mul right left).

    Axiom Mul_is_associative:
        forall (left: H) (middle: H) (right: H),
        eq (Mul (left) (Mul middle right))
           (Mul (Mul left middle) (right)).

    Axiom Mul_is_distributive_left:
        forall (left: H) (middle: H) (right: H),
        eq (Mul (Add left middle) (right))
           (Add (Mul left right) (Mul middle right)).

    Axiom Mul_is_distributive_right:
        forall (left: H) (middle: H) (right: H),
        eq (Mul (left) (Add middle right))
           (Add (Mul left middle) (Mul left right)).

    Axiom Mul_identity_is_zero:
        forall (right: H), eq (Mul one right) (right).

    Axiom One_is_Mul_identity:
        forall (left: H), eq (Mul left one) (left).

    Axiom Mul_real_by_Inv_real:
        forall (left: H) (not_zero : not (eq left zero)),
        eq (Mul (left) (Inv left not_zero)) (one).

    Axiom Mul_Inv_real_by_real:
        forall (right: H) (not_zero : not (eq right zero)),
        eq (Mul (Inv right not_zero) (right)) (one).
*)

    End Required_properties.

End Quaternions.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Locate "exists".

(* 10.1.1 *)
(* Coq.Init.Logic - Props*)
Lemma tst_prop: forall x, exists n, x = n * 2 \/ x = S(n * 2).
Proof.
  elim => [| x [n IH]].
    exists 0. by left.
  case IH.
    move => H.
    exists n.
    right.
    by rewrite -H.
  move => H.
  exists (S n).
  left.
  by rewrite mulSn 2!addSn add0n -H.
Defined.

Compute (tst_prop 5).

(* Coq.Init.Specif - various options arount sigma types *)
Lemma tst_type: forall x,  { n & {x = n * 2} + {x = S(n * 2)} }.
Proof.
  elim => [| x [n IH]].
    exists 0. by left.
  case IH.
    move => H.
    exists n.
    right.
    by rewrite -H.
  move => H.
  exists (S n).
  left.
  by rewrite mulSn 2!addSn add0n -H.
Defined.

Compute (tst_type 5).

Definition tst (n: nat): nat :=
  match (tst_type n) with
  | existT a b => a
  end.

Definition is_even (n: nat): bool :=
  match (tst_type n) with
  | existT a (left _) => true
  | existT a (right _) => false
  end.

Compute (tst 6).
Compute (is_even 6).

(* Prop in calculation *)
Fail Definition tst_prop (n: nat): nat :=
  match (tst_prop n) with
  | ex_intro a b => a
  end.

Locate "+".
Print sumor.
Print sumbool.
Print sum.

(* 10.2.5 *)
Definition e1: forall b, (b = true) + (b = false) :=
  fun b =>
    match b with
    | true => inl erefl
    | false => inr erefl
    end.

Definition e2: forall n, (n = 0) + ({n' & n = S n'}) :=
  fun n =>
    match n return (n = 0) + ({n' & n = S n'}) with
    | 0 => inl erefl
    | S n' as n => inr (existT (fun x => n = S x) n' (erefl (S n')))
    end.

Print prod.
Search ((_ -> _) * (_ -> _)).
Search (Type -> Type -> Prop).

(* 10.2.8 *)
(* Lemma sigma_bij X (p : X -> Prop): { x & p x } <-> (forall Z, (forall x, p x -> Z) -> Z). *)

(* 10.2.9 *)
Lemma sigma_eq_fw X Y : X + Y -> { b & if b then X else Y }.
Proof.
  case.
    by exists true.
  by exists false.
Defined.

Lemma sigma_eq_bw X Y : { b & if b then X else Y } -> X + Y.
Proof.
  move => [b p].
  case: b p => H.
    by left.
  by right.
Defined.

(* 10.3 *)
Definition p1 X (p: X -> Type): {x & p x} -> X :=
  fun p =>
    match p with
    | existT x p => x
    end.

Definition p2 X (p: X -> Type): forall (a: {x & p x}), p (p1 a) :=
  fun a =>
    match a with
    | existT x p' => p'
    end.

(* 10.3.1 *)
Lemma scolem_fw (X Y: Type) (p: X -> Y -> Type):
  (forall x, { y & p x y}) -> { f & forall x, p x (f x) }.
Proof.
  move => H.
  exists (fun x => p1 (H x)).
  move => x.
  move : (H x) => hx.
  case : hx => [y pxy].
  by rewrite /p1.
Defined.

Lemma scolem_bw (X Y: Type) (p: X -> Y -> Type):
   { f & forall x, p x (f x) } -> forall x, { y & p x y}.
Proof.
  move => [f H] x.
  exists (f x).
  by apply (H x).
Defined.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From LF Require Export exercise6.
From Coq Require Import Lia.

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

Definition f (n : nat) :=
  if even n then div2 n
  else 3 * n + 1.

Fail Fixpoint reaches_1_in (n : nat) :=
  if n =? 1 then 0
  else 1 + reaches_1_in (f n).

Inductive reaches_1 : nat -> Prop :=
  | term_done : reaches_1 1
  | term_more (n : nat) : reaches_1 (f n) -> reaches_1 n.

Conjecture collatz : forall n, reaches_1 n.

Module LePlayground.

Inductive le : nat -> nat -> Prop :=
| le_n (n : nat) : le n n
| le_S (n m : nat) : le n m -> le n (S m).

End LePlayground.

(* Basic requirement for a closure : R \subsetof C. *)
Inductive clos_trans {X : Type} (R : X -> X -> Prop) : X -> X -> Prop :=
  | t_step (x y : X) :
    R x y ->
    clos_trans R x y
  | t_trans (x y z : X) :
    clos_trans R x y ->
    clos_trans R y z ->
    clos_trans R x z.

(* Exercise: 1 star, standard, optional (close_refl_trans) *)
(* How would you modify this definition so that it defines reflexive and
transitive closure? How about reflexive, symmetric, and transitive closure? *)
Inductive clos_refl_trans {X : Type} (R : X -> X -> Prop) : X -> X -> Prop :=
  | rt_step (x y : X) : R x y -> clos_refl_trans R x y (* contain *)
  | rt_refl (x : X) : clos_refl_trans R x x            (* reflexivity. *)
  | rt_trans (x y z : X) :
    clos_refl_trans R x y -> clos_refl_trans R y z -> clos_refl_trans R x z.
    (* transivity. *)

Inductive clos_refl_trans_symm {X : Type} (R : X -> X -> Prop) :
  X -> X -> Prop :=
  | rts_step(x y : X) : R x y -> clos_refl_trans_symm R x y
  | rts_symm(x y : X) : clos_refl_trans_symm R x y -> clos_refl_trans_symm R y x
  | rts_refl(x : X) : clos_refl_trans_symm R x x
  | rts_trans(x y z : X) :
    clos_refl_trans_symm R x y ->
    clos_refl_trans_symm R y z ->
    clos_refl_trans_symm R x z.

Inductive Perm3 {X : Type}: list X -> list X -> Prop :=
  | perm3_swap12 (x y z : X) :
    Perm3 [x;y;z] [y;x;z]
  | perm3_swap23 (x y z : X) :
    Perm3 [x;y;z] [x;z;y]
  | perm3_trans (l1 l2 l3 : list X) :
    Perm3 l1 l2 -> Perm3 l2 l3 -> Perm3 l1 l3.

(* These evidence constructors can be thought of as "primitive evidence of
evenness", and they can be used just like proven theorems. *)
Inductive ev : nat -> Prop :=
  | ev_0 : ev 0
  | ev_SS (n : nat) (H : ev n) : ev (S (S n)).

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

Theorem ev_double : forall n,
  ev (double n).
Proof.
  intros. induction n as [| n' H].
  - simpl. apply ev_0.
  - rewrite double_incr. apply ev_SS. apply H.
Qed.

Theorem ev_inversion : forall n : nat,
  ev n ->
  (n = 0) \/ (exists n', n = S (S n') /\ ev n').
Proof.
  intros. destruct H.
  - left. reflexivity.
  - right. exists n. split. reflexivity. apply H.
Qed.

Theorem evSS_ev : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros. apply ev_inversion in H. destruct H as [H1 | H2].
  - discriminate.
  - destruct H2 as [n' [H3 H4]]. injection H3. intros. rewrite H. apply H4.
Qed.

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

(** **** Exercise: 1 star, standard (inversion_practice) *)
(* Prove the following result using inversion. (For extra practice, you can also
prove it using the inversion lemma.) *)
Theorem SSSSev_even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros. inversion H. inversion H1.
  apply H3.
Qed.

(** **** Exercise: 1 star, standard (ev5_nonsense) *)
(* Prove the following result using inversion. *)
Theorem ev5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros. inversion H.
  inversion H1. inversion H3.
Qed.

Theorem ev_Even : forall n,
  ev n -> Even n.
Proof.
  unfold Even. intros. induction H as [| n' H].
  - exists 0. reflexivity.
  - destruct IHH as [nd H'].
    rewrite H'. rewrite <- double_incr. exists (S nd). reflexivity.
Qed.

Theorem Even_ev : forall n,
  Even n -> ev n.
Proof.
  unfold Even. intros.
  destruct H.
  rewrite H. apply ev_double.
Qed.

Theorem ev_Even_iff : forall n,
  ev n <-> Even n.
Proof.
  split. apply ev_Even. apply Even_ev.
Qed.

(** **** Exercise: 2 stars, standard (ev_sum) *)
Theorem ev_sum : forall n m,
  ev n -> ev m -> ev (n + m).
Proof.
  intros. induction H.
  - simpl. apply H0.
  - simpl. apply ev_SS. apply IHev.
Qed.

(** **** Exercise: 4 stars, advanced, optional (ev'_ev) *)
(* In general, there may be multiple ways of defining a property inductively. For
example, here's a (slightly contrived) alternative definition for ev: *)
Inductive ev' : nat -> Prop :=
  | ev'_0 : ev' 0
  | ev'_2 : ev' 2
  | ev'_sum n m (Hn : ev' n) (Hm : ev' m) : ev' (n + m).

Lemma plus_1_r : forall n,
  S n = n + 1.
Proof.
  intros. induction n.
  - reflexivity.
  - simpl. rewrite <- IHn. reflexivity.
Qed.

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

(** **** Exercise: 3 stars, advanced, especially useful (ev_ev__ev) *)
Theorem ev_ev__ev : forall n m,
  ev (n + m) -> ev n -> ev m.
  (* Hint: There are two pieces of evidence you could attempt to induct upon
      here. If one doesn't work, try the other. *)
Proof.
  intros. induction H0.
  - simpl in H. apply H.
  - apply IHev. apply ev_sum. apply H0. simpl in H. apply evSS_ev in H.
    apply IHev in H. apply H.
Qed.

(** **** Exercise: 3 stars, standard, optional (ev_plus_plus) *)
(* This exercise can be completed without induction or case analysis. But, you
will need a clever assertion and some tedious rewriting.
Hint: Is (n+m) + (n+p) even? <- acturally we can prove it by introduce another p *)
Theorem ev_plus_plus : forall n m p,
  ev (n + m) -> ev (n + p) -> ev (m + p).
Proof.
  intros n m p H.
  (* Do not introduce all. We need to take use of the previously proved theorem. *)
  apply ev_ev__ev.
  (* Organize all p's together. *)
  rewrite <- add_assoc. rewrite (add_comm p (m + p)).
  rewrite add_assoc. rewrite add_assoc. rewrite <- add_assoc.
  (* Extract 2 terms. *)
  apply ev_sum.
  apply H.
  (* trivial. *)
  rewrite <- double_plus. apply ev_double.
Qed.

Module Playground.
Inductive le : nat -> nat -> Prop :=
	| le_n (n : nat) : le n n
	| le_S (n m : nat) (H : le n m) : le n (S m).

Notation "n <= m " := (le n m).

Theorem test_le_1 : 3 <= 3.
Proof.
  apply le_n.
Qed.

Theorem test_l2_2: 3 <= 6.
Proof.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
Qed.

Theorem test_le_3 :
  (2 <= 1) -> 2 + 2 = 5.
Proof.
  intros.
  inversion H.
  inversion H2.
Qed.

Definition lt (n m : nat) := le (S n) m.

Notation "m < n" := (lt m n).
End Playground.

(** **** Exercise: 2 stars, standard, optional (total_relation) *)
(* Define an inductive binary relation total_relation that holds between every pair of natural numbers. *)
Inductive total_relation : nat -> nat -> Prop := total n m : total_relation n m.

Theorem total_relation_is_total : forall n m, total_relation n m.
Proof.
  intros. apply total.
Qed.

(** **** Exercise: 2 stars, standard, optional (empty_relation) *)
(* Define an inductive binary relation empty_relation (on numbers) that never holds. *)
Inductive empty_relation : nat -> nat -> Prop :=.

Theorem empty_relation_is_empty : forall n m, ~ empty_relation n m.
Proof.
  unfold not. intros. inversion H.
Qed.

Lemma le_trans : forall n m o, m <= n -> n <= o -> m <= o.
Proof.
  intros. transitivity n. apply H. apply H0.
Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  intros. induction n.
  - reflexivity.
  - apply le_S. apply IHn.
Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H.
  - apply le_n.
  - apply le_S. apply IHle.
Qed.

Lemma Sn_le_m__n_le_m : forall n m,
S n <= m -> n <= m.
Proof.
  intros. induction H.
  - apply le_S. apply le_n.
  - apply le_S. apply IHle.
Qed.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros. inversion H.
  - apply le_n.
  - apply Sn_le_m__n_le_m. apply H1.
Qed.

Lemma O_lt_Sn : forall n,
  0 < S n.
Proof.
  intros. induction n.
  - unfold lt. reflexivity.
  - apply le_S. unfold lt in IHn. apply IHn.
Qed.

Lemma Sn_le_0_0 : forall n,
  n <= 0 -> n = 0.
Proof.
  intros. inversion H. reflexivity.
Qed.

Lemma n_lt_m__Sn_lt_Sm (n m : nat) : n < m -> S n < S m.
Proof.
(* trivial. omit here. *)
Admitted.

Theorem ge_two_meanings : forall n m,
  n <= m -> n < m \/ n = m.
Proof.
  intros n. induction n.
  - intros. destruct m.
    + right. reflexivity.
    + left. apply O_lt_Sn.
  - intros. destruct m.
    + apply Sn_le_0_0 in H. right. apply H.
    + apply Sn_le_Sm__n_le_m in H. apply IHn in H. destruct H.
      * left. apply n_lt_m__Sn_lt_Sm. apply H.
      * right. rewrite H. reflexivity.
Qed.

Theorem ge_two_meanings_strong : forall n m,
  n <= m -> n < m \/ n >= m.
Proof.
  intros. apply ge_two_meanings in H.
  destruct H.
  * left. apply H.
  * right. rewrite H. unfold ge. reflexivity.
Qed.

Theorem lt_ge_cases : forall n m,
  n < m \/ n >= m.
Proof.
  intros. induction n.
  - destruct m.
    + right. unfold ge. reflexivity.
    + left. apply O_lt_Sn.
  - destruct m.
    + right. unfold ge. apply O_le_n.
    + destruct IHn.
      * apply ge_two_meanings_strong. unfold lt in H. apply H.
      * right. unfold ge. unfold ge in H.
        apply Sn_le_m__n_le_m in H. apply n_le_m__Sn_le_Sm. apply H.
Qed.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  intros. induction b.
  - rewrite add_0_r. reflexivity.
  - rewrite plus_1_r. rewrite add_assoc. rewrite <- plus_1_r.
    apply le_S. apply IHb.
Qed.

Theorem plus_le : forall n1 n2 m,
  n1 + n2 <= m ->
  n1 <= m /\ n2 <= m.
Proof.
  intros. split.
  - induction n2.
    + rewrite add_0_r in H. apply H.
    + rewrite plus_1_r in H. rewrite add_assoc in H. rewrite <- plus_1_r in H.
      apply Sn_le_m__n_le_m in H. apply IHn2 in H. apply H.
  - induction n1.
    + simpl in H. apply H.
    + simpl in H. apply Sn_le_m__n_le_m in H. apply IHn1 in H. apply H.
Qed.

Theorem add_le_cases : forall n m p q,
  n + m <= p + q -> n <= p \/ m <= q.
Proof.
  intros n. induction n.
  - intros. left. apply O_le_n.
  - intros. destruct p.
    + simpl in H. apply Sn_le_m__n_le_m in H. right.
      apply plus_le in H. destruct H as [_ H]. apply H.
    + simpl in H. apply Sn_le_Sm__n_le_m in H. apply IHn in H.
      destruct H.
      * left. apply n_le_m__Sn_le_Sm in H. apply H.
      * right. apply H.
Qed.

Theorem plus_le_compat_l : forall n m p,
  n <= m ->
  p + n <= p + m.
Proof.
  intros. induction p. generalize dependent n. generalize dependent m.
  - simpl. intros. apply H.
  - simpl. apply n_le_m__Sn_le_Sm in IHp. apply IHp.
Qed.

Theorem plus_le_compat_r : forall n m p,
  n <= m ->
  n + p <= m + p.
Proof.
  intros. induction p. generalize dependent n. generalize dependent m.
  - intros. rewrite add_0_r. rewrite add_0_r. apply H.
  - rewrite plus_1_r. rewrite (add_comm p 1). rewrite add_assoc. rewrite add_assoc.
    replace (n + 1) with (S n). replace (m + 1) with (S m). simpl.
    apply n_le_m__Sn_le_Sm in IHp. apply IHp.
    apply plus_1_r. apply plus_1_r.
Qed.

Theorem le_plus_trans : forall n m p,
  n <= m ->
  n <= m + p.
Proof.
  intros. induction p.
  - rewrite add_0_r. apply H.
  - rewrite plus_1_r. rewrite add_assoc. rewrite <- plus_1_r.
    apply le_S. apply IHp.
Qed.

Lemma Sn_lt_m__n_lt_m : forall n m,
  S n < m -> n < m.
Proof.
  unfold lt. intros.
  apply Sn_le_m__n_le_m. apply H.
Qed.

Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
  intros. split.
  - induction n2.
    + rewrite add_0_r in H. apply H.
    + rewrite plus_1_r in H. rewrite add_assoc in H. rewrite <- plus_1_r in H.
      apply Sn_lt_m__n_lt_m in H. apply IHn2 in H. apply H.
  - induction n1.
    + simpl in H. apply H.
    + simpl in H. apply Sn_lt_m__n_lt_m in H. apply IHn1 in H. apply H.
Qed.

(** **** Exercise: 4 stars, standard, optional (more_le_exercises) *)
Theorem leb_complete : forall n m,
  n <=? m = true -> n <= m.
Proof.
  intros n. induction n.
  - intros. apply O_le_n.
  - intros. destruct m.
    + inversion H.
    + apply n_le_m__Sn_le_Sm. apply IHn. simpl in H. apply H.
Qed.

Theorem leb_correct : forall n m,
  n <= m ->
  n <=? m = true.
Proof.
  intros. generalize dependent n. induction m.
  - intros. inversion H. reflexivity.
  - destruct n.
    + reflexivity.
    + intros. apply Sn_le_Sm__n_le_m in H. apply IHm in H. simpl. apply H.
Qed.

Theorem leb_iff : forall n m,
  n <=? m = true <-> n <= m.
Proof.
  intros. split. apply leb_complete. apply leb_correct.
Qed.

Theorem leb_true_trans : forall n m o,
  n <=? m = true -> m <=? o = true -> n <=? o = true.
Proof.
  intros. rewrite leb_iff in H, H0. rewrite leb_iff.
  transitivity m. apply H. apply H0.
Qed.

(* R a b c <-> a + b = c. *)
Inductive R : nat -> nat -> nat -> Prop :=
  | c1 : R 0 0 0
  | c2 m n o (H : R m n o ) : R (S m) n (S o)
  | c3 m n o (H : R m n o ) : R m (S n) (S o)
  | c4 m n o (H : R (S m) (S n) (S (S o))) : R m n o
  | c5 m n o (H : R m n o ) : R n m o.

Definition fR : nat -> nat -> nat :=
  fun (a b : nat) => a + b.

Lemma R_0_n_n : forall n,
  R 0 n n.
Proof.
  intros. induction n.
  - apply c1.
  - apply c3. apply IHn.
Qed.

Lemma abc_R_abc : forall a b c,
  a + b = c -> R a b c.
Proof.
  intros a. induction a.
  - simpl. intros. rewrite H. apply R_0_n_n.
  - intros. destruct c.
    + inversion H.
    + simpl in H. injection H. intros.
      apply IHa in H0. apply c2. apply H0.
Qed.

Theorem R_equiv_fR : forall a b c, R a b c <-> fR a b = c.
 Proof.
  split; unfold fR.
  - intros. induction H.
    + trivial.
    + simpl. rewrite IHR. trivial.
    + rewrite <- plus_n_Sm. rewrite IHR. trivial.
    + simpl in IHR. rewrite <- plus_n_Sm in IHR. injection IHR. trivial.
    + rewrite add_comm. apply IHR.
  - apply abc_R_abc.
Qed.

Inductive subseq : list nat -> list nat -> Prop :=
  | empty: subseq [] []
  | add_r l1 l2 n (H : subseq l1 l2): subseq l1 (n :: l2)
  | add_both l1 l2 n (H : subseq l1 l2): subseq (n :: l1) (n :: l2).

Lemma empty_subseq : forall l : list nat,
  subseq [] l.
Proof.
  intros. induction l.
  - apply empty.
  - apply add_r. apply IHl.
Qed.

Lemma add_right_list : forall l1 l2 l3,
  subseq l1 l2 -> subseq l1 (l2 ++ l3).
Proof.
  intros. induction H.
  - simpl. apply empty_subseq.
  - simpl. apply add_r. apply IHsubseq.
  - simpl. apply add_both. apply IHsubseq.
Qed.

Theorem subseq_refl : forall (l : list nat), subseq l l.
Proof.
  intros.
  induction l.
  - apply empty.
  - apply add_both. apply IHl.
Qed.

Theorem subseq_app : forall (l1 l2 l3 : list nat),
  subseq l1 l2 ->
  subseq l1 (l2 ++ l3).
Proof.
  destruct l1.
  - intros. apply empty_subseq.
  - intros. apply add_right_list. apply H.
Qed.

Theorem subseq_trans : forall l1 l2 l3,
  subseq l1 l2 ->
  subseq l2 l3 ->
  subseq l1 l3.
Proof.
  intros l1 l2 l3 H1 H2. generalize dependent l1.
  induction H2. (* We want to eliminate the middle one, so we do induction on it. *)
  - auto.
  - intros. apply add_r. apply IHsubseq. apply H1.
  - intros. inversion H1.
    + apply add_r. apply IHsubseq. apply H3.
    + apply add_both. apply IHsubseq. apply H3.
Qed.


Require Import Basics.Overture Basics.Tactics.
Require Import Pos.Core.

Local Open Scope positive_scope.

(** ** Specification of [succ] in term of [add] *)

Lemma pos_add_1_r p : p + 1 = pos_succ p.
Proof.
  by destruct p.
Qed.

Lemma pos_add_1_l p : 1 + p = pos_succ p.
Proof.
  by destruct p.
Qed.

(** ** Specification of [add_carry] *)

Theorem pos_add_carry_spec p q : pos_add_carry p q = pos_succ (p + q).
Proof.
  revert q.
  induction p; destruct q; simpl; by apply ap.
Qed.

(** ** Commutativity of [add] *)

Theorem pos_add_comm p q : p + q = q + p.
Proof.
  revert q.
  induction p; destruct q; simpl; apply ap; trivial.
  rewrite 2 pos_add_carry_spec; by apply ap.
Qed.

(** ** Permutation of [add] and [succ] *)

Theorem pos_add_succ_r p q : p + pos_succ q = pos_succ (p + q).
Proof.
  revert q.
  induction p; destruct q; simpl; apply ap;
   auto using pos_add_1_r; rewrite pos_add_carry_spec; auto.
Qed.

Theorem pos_add_succ_l p q : pos_succ p + q = pos_succ (p + q).
Proof.
  rewrite pos_add_comm, (pos_add_comm p). apply pos_add_succ_r.
Qed.

Definition pos_add_succ p q : p + pos_succ q = pos_succ p + q.
Proof.
  by rewrite pos_add_succ_r, pos_add_succ_l.
Defined.

Definition pos_add_carry_spec_l q r
  : pos_add_carry q r = pos_succ q + r.
Proof.
  by rewrite pos_add_carry_spec, pos_add_succ_l.
Qed.

Definition pos_add_carry_spec_r q r
  : pos_add_carry q r = q + pos_succ r.
Proof.
  by rewrite pos_add_carry_spec, pos_add_succ_r.
Defined.

(** ** No neutral elements for addition *)
Lemma pos_add_no_neutral p q : q + p <> p.
Proof.
  revert q.
  induction p as [ |p IHp|p IHp]; intros [ |q|q].
  1,3: apply x0_neq_xH.
  1: apply x1_neq_xH.
  1,3: apply x1_neq_x0.
  2,4: apply x0_neq_x1.
  1,2: intro H; apply (IHp q).
  1: apply x0_inj, H.
  apply x1_inj, H.
Qed.

(** * Injectivity of pos_succ *)
Lemma pos_succ_inj n m : pos_succ n = pos_succ m -> n = m.
Proof.
  revert m.
  induction n as [ | n x | n x]; induction m as [ | m y | m y].
  + reflexivity.
  + intro p.
    destruct (x0_neq_x1 p).
  + intro p.
    simpl in p.
    apply x0_inj in p.
    destruct m.
    1,3: destruct (xH_neq_x0 p).
    destruct (xH_neq_x1 p).
  + intro p.
    destruct (x1_neq_x0 p).
  + simpl.
    intro p.
    by apply ap, x1_inj.
  + intro p.
    destruct (x1_neq_x0 p).
  + intro p.
    cbn in p.
    apply x0_inj in p.
    destruct n.
    1,3: destruct (x0_neq_xH p).
    destruct (x1_neq_xH p).
  + intro p.
    cbn in p.
    destruct (x0_neq_x1 p).
  + intro p.
    apply ap, x, x0_inj, p.
Defined.

(** ** Addition is associative *)

Theorem pos_add_assoc p q r : p + (q + r) = p + q + r.
Proof.
  revert q r.
  induction p.
  + intros [|q|q] [|r|r].
    all: try reflexivity.
    all: simpl.
    1,2: by destruct r.
    1,2: apply ap; symmetry.
    1: apply pos_add_carry_spec.
    1: apply pos_add_succ_l.
    apply ap.
    rewrite pos_add_succ_l.
    apply pos_add_carry_spec.
  + intros [|q|q] [|r|r].
    all: try reflexivity.
    all: cbn; apply ap.
    3,4,6: apply IHp.
    1: apply pos_add_1_r.
    1: symmetry; apply pos_add_carry_spec_r.
    1: apply pos_add_succ_r.
    rewrite 2 pos_add_carry_spec_l.
    rewrite <- pos_add_succ_r.
    apply IHp.
  + intros [|q|q] [|r|r].
    all: cbn; apply ap.
    1: apply pos_add_1_r.
    1: apply pos_add_carry_spec_l.
    1: apply pos_add_succ.
    1: apply pos_add_carry_spec.
    1: apply IHp.
    2: symmetry; apply pos_add_carry_spec_r.
    1,2: rewrite 2 pos_add_carry_spec, ?pos_add_succ_l.
    1,2: apply ap, IHp.
    rewrite ?pos_add_carry_spec_r.
    rewrite pos_add_succ.
    apply IHp.
Qed.

(** ** One is neutral for multiplication *)

Lemma pos_mul_1_l p : 1 * p = p.
Proof.
  reflexivity.
Qed.

Lemma pos_mul_1_r p : p * 1 = p.
Proof.
  induction p; cbn; trivial; by apply ap.
Qed.

(** pos_succ and doubling functions *)

Lemma pos_pred_double_succ n
  : pos_pred_double (pos_succ n) = n~1.
Proof.
  induction n as [|n|n nH].
  all: trivial.
  cbn; apply ap, nH.
Qed.

Lemma pos_succ_pred_double n
  : pos_succ (pos_pred_double n) = n~0.
Proof.
  induction n as [|n nH|n].
  all: trivial.
  cbn; apply ap, nH.
Qed.

(** ** Iteration and pos_succ *)
Lemma pos_iter_succ_l {A} (f : A -> A) p a
  : pos_iter f (pos_succ p) a = f (pos_iter f p a).
Proof.
  unfold pos_iter.
  by rewrite pos_peano_ind_beta_pos_succ.
Qed.

Lemma pos_iter_succ_r {A} (f : A -> A) p a
  : pos_iter f (pos_succ p) a = pos_iter f p (f a).
Proof.
  revert p f a.
  srapply pos_peano_ind.
  1: hnf; intros; trivial.
  hnf; intros p q f a.
  refine (_ @ _ @ _^).
  1,3: unfold pos_iter;
    by rewrite pos_peano_ind_beta_pos_succ.
  apply ap.
  apply q.
Qed.

(** ** Right reduction properties for multiplication *)
Lemma mul_xO_r p q : p * q~0 = (p * q)~0.
Proof.
  induction p; simpl; f_ap; f_ap; trivial.
Qed.

Lemma mul_xI_r p q : p * q~1 = p + (p * q)~0.
Proof.
  induction p; simpl; trivial; f_ap.
  rewrite IHp.
  rewrite pos_add_assoc.
  rewrite (pos_add_comm q p).
  symmetry.
  apply pos_add_assoc.
Qed.

(** ** Commutativity of multiplication *)
Lemma pos_mul_comm p q : p * q = q * p.
Proof.
  induction q; simpl.
  1: apply pos_mul_1_r.
  + rewrite mul_xO_r.
    f_ap.
  + rewrite mul_xI_r.
    f_ap; f_ap.
Qed.

(** ** Distributivity of addition over multiplication *)
Theorem pos_mul_add_distr_l p q r :
  p * (q + r) = p * q + p * r.
Proof.
  induction p; cbn; [reflexivity | f_ap | ].
  rewrite IHp.
  set (m:=(p*q)~0).
  set (n:=(p*r)~0).
  change ((p*q+p*r)~0) with (m+n).
  rewrite 2 pos_add_assoc; f_ap.
  rewrite <- 2 pos_add_assoc; f_ap.
  apply pos_add_comm.
Qed.

Theorem pos_mul_add_distr_r p q r :
  (p + q) * r = p * r + q * r.
Proof.
  rewrite 3 (pos_mul_comm _ r); apply pos_mul_add_distr_l.
Qed.

(** ** Associativity of multiplication *)
Theorem pos_mul_assoc p q r : p * (q * r) = p * q * r.
Proof.
  induction p; simpl; rewrite ?IHp; trivial.
  by rewrite pos_mul_add_distr_r.
Qed.

(** ** pos_succ and pos_mul *)

Lemma pos_mul_succ_l p q
  : (pos_succ p) * q = p * q + q.
Proof.
  by rewrite <- pos_add_1_r, pos_mul_add_distr_r, pos_mul_1_l.
Qed.

Lemma pos_mul_succ_r p q
  : p * (pos_succ q) = p + p * q.
Proof.
  by rewrite <- pos_add_1_l, pos_mul_add_distr_l, pos_mul_1_r.
Qed.


Require Import Nat.
Require Import Fin.
Require Import Vector.
Require Import Program.

(****************)
(* Isomorphisms *)
(****************)

(* isomorphism of Types *)
Record Iso (A B : Type) : Type :=
  MkIso {
      to :     A -> B;
      from :   B -> A;
      toFrom : forall (b : B), (to (from b) = b);
      fromTo : forall (a : A), (from (to a) = a)
  }.

Notation " A ≅ B " := (Iso A B) (at level 9).

(* identity isomorphism *)
Definition idIso (A : Type) : A ≅ A :=
  (MkIso _ _ id id (fun _ => eq_refl) (fun _ => eq_refl)).

(* inversion of isomorphisms *)
Definition symIso {A B : Type} : A ≅ B -> B ≅ A.
Proof.
  intro isoAB.
  destruct isoAB as [to from toFrom fromTo].
  exact (MkIso _ _ from to fromTo toFrom).
Defined.

(* we even have (but never use..) *)
Lemma symIsoIso {A B : Type} : (A ≅ B) ≅ (B ≅ A).
Proof.
  apply (MkIso _ _ symIso symIso);
  intro isoab; destruct isoab; simpl; reflexivity.
Defined.

(* composition of isomorphisms *)
Definition transIso {A B C : Type} : B ≅ C -> A ≅ B -> A ≅ C.
Proof.
  intros isoBC isoAB.
  destruct isoBC as [bc cb bccb cbbc].
  destruct isoAB as [ab ba abba baab].
  apply (MkIso _ _ (bc ∘ ab) (ba ∘ cb)).
  + intro c; compute; rewrite (abba (cb c)); rewrite (bccb c); reflexivity.
  + intro a; compute; rewrite (cbbc (ab a)); rewrite (baab a); reflexivity.
Defined.

(* ∘≅  = \circ\cong *)
Notation " iso1 ∘≅ iso2 " := (transIso iso1 iso2) (at level 20).

Definition flipTransIso {A B C : Type} : A ≅ B -> B ≅ C -> A ≅ C.
Proof.
   intros isoAB isoBC.
   exact (isoBC ∘≅ isoAB).
Defined.

(* ⇛  = \Rrightarrow , ⇚  = \Lleftarrow *)
Notation " iso ⇛ " := (transIso iso) (at level 19).
Notation " iso ⇚ " := (transIso (symIso iso)) (at level 19).
Notation " ⇛ iso " := (flipTransIso iso) (at level 19).
Notation " ⇚ iso " := (flipTransIso (symIso iso)) (at level 19).

(*
(* with function extensionality, we would even have: *)
Lemma transIsoIso (A B C : Type) (isoBC : B ≅ C) : (A ≅ B) ≅ (A ≅ C).

  but not here...
*)

(****************)
(* Finite Types *)
(****************)

(* property of a type to be finite *)
Record Finite (X : Type) : Type :=
  MkFinite {
      card : nat;
      isoFin : Iso X (Fin.t card)
  }.

(* the type of finite types *)
Definition FiniteType : Type := sigT Finite.

(* for any cardinality, we have the standard finite type
   of that cardinality *)
Definition FinFinite (card : nat) : FiniteType.
Proof.
  unfold FiniteType.
  exists (Fin.t card).
  apply (MkFinite (Fin.t card) card (idIso (Fin.t card))).
Defined.

(**************************************************)
(* operations on FiniteType:                      *)
(**************************************************)

(* Many constructions producing a type from
   some parameter types yield finite types if
   the parameter types are finite.

   Examples considered below are
     option :    Type -> Type
     sum, prod:  Type -> Type -> Type
     Vect.t _ n: Type -> Type (for some n:nat)

   The function type A -> B of finite types
   A and B cannot be shown to be finite, although
   of course any function f : A -> B is extensionally
   determined by the list of values it takes on the
   elements of A. That's why we take Vector.t B (card A)
   as the type of functions between finite sets A and B,
   see below.

   Remark: Only the finiteness of A is necessary for
   this indentification to be reasonable, so we will also
   identify a type family on a finite type A - i.e. a
   function A -> Type - with a Vector of types although
   of course neither Type nor FiniteType are finite.

*)

(* ---------------------------------------------*)
(* operations on FiniteType: Option             *)
(* ---------------------------------------------*)

(* option preserves finiteness *)

Definition optionFinTo {n : nat} (f : Fin.t (S n)) : option (Fin.t n) :=
  match f with
    | F1 => None
    | FS f' => Some f'
  end.

Definition optionFinFrom {n : nat} (of : option (Fin.t n)) : Fin.t (S n) :=
  match of with
    | None => F1
    | Some f' => FS f'
  end.

Definition optionFinIso {n : nat} : Iso (Fin.t (S n)) (option (Fin.t n)).
Proof.
  apply (MkIso _ _ (@optionFinTo n) (@optionFinFrom n)).
  - induction n; intro b; destruct b; simpl; reflexivity.
  - induction n; intro a; dependent destruction a; simpl; reflexivity.
Defined.

(* option is a functor: can define map *)
Definition mapOption {A B : Type} (f: A -> B) (oa : option A) : option B :=
  match oa with
    | None   => None
    | Some a => Some (f a)
  end.

(* option is a functor: map respects isomorphisms *)
Lemma optionIso {A B : Type} : A ≅ B -> (option A) ≅ (option B).
Proof.
  intro isoAB.
  destruct isoAB as [ab ba abba baab].
  apply (MkIso _ _ (mapOption ab) (mapOption ba)).
  - intro ob; destruct ob as [ b | ]; simpl.
    + rewrite (abba b); reflexivity.
    + reflexivity.
  - intro oa; destruct oa as [ a | ]; simpl.
    + rewrite (baab a); reflexivity.
    + reflexivity.
Defined.

(* option induces an endofunction on FiniteType *)
Definition optionFinite : FiniteType -> FiniteType.
Proof.
  intro X.
  destruct X as [X [cardX isoX]].
  exists (option X).
  exists (S cardX).
  apply (optionFinIso ⇚).
  exact (optionIso isoX).
Defined.

(* to be done: define Hom, id, comp,... to make FiniteType
   a category and prove that optionFinite canonically extends
   to a functor, i.e. define map, prove id-, comp- and iso-preservation!
*)

(* any finite type is either isomorphic to False or isomorphic to
   optionFinite of some (Fin.t ..)
   need's a nicer formulation
   have to figure out how this can be used for
   "induction" analoguous to nat induction
 *)
Lemma decideFin (X : Type) (Xfin : Finite X) :
         (X ≅ (Fin.t 0)) + {n : nat & X ≅ (option (Fin.t n))}.
Proof.
  destruct Xfin as [cardX isoX].
  induction cardX.
  + left; exact isoX.
  + right.
    exists cardX.
    apply (optionFinIso ⇛).
    exact isoX.
Defined.

(* universal property of sum *)
Definition univSum {X Y Z : Type} (f : X -> Z) (g : Y -> Z) (xy: X + Y) : Z :=
  match xy with
      | inl x => f x
      | inr y => g y
  end.

(* \triangledown *)
Notation " f ▿ g " := (univSum f g) (at level 10).

(* sum is a functor in both arguments *)
Definition sumMap {X Y Z W : Type} (f : X -> Z) (g : Y -> W) :
                  (X + Y) -> (Z + W) := (inl ∘ f) ▿ (inr ∘ g).

(* \boxplus *)
Notation " f ⊞ g " := (sumMap f g) (at level 10).

(* towards optionSumIso *)

Fixpoint optionSumTo (X Y : Type) ( sumOXY : (option X) + Y) : option (X + Y) :=
  match sumOXY with
      | (inl None)      => None
      | (inl (Some x))  => Some (inl x)
      | (inr y)         => Some (inr y)
  end.

Fixpoint optionSumFrom (X Y : Type) (oSumXY : option (X + Y)) : (option X) + Y :=
  match oSumXY with
      | None            => inl None
      | Some (inl x)    => inl (Some x)
      | Some (inr y)    => inr y
  end.

Lemma optionSumIso (X Y : Type) : ((option X) + Y) ≅ (option (X + Y)).
Proof.
  apply (MkIso _ _ (optionSumTo X Y) (optionSumFrom X Y)).
  + intro oxy; destruct oxy as [xy | ].
    - destruct xy; simpl; reflexivity.
    - simpl; reflexivity.
  + intro oxy; destruct oxy as [ox | y].
    - destruct ox as [x | ]; simpl; reflexivity.
    - simpl; reflexivity.
Defined.

(* sum is commutative (up to iso) *)
Lemma sumCommutative (X Y : Type) : (X + Y) ≅ (Y + X).
Proof.
  apply (MkIso (X + Y) (Y + X) (inr ▿ inl) (inr ▿ inl));
  intro xy; destruct xy; simpl; reflexivity.
Defined.

(* sum is a functor: it respects isomorphisms *)
Lemma sumIso {X Y Z W : Type} : X ≅ Y -> Z ≅ W -> (X + Z) ≅ (Y + W).
Proof.
  intros isoXY isoZW.
  destruct isoXY as [xy yx xyyx yxxy].
  destruct isoZW as [zw wz zwwz wzzw].
  apply (MkIso _ _ (xy ⊞ zw) (yx ⊞ wz)).
  + intro sumYW; destruct sumYW as [y | w].
    - compute; rewrite (xyyx y); reflexivity.
    - compute; rewrite (zwwz w); reflexivity.
  + intro sumXZ; destruct sumXZ as [x | z].
    - compute; rewrite (yxxy x); reflexivity.
    - compute; rewrite (wzzw z); reflexivity.
Defined.

(* name cases where iso on one side is identity *)
Definition sumIsoLeft {X Y : Type} (Z : Type) (isoXY: X ≅ Y) :
    (X + Z) ≅ (Y + Z) := (sumIso isoXY (idIso Z)).

Definition sumIsoRight {X Y : Type} (Z : Type) (isoXY: X ≅ Y) :
    (Z + X) ≅ (Z + Y) := (sumIso (idIso Z) isoXY).

(* (Fin.t 0) is uninhabited, i.e. isomorphic to False *)
Lemma falseFromFin0 (x : Fin.t 0) : False.
Proof.
  dependent destruction x.
Defined.

Lemma isoFalseFin0 : False ≅ (Fin.t 0).
Proof.
  apply (MkIso _ _ (False_rect (Fin.t 0)) falseFromFin0).
  + intro x; dependent destruction x.
  + intro a; destruct a.
Defined.

(* in particular, False is Finite *)
Lemma falseIsFinite : Finite False.
Proof.
   exists 0.
   exact isoFalseFin0.
Defined.

(* (Fin.t 1) is isomorphic to True *)
Lemma isoTrueFin1 : True ≅ (Fin.t 1).
Proof.
  apply (MkIso _ _ (fun _ => F1) (fun _ => I)).
  + intro i.
    dependent destruction i.
    - reflexivity.
    - dependent destruction i.
  + intro a; destruct a; reflexivity.
Defined.

Lemma trueIsFinite : Finite True.
Proof.
  exists 1.
  exact isoTrueFin1.
Defined.

(* False is neutral element for + *)
Lemma sumFalseIso (X : Type) : (False + X) ≅ X.
Proof.
  apply (MkIso _ _ ((False_rect X) ▿ id) inr).
  + intro x; simpl; reflexivity.
  + intro fx; destruct fx as [f | x].
    - destruct f.
    - simpl; reflexivity.
Defined.

(* (Fin.t 0) is also neutral for + *)
Lemma sumFin0Iso (X : Type) : ((Fin.t 0) + X) ≅ X.
Proof.
  apply (sumFalseIso _ ⇛).
  exact (sumIsoLeft _ (symIso isoFalseFin0)).
Defined.

(* adding (Fin.t 1) is option (up to iso) *)

Fixpoint sumFin1IsoTo (X : Type) (t1X : (Fin.t 1) + X) : (option X) :=
   match t1X with
   | inl _ => None
   | inr x => Some x
   end.

Fixpoint sumFin1IsoFrom (X : Type) (OX : option X) : (Fin.t 1) + X  :=
   match OX with
   | None   => inl F1
   | Some x => inr x
   end.

Lemma sumFin1Iso (X : Type) : ((Fin.t 1) + X) ≅ (option X).
Proof.
  apply (MkIso _ _ (sumFin1IsoTo X) (sumFin1IsoFrom X)).
  + intro OX; destruct OX; simpl; reflexivity.
  + intro sumt1X; destruct sumt1X as [t | x].
    - simpl.
      dependent destruction t.
      * reflexivity.
      * dependent destruction t.
    - simpl; reflexivity.
Defined.

Lemma sumFin1FinNIso (n : nat) : ((Fin.t 1) + (Fin.t n)) ≅ (Fin.t (S n)).
Proof.
  apply (optionFinIso ⇚).
  exact (sumFin1Iso _).
Defined.

(* the sum of two finite types is finite *)

Lemma sumIsFiniteLemma (n m : nat) : forall (X Y : Type),
                          (X ≅ (Fin.t n)) -> (Y ≅ (Fin.t m)) ->
                          ((X + Y) ≅ (Fin.t (n + m))).
Proof.
  induction n.
  + intros X Y isoXt0 isoYtm.
    simpl.
    apply ((sumFalseIso _) ⇛).
    apply ((sumIsoLeft _ isoFalseFin0) ⇚).
    exact (sumIso isoXt0 isoYtm).
  + intros X Y isoXtSn isoYtm.
    apply ((@optionFinIso (n + m)) ⇚).
    apply ((optionIso (IHn _ _ (idIso (Fin.t n)) (idIso (Fin.t m)))) ⇛).
    apply ((optionSumIso _ _) ⇛).
    apply ((sumIsoLeft _ optionFinIso) ⇛).
    exact (sumIso isoXtSn isoYtm).
Defined.

Lemma sumIsFinite (X Y : Type) (Xfin : Finite X) (Yfin : Finite Y) : Finite (X + Y).
Proof.
  destruct Xfin as [cardX isoX].
  destruct Yfin as [cardY isoY].
  apply (MkFinite _ (cardX + cardY)).
  apply (sumIsFiniteLemma cardX cardY X Y isoX isoY).
Defined.

Fixpoint sumFinite (X Y : FiniteType) : FiniteType.
Proof.
   destruct X as [X Xfin].
   destruct Y as [Y Yfin].
   exists (sum X Y).
   exact (sumIsFinite X Y Xfin Yfin).
Defined.

(* towards prodFinite *)
(* universal property of prod *)

Definition univProd {X Y Z : Type} (f : X -> Y) (g : X -> Z) (x : X) : Y * Z := (f x , g x).

(* \triangle *)
Notation " f ▵ g " := (univProd f g) (at level 10).

(* prod is a functor in both arguments *)

Definition prodMap {X Y Z W : Type} (f : X -> Z) (g : Y -> W) :
                              (X * Y) -> (Z * W) := (f ∘ fst) ▵ (g ∘ snd).

(* \boxtimes *)
Notation " f ⊠ g " := (prodMap f g) (at level 10).

(* prod is commutative (up to iso) *)
Lemma prodCommutative (X Y : Type) : (X * Y) ≅ (Y * X).
Proof.
  apply (MkIso (X * Y) (Y * X) (snd ▵ fst) (snd ▵ fst));
  intro pair; destruct pair; simpl; reflexivity.
Defined.

(* prod is a functor: it respects isomorphisms *)
Lemma prodIso {X Y Z W : Type} : X ≅ Y -> Z ≅ W -> (X * Z) ≅ (Y * W).
Proof.
  intros isoXY isoZW.
  destruct isoXY as [xy yx xyyx yxxy].
  destruct isoZW as [zw wz zwwz wzzw].
  apply (MkIso _ _ (xy ⊠ zw) (yx ⊠ wz)).
  + intro pairYW; destruct pairYW as [y w];
    compute; rewrite (xyyx y); rewrite (zwwz w); reflexivity.
  + intro pairXZ; destruct pairXZ as [x z];
    compute; rewrite (yxxy x); rewrite (wzzw z); reflexivity.
Defined.

Definition prodIsoLeft {X Y : Type} (Z : Type) (isoXY : X ≅ Y) :
                  (X * Z) ≅ (Y * Z) := prodIso isoXY (idIso Z).

Definition prodIsoRight {X Y : Type} (Z : Type) (isoXY : X ≅ Y) :
                  (Z * X) ≅ (Z * Y) := prodIso (idIso Z) isoXY.

(* product with False is False *)
Lemma prodFalseIso (X : Type) : (False * X) ≅ False.
Proof.
  apply (MkIso _ _ fst (id ▵ (False_rect X))).
  + intro f; destruct f.
  + intro fx; destruct fx as [f x]. destruct f.
Defined.

(* True is neutral for prod *)
Lemma prodTrueIso (X : Type) : (True * X) ≅ X.
Proof.
  apply (MkIso _ _ snd ((fun _ => I) ▵ id)).
  + intro x; simpl; reflexivity.
  + intro tx; destruct tx as [t x]; destruct t; simpl; reflexivity.
Defined.

(* product distributes over sum *)

Definition prodDistSumIsoTo (X Y Z : Type) (xyz : X * (Y + Z)) : (X * Y) + (X * Z) :=
  match xyz with
  | (x , inl y) => inl (x , y)
  | (x , inr z) => inr (x , z)
  end.

Lemma prodDistSumIsoLeft (X Y Z : Type) : (X * (Y + Z)) ≅ ((X * Y) + (X * Z)).
Proof.
  apply (MkIso _ _ (prodDistSumIsoTo X Y Z) ((id ⊠ inl) ▿ (id ⊠ inr))).
  + intro sumXYXZ; destruct sumXYXZ as [pair | pair];
    destruct pair; simpl; reflexivity.
  + intro pairXSumYZ.
    destruct pairXSumYZ as [x [y | z]]; simpl; reflexivity.
Defined.

Lemma prodDistSumIsoRight (X Y Z : Type) : ((Y + Z) * X) ≅ ((Y * X) + (Z * X)).
Proof.
  apply (⇚ (prodCommutative X (Y + Z))).
  apply ((sumIso (prodCommutative X Y) (prodCommutative X Z)) ⇛).
  exact (prodDistSumIsoLeft X Y Z).
Defined.

Lemma prodIsFiniteLemma (n m : nat) : forall (X Y : Type),
        (X ≅ (Fin.t n)) -> (Y ≅ (Fin.t m)) -> ((X * Y) ≅ (Fin.t (n * m))).
Proof.
  induction n.
  + intros X Y isoXt0 isoYtm.
    simpl.
    apply (isoFalseFin0 ⇛).
    apply ((prodFalseIso (Fin.t m)) ⇛).
    apply ((prodIsoLeft _ isoFalseFin0) ⇚).
    exact (prodIso isoXt0 isoYtm).
  + intros X Y isoXtSn isoYtm.
    apply ((sumIsFiniteLemma _ _ _ _ (idIso (Fin.t m))
                                     (idIso (Fin.t (n * m)))) ⇛).
    apply ((sumIsoRight _  (IHn (Fin.t n) (Fin.t m) (idIso _) (idIso _))) ⇛).
    apply ((sumIsoLeft _ (prodTrueIso (Fin.t m))) ⇛).
    apply ((sumIsoLeft _ (prodIsoLeft _ isoTrueFin1)) ⇚).
    apply ((prodDistSumIsoRight _ _ _) ⇛).
    apply ((prodIsoLeft _ (sumFin1FinNIso n)) ⇚).
    exact (prodIso isoXtSn isoYtm).
Defined.

Lemma prodIsFinite (X Y : Type) (Xfin : Finite X) (Yfin : Finite Y) : Finite (X * Y).
Proof.
   destruct Xfin as [cardX isoX].
   destruct Yfin as [cardY isoY].
   apply (MkFinite _ (cardX * cardY)).
   apply (prodIsFiniteLemma cardX cardY X Y isoX isoY).
Defined.

Lemma prodFinite (X Y : FiniteType) : FiniteType.
Proof.
   destruct X as [X Xfin].
   destruct Y as [Y Yfin].
   exists (prod X Y).
   exact (prodIsFinite X Y Xfin Yfin).
Defined.

(* now for the exponential:

   problem: we cannot show that for finite X and Y
   X -> Y is finite:

   The cardinality should of course be cardY ^ cardX. But then already for
   X ≅ t 0 ≅ False, we would have to show that there is exactly one map
   False -> Y for any type Y, so we'd have to show that any map
   False -> Y is equal to False_rect Y, and since we don't have function
   extensionality, there is no chance to do that.

   Instead, we define Hom for finite types X, Y to be
          Hom X Y  :=  Vect.t Y cardX

   That looks strange since the right hand side does not depend
   on X itself, but only on its cardinality.

   However, since the finite set X comes with an isomorphisms to (t cardX),
   we can define maps

       X -> Y   --- toHom --->   Hom X Y
                <-- fromHom --

   Without function extensionality, we cannot prove

            fromHom . toHom = id (X -> Y).

   But it should be possible to prove

            toHom . fromHom = id (Hom X Y).

   And it shouldn't be hard to prove

            (Vect Y cardX ) ≅ t (cardY ^ cardX)),

   i.e. Hom X Y finite for finite X and Y.
 *)

(* first, we define a type for Hom *)
Definition HomFinT (X Y : FiniteType) : Type.
Proof.
  destruct X as [X [cardX isoX]].
  destruct Y as [Y [cardY isoY]].
  exact (Vector.t Y cardX).
Defined.

SearchAbout "nth".
Print VectorDef.nth.
Print VectorDef.nil.
Print VectorDef.cons.

Print "::".
SearchPattern (nat -> nat -> nat).

(* towards vectProdIso *)

Fixpoint vectProdTo (X : Type) (n : nat) (v : Vector.t X (S n)) : X * (Vector.t X n) :=
  match v with
  | (VectorDef.cons _ x _ xs) => (x , xs)
  end.

Fixpoint vectProdFrom (X : Type) (n : nat) (p : X * (Vector.t X n)) : Vector.t X (S n) :=
  match p with
  | (x , xs) => VectorDef.cons X x n xs
  end.

Lemma vectProdIso (X : Type) (n : nat) : (Vector.t X (S n)) ≅ (X * (Vector.t X n)).
Proof.
  apply (MkIso _ _ (vectProdTo X n) (vectProdFrom X n)).
  + intro pair.
    destruct pair as [x v].
    dependent destruction v; simpl; reflexivity.
  + intro v.
    dependent destruction v.
    dependent destruction v; simpl; reflexivity.
Defined.

Fixpoint lemma1To (X : Type) (v : Vector.t X 0) : Fin.t 1 :=
  match v with
  | nil _ => F1
  end.

Lemma lemma1From (X : Type) (i : Fin.t 1) : Vector.t X 0.
Proof.
  exact (nil X).
Defined.

Lemma lemma (n m : nat) : (Vector.t (Fin.t n) m) ≅ (Fin.t (n ^ m)).
Proof.
  induction m.
  + simpl.
    apply (MkIso _ _ (lemma1To (Fin.t n)) (lemma1From (Fin.t n))).
    - intro f; dependent destruction f.
      * simpl; reflexivity.
      * dependent destruction f; simpl.
    - intro v; simpl; dependent destruction v; reflexivity.
  + apply (transIso (prodIsFiniteLemma n (n ^ m)
                        (Fin.t n) (Fin.t (n ^ m)) (idIso _) (idIso _))).
    apply (transIso (prodIsoRight (Fin.t n) IHm)).
    exact (vectProdIso (Fin.t n) m).
Defined.