(** * The Z property implies Confluence

  An ARS, say $(A,R)$, is defined as a pair composed of a set $A$ and
  binary relation over this set $R:A\times A$. Let $a,b\in A$. We
  write $a\to_R b$ (or $R\ a\ b$ in Coq) to denote that $(a,b)\in R$,
  and we say that $a$ $R$-reduces to $b$ in one step. The reflexive
  transitive closure of a relation [R], written as $\tto_R$, is
  defined by the following inference rules: %\begin{mathpar}
  \inferrule*[Right={$(refl)$}]{~}{a \tto_R a} \and
  \inferrule*[Right={$(rtrans)$}]{a\to_R b \and b \tto_R c}{a \tto_R
  c} \end{mathpar}% %\noindent% where $a,b$ and $c$ are universally
  quantified variables as one makes explicit in the corresponding Coq
  definition: *)
(* begin hide *)
Definition Rel (A:Type) := A -> A -> Prop.

Inductive trans {A} (red: Rel A) : Rel A :=
| singl: forall a b,  red a b -> trans red a b
| transit: forall b a c,  red a b -> trans red b c -> trans red a c.

Arguments transit {A} {red} _ _ _ _ _ .

Lemma trans_composition {A} (R: Rel A):
  forall t u v, trans R t u -> trans R u v -> trans R t v.
Proof.
  intros t u v H1 H2. induction H1.
  - apply transit with b; assumption.
  - apply transit with b.
    + assumption.
    + apply IHtrans; assumption.
Qed.

(**
Lemma transit' {A:Type} (R: Rel A):
  forall t u v, trans R t u -> R u v -> trans R t v.
Proof.
  intros t u v H1 H2. induction H1.
  - apply transit with b.
    + assumption.
    + apply singl.
      assumption.
  - apply IHtrans in H2.
    apply transit with b; assumption.
Qed.

Lemma trans_composition' {A} (R: Rel A):
  forall t v, trans R t v -> (R t v \/ exists u, trans R t u /\ R u v).
Proof.
 intros t v H.
 induction H.
 - left; assumption.
 - right.
   destruct IHtrans.
   + exists b.
     split.
     * apply singl.
       assumption.
     * assumption.
   + destruct H1.
     exists x.
     split.
     * apply transit with b.
       ** assumption.
       ** apply H1.
     * apply H1.
Qed. *)
(* end hide *)

Inductive refltrans {A:Type} (R: Rel A) : A -> A -> Prop :=
| refl: forall a, (refltrans R) a a
| rtrans: forall a b c, R a b -> refltrans R b c -> refltrans R a c.

(** The rules named ([refl]) and ([rtrans]) are called _constructors_
in the Coq definition. The first constructor, namely [refl], states
the reflexivity axiom for $\tto_R$, while [rtrans] extends the
reflexive transitive closure of [R], if one has at least a one-step
reduction. As a first example, let's have a look at the proof of
transitivity of $\tto_R$:

%\begin{lemma} Let $\to_R$ be a binary relation over a set $A$. For
all $t, u, v \in A$, if $t \tto_R u$ and $u \tto_R v$ then $t \tto_R
v$.  \end{lemma}%

 Despite its simplicity, the proof of this lemma will help us explain
the way in which we will relate English annotations with the proof
steps. Coq proofs are written between the reserved words [Proof] and
[Qed] (lines 1 and 9), and each proof command finishes with a
dot. Proofs can be structured with bullets (- in the first level, + in
the second level, * in the third level, ** in the fourth level, and so
on). The corresponding informal proof proceed as follows: The
corresponding lemma in Coq, named [refltrans_composition], is stated
as follows: *)

Lemma refltrans_composition {A} (R: Rel A): forall t u v, refltrans R t u -> refltrans R u v -> refltrans R t v.
Proof.
  intros t u v. (** %\comm{Let $t,u,v$ be elements of $A$.}% *)

  intros H1 H2. (** %\comm{Let $H1$ (respectively, $H2$) be the hipothesis that $t \tto_R   u$ (respectively, $u \tto_R v$).}% *)

  induction H1. (** %\comm{The proof procceds by induction on the
    hipothesis $H1$. Therefore there is one case for each constructor
    of the reflexive transitive closure of $R$. The structure of the
    proof context determines the shape of the induction hypothesis,
    and this fact will be essential to understand the inductive proof
    of the next theorem.}% *)

  - assumption. (** %\comm{For the base case, which corresponds to the rule $refl$, $t$ and $u$ are the same element and hence the goal coincides with the hipothesis $H2$.}% *)

  - apply rtrans with b. (** %\comm{For the inductive case, $t \tto_R
    u$ is build from $t \to_R b$ and $b \tto_R u$, for some $b$, and
    as induction hipothesis one has that $b \tto_R v$. Therefore, one
    can prove that $t \tto_R v$ by applying the rule ($rtrans$) with
    $b$ as the intermediary term:

\begin{mathpar} \inferrule*[Right={$(rtrans)$}]{t\to_R b \and b \tto_R
  v}{t \tto_R v} \end{mathpar}

 We have then two subproofs:}% *)

    + assumption. (** %\comm{The proof that $t\to_R b$ is one of the hipothesis, and we are done.}% *)

    + apply IHrefltrans; assumption.  (** %\comm{The proof that
$b\tto_R v$ is obtained from the induction hipothesis, and this proof
can be better visualized by the corresponding deduction tree:

\begin{mathpar}
\inferrule*[Right={$MP$}]{
\inferrule*[Right={$IH$}]{~}{b\tto_R u \to b\tto_R v} \and
\inferrule*[Right={H2}]{~}{b\tto_R u}}{b\tto_R v}
\end{mathpar} }% *)

Qed.
(* begin hide *)
(**
<<
1. Proof.
2.  intros t u v.
3.  intros H1 H2.
4.  induction H1.
5.  - assumption.
6.  - apply rtrans with b.
7.  + assumption.
8.  + apply IHrefltrans; assumption.
9. Qed.
>>

This work is not a Coq tutorial, but our idea is that it should
also be readable for those unfamiliar with the Coq proof Assistant. In
addition, this paper is built directly from a Coq proof script, which
means that we are forced to present the ideas and the results in a
more organized and systematic way that is not necessarily the more
pedagogical one. *)

(** %{\bf Proof}.%

    Let $t, u, v \in A$, i.e. they are elements of type [A], or
    elements of the set [A] (line 2). Call [H1] (resp. [H2]) the
    hypothesis that $t \tto_R u$ (resp. $u\tto_R v$) (line 3). The
    proof proceeds by induction on the hypothesis [H1] (line 4),
    i.e. by induction on $t \tto_R u$. The structure of the proof
    context determines the shape of the induction hypothesis, and this
    fact will be essential to understand the inductive proof of the
    next theorem. As shown in Figure %\ref{fig:trans}%, [H1] and [H2]
    are the only hypothesis (the other lines are just declaration of
    variables), therefore the induction hypothesis subsumes [H2].

      %\begin{figure}[h] \centering
        \includegraphics[scale=0.6]{fig1.png} \caption{Transitivity of
        $\tto_R$}\label{fig:trans} \end{figure}%

    The first case is when $t \tto_R u$ is generated by the
    constructor [refl], which is an axiom and hence we are done (line
    5).  The second case, i.e. the recursive case is more interesting
    because $t \tto_R u$ is now generated by [rtrans] (line 6). This
    means that there exists an element, say $b$, such that $t \to_R b$
    and $b \tto_R u$. Therefore, in order to prove that $t \tto_R u$,
    we can apply the rule [rtrans] taking [b] as the intermediary
    term. The proof of the recursive case can be better visualized by
    the corresponding deduction tree: %{\scriptsize \begin{mathpar}
    \inferrule*[Right=MP]{\inferrule*[Right=MP]{\inferrule*[Right={
    $rtrans$}]{~}{\inferrule*[Right={$(\forall_e)$}]{\forall x\ y\ z,
    x\to_R y \to y\tto_R z \to x\tto_R z}{t\to_R b \to b\tto_R u \to
    t\tto_R u}} \and \inferrule*[Right={H}]{~}{t\to_R b}}{ b\tto_R u
    \to t\tto_R u} \and \inferrule*[Right=MP]{\inferrule*[Right={
    $IH$}]{~}{u\tto_R v \to b\tto_R u} \and
    \inferrule*[Right={H2}]{~}{u\tto_R v}}{b\tto_R u}}{t\tto_R u}
    \end{mathpar}}%

    Each branch of the above tree corresponds to a new goal in the Coq
    proof. Therefore, we have two subcases (or subgoals) to prove: In
    this subgoal we need to prove that $t \to_R b$, which we have as
    hypothesis (line 7). In the second subgoal (line 8), we need to
    prove that $b \tto_R u$. To do so, we apply the induction
    hypothesis [IHrefltrans]: $u \tto_R v \to b \tto_R u$, where
    $u\tto_R v$ is the hypothesis [H2]. $\hfill\Box$ *)
(* end hide *)

(** This example is interesting because it shows how Coq works, how
each command line (also known as tactics or tacticals depending on its
structure) corresponds, in general, to several steps of natural
deduction rules. *)

(* begin hide *)
Lemma refltrans_composition2 {A} (R: Rel A): forall t u v, refltrans R t u -> R u v -> refltrans R t v.
Proof.
  intros t u v H1 H2. induction H1.
  - apply rtrans with v.
    + assumption.
    + apply refl.
  - apply IHrefltrans in H2.
    apply rtrans with b; assumption.
Qed.

Lemma trans_to_refltrans {A:Type} (R: Rel A): forall a b, trans R a b -> refltrans R a b.
Proof.
  intros a b Htrans.
  induction Htrans.
  - apply rtrans with b.
    + assumption.
    + apply refl.
  - apply rtrans with b; assumption.
Qed.
(* end hide *)

(** The reflexive transitive closure of a relation is used to define
    the notion of confluence: no matter how the reduction is done, the
    result will always be the same. In other words, every divergence
    is joinable as stated by the following diagram:

    $\centerline{\xymatrix{ & a \ar@{->>}[dl] \ar@{->>}[dr] & \\ b
    \ar@{.>>}[dr] & & c \ar@{.>>}[dl] \\ & d & }}$

    Formally, this means that if an expression $a$ can be reduced in
    two different ways to the expressions $b$ and $c$, then there
    exists an expression $d$ such that both $b$ and $c$ reduce to
    $d$. The existential quantification is expressed by the dotted
    lines in the diagram. This notion is defined in the Coq system as
    follows: *)

Definition Confl {A:Type} (R: Rel A) := forall a b c, (refltrans R) a b -> (refltrans R) a c -> (exists d, (refltrans R) b d /\ (refltrans R) c d).

(** In %\cite{dehornoy2008z}%, V. van Oostrom gives a sufficient
    condition for an ARS to be confluent, known as the _Z Property_:

    %\begin{definition} Let $(A,\to_R)$ be an ARS. Then $(A,\to_R)$
      has the Z property, if there exists a map $f:A \to A$ such that
      the following diagram holds:

      \[ \xymatrix{ a \ar[r]_R & b \ar@{.>>}[dl]^R\\ f(a)
      \ar@{.>>}[r]_R & f(b) \\ } \] \end{definition}%

The corresponding Coq definition is given as: *)

Definition Z_prop {A:Type} (R: Rel A) := exists f:A -> A, forall a b, R a b -> ((refltrans R) b (f a) /\ (refltrans R) (f a) (f b)).

(** Alternatively, for a given function [f], one can say that [f] satisfies the Z property, or that [f] is Z, if the above conditions hold for [f]: *)

Definition f_is_Z {A:Type} (R: Rel A) (f: A -> A) := forall a b, R a b -> ((refltrans R)  b (f a) /\ (refltrans R) (f a) (f b)).

(** The first contribution of this work is a constructive proof of the
    fact that the Z property implies confluence. Our proof uses nested
    induction, and hence it differs from the one in %\cite{kes09}%
    (that follows %\cite{dehornoy2008z}%) and the one in %\cite{zproperty}%
    in the sense that it does not rely on analyzing whether
    a term is in normal form or not, avoiding necessity of
    the law of the excluded middle . As a result, we have
    an elegant inductive proof of the fact that if a binary relation
    has the Z property then it is confluent. In addition, we
    formalized this proof in the Coq proof assistant. In
    %\cite{zproperty}%, B. Felgenhauer et.al. formalized in Isabelle/HOL
    the Z property and its relation to confluence.
    In what follows, we present the theorem
    and its proof interleaving Coq code and the corresponding
    comments. *)

Theorem Z_prop_implies_Confl {A:Type}: forall R: Rel A, Z_prop R -> Confl R.
Proof.
  intros R HZ_prop. (** %\comm{Let $R$ be a relation over $A$ that satisfies
    the Z property, which will be denoted by $HZ\_prop$ for future
    reference.}% *)

  unfold Z_prop, Confl in *. (** %\comm{Unfolding both definitions of
  $Z\_prop$ and $Confl$, we get the following proof context:

     \includegraphics[scale=0.5]{fig3.png} }% *)

  intros a b c Hrefl1 Hrefl2. (** %\comm{Let $a, b$ and $c$ be elements of
     the set $A$, $Hrefl1$ the hypothesis that $a \tto_R b$, and
     $Hrefl2$ the hypothesis that $a\tto_R c$. We need to prove that
     there exists $d$ such that $b\tto_R d$ and $c\tto_R d$.}% *)

  destruct HZ_prop as [g HZ_prop]. (** %\comm{We know from the hypothesis
     $HZ\_prop$ that there exists a mapping $f$ that is Z. Let's call
     $g$ this mapping, and we get following proof context:

      %\includegraphics[scale=0.6]{fig4.png}%

      The proof proceeds by nested induction, firstly on the length of
      the reduction from $a$ to $b$, and then on the length of the
      reduction from $a$ to $c$.}% *)

  generalize dependent c. (** %\comm{Before the first induction,
      i.e. induction on $Hrefl1$, the element $c$ needs to be
      generalized so that it can be afterwards instantiated with any
      reduct of $a$.}% *)

  induction Hrefl1. (** %\comm{The induction on $Hrefl1$ corresponds to
       induction on the reflexive transitive closure of the relation
       $R$, and since $refltrans$ has two rules, the goal splits in
       two subgoals, one for each possible way of constructing $a
       \tto_R b$.}% *)

  - intros c Hrefl2. (** %\comm{In the first case, we have that $b = a$ since
    we are in the reflexive case. This means that we have to prove
    that there exists $d$, such that $a \tto_R d$ and $c \tto_R d$.}% *)

    exists c; split. (** %\comm{Taking $d$ as $c$, the proof is simplified to $a
    \tto_R c$ and $c \tto_R c$.}% *)

    + assumption. (** %\comm{The first component is exactly the hypothesis
        $Hrefl2$ and }% *)

    + apply refl. (** %\comm{$c \tto_R c$ corresponds to an application of
        the $refl$ axiom.}% *)

        (** The interesting part of the proof is then given by the
        inductive case, i.e. when $a\tto_R b$ is generated by the rule
        [(rtrans)]. In this case, the reduction from [a] to [b] is
        done in at least one step, therefore there must exists an
        element $a'$ such that the following diagram holds.

        % \[\xymatrix{ & & a \ar@{->}[dl] \ar@{->>}[dr] & \\ & a'
        \ar@{->>}[dl] & & c \ar@{.>>}[ddll] \\ b \ar@{.>>}[dr] & & &
        \\ & d & & }\] %

        (* The corresponding proof context is as follows:

        %\includegraphics[scale=0.6]{fig5.png}% *)

        The induction hypothesis states that every divergence from
        $a'$ that reduces to $b$ from one side converges: [IHHrefl1]
        : $\forall c_0 : A, a'\tto_R c_0 \to (\exists d : A, b\tto_R d
        \land c_0\tto_R d$). Now, we'd like apply induction on the
        hypothesis [Hrefl2] (a\tto_R c), but the current proof context has the
        hypothesis [H]: $a\to_R a'$ ([a] reduces to [a'] in one step),
        and hence it is the sole hypothesis depending on [a] in the
        current proof context. If we were to apply induction on [Hrefl2] now,
        the generated induction hypothesis [IHrefl2] would assume that there is
        a term $a''$ such that $a \to_R a'' \tto_R c$ and would require that
        $a'' \to_R a'$, which is generally false. In order to circumvent
        this problem, we need to discard the hypothesis [H] from our proof
        context, and replace it by another relevant information derived from
        the Z property as shown in what follows. *)

  - intros c0 Hrefl2. (** %\comm{Let $c_0$ be a reduct of $a$, and $Hrefl2$
    be the hypothesis $a \tto_R c_0$. So the reduction $a\tto_R c$ in
    the above diagram is now $a\tto_R c_0$ due to a renaming of
    variables automatically done by the Coq system. In addition, the
    reduction $a \to_R a' \tto_R b$ is now $a\to_R b \tto_R c$, as
    shown below:

    \includegraphics[scale=0.5]{fig5-1.png}

    Before applying induction to $Hrefl2$: $a \tto_R c_0$, we will derive
    $b\tto_R (g\ a)$ and $a\tto_R (g\ a)$ from the proof context so we can
    discard the hypothesis $H$: $a\to_R$.}% *)

    assert (Hbga: refltrans R b (g a)).
    { apply HZ_prop; assumption.  } (** %\comm{We call $Hbga$ the reduction
    $b\tto_R (g\ a)$ that is directly obtained from the Z property.}% *)

    assert (Haga: refltrans R a (g a)).
    { apply rtrans with b; assumption.  } (** %\comm{Call $Haga$ the
        reduction $a\tto_R (g\ a)$, and prove it using the
        transitivity of $\tto_R$, since $a \to_R b$ and $b \tto_R (g\
        a)$. Diagrammatically, we change from the situation on the
        top to the bottomone on the right:

        \xymatrix{ & & a \ar@{->>}[ddrr]_R \ar@{->}[dl]^R & & \\ & b
        \ar@{->>}[dl]^R & & & \\ c \ar@{.>>}[ddrr]_R & & & & c_0
        \ar@{.>>}[ddll]^R \\ & & & & \\ & & d & & }

        \xymatrix{ & & a \ar@{->>}[ddrr]_R \ar@{->>}[dd]_R & & \\ & b
        \ar@{->>}[dl]^R \ar@{->>}[dr]_R & & & \\ c \ar@{.>>}[ddrr]_R &
        & (g \; a) & & c_0 \ar@{.>>}[ddll]^R \\ & & & & \\ & & d & &} }% *)

    clear H. generalize dependent b. (** %\comm{At this point we can remove
      the hypothesis $H$ from the context, and generalize $b$. Doing so,
      we generalize $IHHrefl1$, which, in conjunction with the hypotheses
      that depend on a (namely, $Hrefl2$, $Hbga$, and $Haga$), will form
      the four necessary conditions for use of the second inductive
      hypothesis, $IHHrefl2$.}% *)

    induction Hrefl2. (** %\comm{Now we are ready to start the induction on
    the reduction $a\tto_R c_0$, and we have two subgoals.}% *)

    + intros b Hrefl1 IHHrefl1 Hbga. (** %\comm{The first subgoal corresponds
        to the reflexive case that is closed by the induction
        hypothesis $IHHrefl1$:

        \[\xymatrix{ & & a \ar@{->>}[dd]^{H2} & & \\ & b
        \ar@{->>}[dl]_{Hrefl1} \ar@{->>}[dr]^{H1} & & & \\ c
        \ar@{.>>}[dr] & IHHrefl1 & (g \; a) \ar@{.>>}[dl] & & \\ & d &
        &&}\] }% *)

      assert (IHHrefl1_ga := IHHrefl1 (g a));

        apply IHHrefl1_ga in Hbga. (** %\comm{In order to apply $IHHrefl1$, we instantiate $c_0$ with $(g\
      a)$.}% *)

      destruct Hbga. (** %\comm{Therefore, there exists an element, say $x$,
      such that both $c\tto_R x$ and $(g\ a) \tto_R x$.}% *)

      exists x; split. (** %\comm{We then take $x$ to show that $c\tto_R x$ and $a
      \tto_R x$.}% *)

      * apply H. (** %\comm{Note that $c\tto_R x$ is already an hypothesis,
        and we are done.}% *)

      * apply refltrans_composition with (g a);

        [assumption | apply H]. (**
      %\comm{The proof of $a \tto_R x$ is done by the transitivity of
      $\tto_R$ taking $(g\ a)$ as the intermediate step.}% *)

    + intros b0 Hrefl1 IHHrefl1 Hb0ga. (** %\comm{The second subgoal corresponds
        to the case in which $a\tto_R c_0$ is generated by the rule
        $(rtrans)$. Therefore, there exists a term $b$ such that
        $a\to_R b$ and $b \tto_R c_0$. The corresponding proof context
        after introducing the universally quantified variable $b0$,
        the hypothesis $Hrefl1$ and the induction hypothesis
        $IHHrefl1$ generated by the first outer induction and the fact
        that $b0 \tto_R (g\ a)$ is given by:

        \includegraphics[scale=0.48]{fig7.png} }% *)

      apply IHHrefl2 with b0. (** %\comm{The second goal, i.e. the inductive case is
      the consequent on $IHHrefl2$, so we can apply $IHHrefl2$ to prove it. Doing so,
      we must prove the antecedent of $IHHrefl2$, which consists of four separate
      hypotheses that we must prove. Those hypotheses are as follows:}% *)

      * apply refltrans_composition with (g a);

        apply HZ_prop; assumption. (** %\comm{1. $b \tto_R (g\ b)$: This is proved by the transitivity of the
      reflexive transitive closure of $R$ using the
      hypothesis (H: $a\to_R b$) and $HZ\_prop$: $\forall a\
      b: a \to_R b \to (b \tto_R (g\ a) \land (g\ a) \tto_R (g\ b))$.}% *)

      * assumption. (** %\comm{2. $b0 \tto_R c$: This is exactly the
          hypothesis $Hrefl1$.}% *)

      * assumption. (** %\comm{3. $\forall c0: b0 \tto_R c0 \to (\exists d:
            c \tto_R d \land c0 \tto_R d)$: This is exactly the
            induction hypothesis $IHHrefl1$.}% *)

      * apply refltrans_composition with (g a);
        [ assumption | apply HZ_prop; assumption]. (** %\comm{4. $b0 \tto_R (g\ b)$: This is proved by the transitivity of
      the reflexive transitive closure of $R$ using the
      hypothesis $H'$: $b0 \tto_R (g\ a)$ and the fact that
      $(g\ a) \tto_R (g\ b)$ that is obtained from the fact that
      $R$ satisfies the Z property (hypothesis
      $HZ\_prop$).}% *)

Qed.

(* Another proof

Lemma refltrans_f_is_Z_refltrans {A:Type}: forall (R: Rel A) a b f, f_is_Z R f -> (refltrans R) a b -> (refltrans R) (f a) (f b).
Proof.
  intros R a b f H Hab.
  unfold f_is_Z in H.
  induction Hab.
  - apply refl.
  - apply H in H0.
    destruct H0 as [H1 H2].
    apply refltrans_composition with (f b); assumption.
Qed.

Lemma refltrans_f_is_Z {A:Type}: forall (R: Rel A) a f, f_is_Z R f -> (refltrans R) a (f a).
Proof.
  intros R a f H.
  unfold f_is_Z in H.
Admitted.

  Theorem Z_prop_implies_Confl2 {A:Type}: forall R: Rel A, Z_prop R -> Confl R.
  Proof.
    intros R H.
    unfold Z_prop in H.
    destruct H as [g H].
    unfold Confl.
    intros a b c H1 H2.
    generalize dependent c.
    induction H1.
    - intros c H1.
      exists c; split.
      + assumption.
      + apply refl.
    - intros c0 H2.
      apply H in H0.
      destruct H0 as [Hga Hgb].
      assert (refltrans R (g a) (g c0)).
      {
        apply  refltrans_f_is_Z_refltrans.
        - assumption.
        - assumption.
      }
      assert (refltrans R c0 (g c0)).
      {
        apply refltrans_f_is_Z; assumption.
      }
      assert (refltrans R b (g c0)).
      {
        apply refltrans_composition with (g a); assumption.
      }
      apply IHrefltrans in H4.
      destruct H4 as [d [H4 H5]].
      exists d; split.
      +  assumption.
      + apply refltrans_composition with (g c0); assumption.
Qed. *)

(** An alternative proof that Z implies confluence is possible via the
    notion of semiconfluence, which is equivalent to confluence, as
    done in %\cite{zproperty}%. Unlike the proof in %\cite{zproperty}% and
    similarly to our previous proof, our proof of the Theorem that
    Z implies semiconfluence is constructive, but we
    will not explain it here due to lack of space; any
    interested reader can find it in the Coq file in our GitHub
    repository. *)

Definition SemiConfl {A:Type} (R: Rel A) := forall a b c, R a b -> (refltrans R) a c -> (exists d, (refltrans R) b d /\ (refltrans R) c d).

Theorem Z_prop_implies_SemiConfl {A:Type}: forall R: Rel A, Z_prop R -> SemiConfl R.
(* begin hide *)
Proof.
  intros R HZ_prop.
  unfold Z_prop in HZ_prop.
  unfold SemiConfl.
  destruct HZ_prop.
  intros a b c Hrefl Hrefl'.
  assert (Haxa: refltrans R a (x a)).
  { apply rtrans with b.  - assumption.  - apply H.  assumption.  }
  apply H in Hrefl.
  destruct Hrefl.
  clear H1.
  generalize dependent b.
  induction Hrefl'.
  - intros.
    exists (x a).
    split; assumption.
  - intros.
    destruct IHHrefl' with b0.
    + apply refltrans_composition with (x a); apply H; assumption.
    + apply refltrans_composition with (x b).
      * apply refltrans_composition with (x a).
        ** assumption.
        ** apply H.
           assumption.
      * apply refl.
    + exists x0.
      assumption.
Qed.
(* end hide *)

Theorem Semi_equiv_Confl {A: Type}: forall R: Rel A, Confl R <-> SemiConfl R.
(* begin hide *)
Proof.
  unfold Confl.
  unfold SemiConfl.
  intro R.
  split.
  - intros.
    apply H with a.
    + apply rtrans with b.
      * assumption.
      * apply refl.
    + assumption.
  - intros.
    generalize dependent c.
    induction H0.
    + intros.
      exists c.
      split.
      * assumption.
      * apply refl.
    + intros.
      specialize (H a).
      specialize (H b).
      specialize (H c0).
      apply H in H0.
      * destruct H0.
        destruct H0.
        apply IHrefltrans in H0.
        destruct H0.
        destruct H0.
        exists x0.
        split.
        ** assumption.
        ** apply refltrans_composition with x; assumption.
      * assumption.
Qed.
(* end hide *)

Corollary Zprop_implies_Confl_via_SemiConfl {A:Type}: forall R: Rel A, Z_prop R -> Confl R.
Proof. intros R HZ_prop. apply Semi_equiv_Confl. generalize dependent HZ_prop.
       apply Z_prop_implies_SemiConfl. Qed.

(** * An extension of the Z property: Compositional Z

    In this section we present a formalization of an extension of the
    Z property with compositional functions, known as _Compositional
    Z_, as presented in %\cite{Nakazawa-Fujita2016}%. The
    compositional Z is an interesting property because it allows a
    kind of modular approach to the Z property in such a way that the
    reduction relation can be split into two parts. More precisely,
    given an ARS $(A,\to_R)$, one must be able to decompose the
    relation $\to_R$ into two parts, say $\to_1$ and $\to_2$ such that
    $\to_R = \to_1\cup \to_2$. This kind of decomposition can be done
    in several interesting situations such as the $\lambda$-calculus
    with $\beta\eta$-reduction%\cite{Ba84}%, extensions of the
    $\lambda$-calculus with explicit substitutions%\cite{accl91}%, the
    $\lambda\mu$-calculus%\cite{Parigot92}%, etc. But before
    presenting the full definition of the Compositional Z, we need
    to define the _weak Z property_:

    %\begin{figure}[h] \centering \[ \xymatrix{ a \ar[r]_R & b
        \ar@{.>>}[dl]^x\\ f(a) \ar@{.>>}[r]_x & f(b) \\ } \]
        \caption{The weak Z property}\label{fig:weakZ} \end{figure}%

    %\begin{definition} Let $(A,\to_R)$ be an ARS and $\to_R'$ a
     relation on $A$. A mapping $f$ satisfies the {\it weak Z
     property} for $\to_R$ by $\to_R'$ if $a\to_R b$ implies $b \tto_R'
     f(a)$ and $f(a) \tto_R' f(b)$ (cf. Figure
     \ref{fig:weakZ}). Therefore, a mapping $f$ satisfies the Z
     property for $\to_R$ if it satisfies the weak Z property by
     itself.  \end{definition}%

    When $f$ satisfies the weak Z property, we also say that $f$ is
    weakly Z, and the corresponding definition in Coq is given as
    follows: *)

Definition f_is_weak_Z {A} (R R': Rel A) (f: A -> A) := forall a b, R a b -> ((refltrans R') b (f a) /\ (refltrans R') (f a) (f b)).

(** The compositional Z is an extension of the Z property for
compositional functions, where composition is defined as usual: *)

Definition comp {A} (f1 f2: A -> A) := fun x:A => f1 (f2 x).
Notation "f1 # f2" := (comp f1 f2) (at level 40).

(** %\noindent% and the disjoint union is inductively defined as: *)

Inductive union {A} (red1 red2: Rel A) : Rel A :=
| union_left: forall a b, red1 a b -> union red1 red2 a b
| union_right: forall a b, red2 a b -> union red1 red2 a b.
Notation "R1 !_! R2" := (union R1 R2) (at level 40).

(* begin hide *)
Lemma union_or {A}: forall (r1 r2: Rel A) (a b: A), (r1 !_! r2) a b <-> (r1 a b) \/ (r2 a b).
Proof.
  intros r1 r2 a b; split.
  - intro Hunion.
    inversion Hunion; subst.
    + left; assumption.
    + right; assumption.
  - intro Hunion.
    inversion Hunion.
    + apply union_left; assumption.
    + apply union_right; assumption.
Qed.
(* end hide *)

(** We are now ready to present the definition of the compositional Z:

    %\begin{theorem}\cite{Nakazawa-Fujita2016}\label{thm:zcomp} Let
     $(A,\to_R)$ be an ARS such that $\to_R = \to_1 \cup \to_2$. If
     there exists mappings $f_1,f_2: A \to A$ such that
     \begin{enumerate} \item $f_1$ is Z for $\to_1$ \item $a \to_1 b$
     implies $f_2(a) \tto f_2(b)$ \item $a \tto f_2(a)$ holds for any
     $a\in Im(f_1)$ \item $f_2 \circ f_1$ is weakly Z for $\to_2$ by
     $\to_R$ \end{enumerate} then $f_2 \circ f_1$ is Z for
     $(A,\to_R)$, and hence $(A,\to_R)$ is confluent.  \end{theorem}%

    We define the predicate [Z_comp] that corresponds to the premises
    of Theorem %\ref{thm:zcomp}%, i.e. to the conjunction of items
    (i), (ii), (iii) and (iv) in addition to the fact that $\to_R =
    \to_1 \cup \to_2$, where $\to_1$ (resp. $\to_2$) is written as
    [R1] (resp. [R2]): *)

Definition Z_comp {A:Type} (R :Rel A) := exists (R1 R2: Rel A) (f1 f2: A -> A), (forall x y, R x y <-> (R1 !_! R2) x y) /\ f_is_Z R1 f1 /\ (forall a b, R1 a b -> (refltrans R) (f2 a) (f2 b)) /\ (forall a b, b = f1 a -> (refltrans R) b (f2 b)) /\ (f_is_weak_Z R2 R (f2 # f1)).

(* begin hide *)
Lemma refltrans_union {A:Type}: forall (R R' :Rel A) (a b: A), refltrans R a b -> refltrans (R !_! R') a b.
Proof.
  intros R R' a b Hrefl.
  induction Hrefl.
  - apply refl.
  - apply rtrans with b.
    + apply union_left; assumption.
    + assumption.
Qed.
(* end hide *)

(** As stated by Theorem %\ref{thm:zcomp}%, the compositional Z gives
    a sufficient condition for compositional functions to be Z. In
    other words, compositional Z implies Z, which is justified by the
    diagrams of Figure %\ref{fig:zcomp}%.

    %\begin{figure}[h]\begin{tabular}{l@{\hskip 3cm}l} $\xymatrix{ a
    \ar@{->}[rr]^1 && b \ar@{.>>}[dll]_1\\ f_1(a)\ar@{.>>}[d]
    \ar@{.>>}[rr]^1 && f_1(b) \\ f_2(f_1(a)) \ar@{.>>}[rr] &&
    f_2(f_1(b)) }$ & $\xymatrix{ a \ar@{->}[rr]^2 && b
    \ar@{.>>}[ddll]\\ & & \\ f_2(f_1(a)) \ar@{.>>}[rr] && f_2(f_1(b))
    }$ \end{tabular}\caption{Compositional Z implies
    Z}\label{fig:zcomp}\end{figure}%

    In what follows, we present our commented Coq proof of this fact:
    *)

Lemma refltrans_union_equiv {A}: forall (R R1 R2 : Rel A) (x y : A), R x y <-> (R1 !_! R2) x y -> forall x y : A, refltrans (R1 !_! R2) x y -> refltrans R x y.
Proof.
Admitted.

Theorem Z_comp_implies_Z_prop {A:Type}: forall (R :Rel A), Z_comp R -> Z_prop R.
Proof.
  intros R H.
  unfold Z_prop. unfold Z_comp in H. destruct H as
  [ R1 [ R2 [f1 [f2 [Hunion [H1 [H2 [H3 H4]]]]]]]].
  exists (f2 # f1).
  intros a b HR.
  apply Hunion in HR. inversion HR; subst. clear HR.
  - split.
    + apply refltrans_composition with (f1 a).
      * apply H1 in H.
        destruct H as [Hb Hf].
        apply (refltrans_union R1 R2) in Hb.
        apply refltrans_union_equiv with R1 R2 b (f1 a).
        ** apply Hunion.
        ** apply Hb.
      * apply H3 with a; reflexivity.
    + apply H1 in H.  destruct H as [Hb Hf].
      clear Hb.  unfold comp.
      induction Hf.
      * apply refl.
      * apply refltrans_composition with (f2 b0).
        ** apply H2; assumption.
        ** apply IHHf.
  - apply H4; assumption.
Qed.

(** Now we can use the proofs of the theorems [Z_comp_implies_Z_prop]
and [Z_prop_implies_Confl] to conclude that compositional Z is a
sufficient condition for confluence. *)

Corollary Z_comp_is_Confl {A}: forall (R: Rel A), Z_comp R -> Confl R.
Proof.
  intros R H.
  apply Z_comp_implies_Z_prop in H.
  apply Z_prop_implies_Confl; assumption.
Qed.

(** Rewriting Systems with equations is another interesting and
    non-trivial topic %\cite{winkler89,terese03}%. The confluence of
    rewriting systems with an equivalence relation can also be proved
    by a variant of the compositional Z, known as Z property
    modulo%~\cite{AK12b}%.

    %\begin{theorem}\label{cor:zcomp} Let
     $(A,\to_R)$ be an ARS such that $\to_R = \to_1 \cup \to_2$. If
     there exist mappings $f_1,f_2: A \to A$ such that
     \begin{enumerate} \item $a \to_1 b$ implies $f_1(a) = f_1(b)$
     \item $a \tto_1 f_1(a), for all a$ \item $a \tto_R f_2(a)$ holds
     for any $a\in Im(f_1)$ \item $f_2 \circ f_1$ is weakly Z for
     $\to_2$ by $\to_R$ \end{enumerate} then $f_2 \circ f_1$ is Z for
     $(A,\to_R)$, and hence $(A,\to_R)$ is confluent. \end{theorem}%

    We define the predicate [Z_comp_eq] corresponding to the
    hypothesis of Theorem %\ref{cor:zcomp}%, and then we prove
    directly that if [Z_comp_eq] holds for a relation [R] then [Zprop
    R] also holds. This approach differs from
    %\cite{Nakazawa-Fujita2016}% that proves Theorem
    %\ref{cor:zcomp}%, which is a Corollary in %\cite{Nakazawa-Fujita2016}%,
    directly from Theorem %\ref{thm:zcomp}% *)

Definition Z_comp_eq {A:Type} (R :Rel A) := exists (R1 R2: Rel A) (f1 f2: A -> A), (forall x y, R x y <-> (R1 !_! R2) x y) /\ (forall a b, R1 a b -> (f1 a) = (f1 b)) /\ (forall a, (refltrans R1) a (f1 a)) /\ (forall b a, a = f1 b -> (refltrans R) a (f2 a)) /\ (f_is_weak_Z R2 R (f2 # f1)).

Lemma Z_comp_eq_implies_Z_prop {A:Type}: forall (R : Rel A), Z_comp_eq R -> Z_prop R.
Proof.
  intros R Heq.  unfold Z_comp_eq in Heq. (** %\comm{Let $R$ be a relation
  and suppose that $R$ satisfies the predicate $Z\_comp\_eq$.}% *)

  destruct Heq as [R1 [R2 [f1 [f2 [Hunion [H1 [H2 [H3 H4]]]]]]]]. (**
  %\comm{Call $Hi$ the $i$th hypothesis as in \ref{cor:zcomp}.}% *)

  unfold Z_prop.  exists (f2 # f1). (** %\comm{From the definition of the
  predicate $Z\_prop$, we need to find a map, say $f$ that is Z. Let
  $(f_2 \circ f_1)$ be such map.}%  *)

  intros a b Hab. (** %\comm{In order to prove that $(f_2 \circ f_1)$ is Z,
  let $a$ and $b$ be arbitrary elements of type $A$, and $Hab$ be the
  hypothesis that $a \to_{R} b$.}% *)
  Admitted.
(*
  inversion Hunion; subst; clear H.  inversion Hab; subst; clear Hab. (**
  %\comm{Since $a$ $R$-reduces in one step to $b$ and $R$ is the union of the
  relations $R1$ and $R2$ then we consider two cases:}% *)

  - unfold comp; split. (** %\comm{The first case is when $a \to_{R1}
    b$. This is equivalent to say that $f_2 \circ f_1$ is weak Z for
    $R1$ by $R1 \cup R2$.}% *)

    + apply refltrans_composition with (f1 b). (** %\comm{Therefore, we first
    prove that $b \tto_{(R1\cup R2)} (f_2 (f_1\ a))$, which can be
    reduced to $b \tto_{(R1\cup R2)} (f_1\ b)$ and $(f_1\ b)
    \tto_{(R1\cup R2)} (f_2 (f_1\ a))$ by the transitivity of
    $refltrans$.}% *)

      * apply refltrans_union.  apply H2. (** %\comm{From hypothesis $H2$, we
        know that $a \tto_{R1} (f_1\ a)$ for all $a$, and hence
        $a\tto_{(R1\cup R2)} (f_1\ a)$ and we conclude.}% *)

      * apply H1 in H.  rewrite H.  apply H3 with b; reflexivity. (**
        %\comm{The proof that $(f_1\ b)\tto_{(R1\cup R2)} (f_2 (f_1\ a))$ is
        exactly the hypothesis $H3$.}% *)

    + apply H1 in H.  rewrite H.  apply refl. (** %\comm{The proof that $(f_2
    (f_1\ a)) \tto_{(R1\cup R2)} (f_2 (f_1\ b))$ is done using the
    reflexivity of $refltrans$ because $(f_2 (f_1\ a)) = (f_2 (f_1\
    b))$ by hypothesis $H1$.}% *)

  - apply H4; assumption. (** %\comm{When $a \to_{R2} b$ then we are done by
    hypothesis $H4$.}% *)

Qed.
*)


Require Export Utils Basics.

Theorem andb_true_elim1 : forall b c : bool,
                            andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H.
    reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
                            andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    simpl in H.
    rewrite -> H.
    reflexivity.
  Case "b = false".
    destruct c.
    SCase "c = true".
      reflexivity.
    SCase "c = false".
      simpl in H.
      rewrite -> H.
      reflexivity.
Qed.

Theorem plus_O_r : forall n : nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S h'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n : nat,
                       minus n n = 0.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mult_O_r : forall n : nat,
                     n * 0 = 0.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
                      S (n + m) = n + (S m).
Proof.
  intros n m. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
                      n + m = m + n.
Proof.
  intros n m. induction n as [| n'].
  Case "n = 0". simpl. rewrite <- plus_n_O. reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'. rewrite -> plus_n_Sm.
    reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
                       n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

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

Lemma double_plus : forall n, double n = n + n.
Proof.
  intros n. induction n as [| n'].
  Case "n = O". reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'. rewrite -> plus_n_Sm.
    reflexivity.
Qed.

Theorem mult_O_plus' : forall n m : nat,
                         (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: O + n = n).
    Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_rearrange : forall n m p q : nat,
                           (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H. reflexivity.
Qed.

Theorem plus_swap : forall n m p : nat,
                      n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  assert (H: n + m = m + n). rewrite -> plus_comm. reflexivity.
  rewrite -> H. rewrite -> plus_assoc.
  reflexivity.
Qed.

Theorem mult_plus : forall m n : nat,
                      n * S m = n + n * m.
Proof.
  intros m n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
  simpl.
  rewrite -> IHn'. rewrite -> plus_swap.
  reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
                      m * n = n * m.
Proof.
  intros m n. induction n as [| n'].
  Case "n = 0". rewrite -> mult_O_r. reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> mult_plus. rewrite -> IHn'.
    reflexivity.
Qed.

Theorem evenb_n__oddb_Sn : forall n : nat,
                             evenb n = negb (evenb (S n)).
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    assert (H: evenb (S (S n')) = evenb n'). reflexivity.
    rewrite -> H. rewrite -> IHn'. rewrite -> negb_involutive.
    reflexivity.
Qed.

Theorem ble_nat_refl : forall n : nat,
                         true = ble_nat n n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem zero_nbeq_S : forall n : nat,
                        beq_nat 0 (S n) = false.
Proof.
  intros n. reflexivity.
Qed.

Theorem andb_false_r : forall b : bool,
                         andb b false = false.
Proof.
  intros b. destruct b; reflexivity.
Qed.

Lemma plus_O_l : forall n : nat,
                   0 + n = n.
Proof.
  reflexivity.
Qed.

Theorem plus_ble_compat_l :
  forall n m p : nat,
    ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros n m p H. induction p as [| p']; simpl.
  Case "p = 0". rewrite -> H. reflexivity.
  Case "p = S p'". rewrite -> IHp'. reflexivity.
Qed.

Theorem S_nbeq_O : forall n : nat,
                     beq_nat (S n) 0 = false.
Proof.
  intros n. reflexivity.
Qed.

Theorem mult_1_l : forall n : nat, 1 * n = n.
Proof.
  intros n. simpl. rewrite -> plus_O_r. reflexivity.
Qed.

Theorem all3_spec :
  forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
           (negb c))
    = true.
Proof.
  intros b c.
  destruct b; destruct c; reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
                              (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'. rewrite -> plus_assoc.
    reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat,
                       n * (m * p) = (n * m) * p.
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'. rewrite -> mult_plus_distr_r.
    reflexivity.
Qed.

Theorem beq_nat_refl : forall n : nat,
                         true = beq_nat n n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem plus_swap' : forall n m p : nat,
                       n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  replace (n + m) with (m + n).
  rewrite -> plus_assoc.
  reflexivity.

  Case "n + m = m + n".
  rewrite -> plus_comm.
  reflexivity.
Qed.

Theorem bin_to_nat_pres_incr :
  forall b : bin,
    bin_to_nat (bin_incr b) = (bin_to_nat b) + 1.
Proof.
  intros b. induction b as [| b'| b''].
  Case "b = Z". reflexivity.
  Case "b = Twice b'". reflexivity.
  Case "b = STwice b''".
    simpl.
    rewrite -> IHb''.
    repeat rewrite -> plus_O_r.
    rewrite -> plus_swap.
    repeat rewrite -> plus_assoc.
    reflexivity.
Qed.

Fixpoint nat_to_bin (n:nat) : bin :=
  match n with
    | O => Z
    | S n' => bin_incr (nat_to_bin n')
  end.

Theorem nat_to_bin_to_nat :
  forall n : nat, bin_to_nat (nat_to_bin n) = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> bin_to_nat_pres_incr.
    rewrite -> IHn'.
    rewrite -> plus_comm.
    reflexivity.
Qed.

Fixpoint normalize (b:bin) : bin :=
  match b with
    | Z => Z
    | Twice b' => nat_to_bin (bin_to_nat b)
    | STwice b' => nat_to_bin (bin_to_nat b)
  end.

Theorem bin_to_nat_to_bin :
  forall b : bin, nat_to_bin (bin_to_nat b) = normalize b.
Proof.
  intros b. destruct b as [| b'| b'']; reflexivity.
Qed.


(** -> を含む証明 *)
Module Section4.

Section imp_sample.
Variables P Q R:Prop.
Theorem imp_sample : (P -> (Q -> R)) -> (P -> Q) -> P -> R.
Proof.
  (* 最初は intro(s) してゴールの -> を無くす *)
  intros pqr pq p.
  (* ゴールの R を得られそうなのは pqr *)
  apply pqr.
    (* ゴール = P. そのままの仮定があれば assumption *)
    assumption.
    (* ゴール = Q. pq を使えば Q が得られそう *)
    apply pq.  assumption.
Qed.

(** 4.2 /\ を含む証明 *)
Theorem and_assoc : (P/\Q)/\R -> P/\(Q/\R).
Proof.
  intro pqr.
  (* (P/\Q)/\R を分解する *)
  destruct pqr as [[p q] r].
  (* ゴールの P/\(Q/\R) を P と Q/\R に分解 *)
  split.
    (* ゴール P *)
    assumption.
    (* ゴール Q /\ R。 split. assumption. assumption. でも OK *)
    split; assumption.
Qed.

(** 4.3 \/ を含む証明 *)
Theorem or_assoc : (P\/Q)\/R -> P\/(Q\/R).
Proof.
  intro pqr.
  (* (P\/Q)\/R を分解する *)
  destruct pqr as [[p|q]|r].
    (* 仮定 p:P *)
    left. assumption.
    (* 仮定 q:Q *)
    right. left. assumption.
    (* 仮定 r:R *)
    right; right.  assumption.
Qed.

(** 4.4 ~を含む証明 *)
Print False.

Theorem neg_sample : ~(P /\ ~P).
Proof.
  (* ~で始まるゴールは intro *)
  intro.
  destruct H as [p np].
  (* ゴールが False なら ~で始まる仮定を elim *)
  elim np.
  assumption.
Qed.

End imp_sample.
(** 課題４：命題論理の証明 *)
(* 証明せよ *)
Section Ex4.
Variable A B C D:Prop.
Theorem ex4_1 : (A -> C) /\ (B -> D) /\ A /\ B -> C /\ D.
Proof.
(* Proof *)
Qed.

Theorem ex4_2 : ~~~A -> ~A.
Proof.
(* Proof *)
Qed.

Theorem ex4_3 : (A -> B) -> ~B -> ~A.
Proof.
(* Proof *)
Qed.

Theorem ex4_4 : ((((A -> B) -> A) -> A) -> B) -> B.
Proof.
(* Proof *)
Qed.

Theorem ex4_5 : ~~(A\/~A).
Proof.
(* Proof *)
Qed.

End Ex4.
End Section4.


(* ================================================================== *)
(* =============== Reasoning about lists and naturals =============== *)
(* ================================================================== *)

Require Import List.

Set Implicit Arguments.

Print list.
Print app.

Locate "::".
Locate "++".

(* three similar proofs by induction using different tactics *)

Theorem app_l_nil : forall (A:Set) (l:list A), app l nil = l.
Proof.
  intros A l.
  pattern l. (* pattern performs a beta-expansion *)
Check list_ind.
  apply list_ind.
  - reflexivity.
  - intros a l0 IH. simpl. rewrite IH. reflexivity.
Qed.

Theorem app_l_nil' : forall (A:Set) (l:list A), app l nil = l.
Proof.
  intros A l.
  elim l.
  - reflexivity.
  - intros a l0 IH; simpl; rewrite IH; reflexivity.
Qed.

Theorem app_l_nil'' : forall (A:Set) (l:list A), app l nil = l.
Proof.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Print nat.
Print length.

(*
 Exercise: prove that the length of the append of two lists is equal
           to the sum of the length of each list
*)

Lemma sum_length : forall (A:Prop)(l1 l2:list A), length(app l1 l2) = length(l1) + length(l2).
Proof.
  intros a l1 l2.
  induction l1.
  - reflexivity.
  - simpl. SearchPattern (S _ = S _).
    apply eq_S.
    assumption.
Qed.

Fixpoint snoc (A:Type) (a:A) (l:list A) {struct l} : list A :=
    match l with
      | nil => a::nil
      | x::xs => x::(snoc a xs)
    end.

Lemma snoc_len : forall (A:Set) (a:A) (l:list A),
                            length (snoc a l) =  1 + (length l).
Proof.
  intros.
  induction l.          (* proof by induction on l *)
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

(* Exercise: *)
Lemma snoc_app : forall (A:Set) (a:A) (l:list A), snoc a l = l ++ (a::nil).
Proof.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

(* A predicate defined recursively as a function *)

Fixpoint In (A:Set) (a:A) (l:list A) {struct l} : Prop :=
    match l with
      | nil => False
      |  x :: xs => x = a \/ In a xs
    end.

Lemma in_app : forall (A:Set) (l1 l2:list A) (a:A),
                           In a (app l1 l2) -> In a l1 \/ In a l2.
Proof.
  intros.
  generalize H.  (* generalize – reintroduces an hypothesis into the goal *)
  clear H.       (* clear – removes an hypothesis from the environment *)
  induction l1.
  - simpl. intro H. right. assumption.
  - intros.  simpl in H. destruct H as [H|H].
    + rewrite H. left. simpl. left. reflexivity.
    +  destruct (IHl1 H).  (* apply IHl1 in H. destruct H. *)
      * left. simpl. right; assumption.
      * right; assumption.
Qed.

Print rev.

Lemma rev_rev_l : forall (A:Set) (l:list A), rev (rev l) = l.
Proof.
  induction l.
  - reflexivity.
  - simpl.
(* This auxiliary lemma would help...
Lemma rev_aux : forall (A:Set) (l: list A) (a:A), rev (l ++ (a :: nil)) = a :: (rev l).
You can prove it before this lemma or you can use the tactic assert as follows.
*)
    assert (rev_aux : forall (A:Set) (l: list A) (a:A), rev (l ++ (a :: nil)) = a :: (rev l)).
    + induction l0.
      * reflexivity.
      * intro. simpl. rewrite IHl0.
        simpl. reflexivity.
    + rewrite rev_aux.
      rewrite IHl. reflexivity.
Qed.

Print nat.

(* A predicate on natural numbers defined as an inductive type *)

Inductive Even : nat -> Prop :=
| Even_base : Even 0
| Even_step : forall n, Even n -> Even (S (S n)).

(*

-- --------------- (Even_base)
     Even 0

      Even n
--------------------- (Even_step)
   Even (S (S n))

*)

Lemma not_1_even : ~(Even 3).
Proof.
  red.
  intros.
  inversion H. inversion H1.
(* inversion_clear H. inversion H0.  *)
Qed.

Proposition sum_even : forall n m:nat, Even n -> Even m -> Even (n+m).
Proof.
  intros.
  induction H.               (* proof by induction on the predicate (Even n) *)
  - simpl. assumption.
  - simpl. apply Even_step.  (* constructor whould work here also *)
    assumption.
Qed.

Lemma  s_n_even : forall n:nat, Even n -> ~ Even (1+n).
Proof.
  intros n H. simpl.
  induction H.
  - intro. inversion H.
  - intro. inversion_clear H0. contradiction.
Qed.

Lemma double_even : forall n:nat, Even (2*n).
Proof.
  intros. simpl. elim n.
  - simpl. constructor.  (* apply Even_base. *)
  - intros. simpl.
    cut (forall x y:nat, x+(S y) = S (x+y)).   (* similar to assert *)
    + intros. rewrite H0. constructor. assumption.
    + clear H. intros. induction x.
      * reflexivity.
      * simpl. rewrite IHx. reflexivity.
Qed.

(*
 Exercise: rewrite the prove of the previous lemma without using the cut tactic.
 Hint: use the command SearchPattern or SearchRewrite to find out a useful lemma in the database.
*)

Lemma double_even' : forall n:nat, Even (2*n).
Proof.
  intros.
  simpl.
  induction n.
  - simpl. constructor.
  - simpl.
    rewrite PeanoNat.Nat.add_0_r.
    rewrite PeanoNat.Nat.add_succ_r.
    constructor.
    rewrite PeanoNat.Nat.add_assoc in IHn.
    rewrite PeanoNat.Nat.add_0_r in IHn.
    assumption.
  Qed.

(*
 Exercise: define the "Odd" predicate and prove that for every n, (Even n)->(Odd (S n)).
*)

Inductive Odd : nat -> Prop :=
| Odd_base : Odd 1
| Odd_step : forall n, Odd n -> Odd (S (S n)).

Lemma even_odd : forall n:nat, (Even n)->(Odd (S n)).
Proof.
  intros.
  elim H.
    - constructor.
    - intros.
      constructor.
      assumption.
Qed.

(* An inductive relation "x is the last element of list l" *)
Inductive Last (A:Type) (x:A) : list A -> Prop :=
| last_base : Last x (cons x nil)
| last_step : forall l y, Last x l -> Last x (cons y l).

Lemma last_nil : forall (A:Type) (x:A), ~(Last x nil).
Proof.
  intros. intro. inversion H.
Qed.

(* The prove of  ~(Last x nil)  without using the inversion tactic. *)

Lemma last_nil_aux : forall (A:Type) (l: list A) (x:A), Last x l -> l=nil -> False.
Proof.
  intros A l x H. elim H.
  - intro H0. discriminate H0.
  - intros. discriminate H2.
Qed.

Theorem last_nil' : forall (A:Type) (x:A), ~(Last x nil).
Proof.
  intros. intro.
  apply last_nil_aux with A nil x.
  - assumption.
  - reflexivity.
Qed.

(* Exercise:
*)
Lemma rev_last : forall (A:Type) (x:A) (l: list A), (Last x (rev (x::l))).
(* An auxiliary lemma can be useful! *)
Proof.
  intros.
  simpl.
  induction l.
  - constructor.
  - Search rev.
    constructor.
Qed.


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

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

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

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

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

(** We saw 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.

(* ################################################################# *)
(** * 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 a
    "hole" (indicated by [?Goal] here, and so on), and it knows what
    type of evidence is needed to fill this hole.

    Each hole 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.
  apply ev_SS. apply ev_SS. apply ev_SS. apply ev_SS. apply ev_0.
Qed.

Definition ev_8' : ev 8 :=
  ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0))).
(** [] *)

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

(** 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 interesting point becomes apparent: 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 the recent flurry of activity 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 left-hand side 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]". *)

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

(* ################################################################# *)
(** * Logical 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'll see 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 :=
  fun P Q R HPQ HQR =>
    match HPQ, HQR with
    | conj HP _, conj _ HR => conj HP HR
    end.
(** [] *)

(** ** 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 :=
  fun P Q HPQ =>
    match HPQ with
    | or_introl HP => or_intror HP
    | or_intror HQ => or_introl HQ
    end.
(** [] *)

(** ** 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)) :=
  ex_intro (fun n => ev (S n)) 1 (ev_SS 0 ev_0).
(** [] *)

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

(* ################################################################# *)
(** * 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.
  intros X x y Heq P HPx. destruct Heq. apply HPx.
Qed.
(** [] *)

(** 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 eq_refl].

    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:Type) (x:X), []++[x] = x::[]  :=
  fun (X:Type) (x:X) => eq_refl [x].

End MyEquality.

(* ================================================================= *)
(** ** 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: 2017-09-06 10:45:52 -0400 (Wed, 06 Sep 2017) $ *)


Require Import Reals.
Require Import Interval.Tactic.
Local Open Scope R_scope.

(*
Example taken from:
Marc Daumas and Guillaume Melquiond and César Muñoz,
Guaranteed Proofs Using Interval Arithmetic.
In IEEE ARITH 17, pages 188-195, 2005.
*)

Definition a := 6378137.
Definition f := 1000000000/298257223563.
Definition umf2 := (1 - f)².
Definition max := 715/512.
Definition rp phi := a / sqrt (1 + umf2 * (tan phi)²).
Definition arp phi :=
  let x := max² - phi² in
  4439091/4 + x * (9023647/4 + x * (
    13868737/64 + x * (13233647/2048 + x * (
      -1898597/16384 + x * (-6661427/131072))))).

Goal forall phi, 0 <= phi <= max ->
  Rabs ((rp phi - arp phi) / rp phi) <= 23/16777216.
Proof.
unfold rp, arp, umf2, a, f, max.
intros phi Hphi.
(*
Time interval with (i_bisect_diff phi). (* 38 s *)
*)
Time interval with (i_bisect_taylor phi 5). (* 4.4 s *)
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import ZArithRing.
Require Import ZArith_base.
Require Export Omega.
Require Import Wf_nat.
Open Local Scope Z_scope.

(**********************************************************************)
(** About parity *)

Lemma two_or_two_plus_one :
  forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}.
Proof.
  intro x; destruct x.
  left; split with 0; reflexivity.

  destruct p.
  right; split with (Zpos p); reflexivity.

  left; split with (Zpos p); reflexivity.

  right; split with 0; reflexivity.

  destruct p.
  right; split with (Zneg (1 + p)).
  rewrite BinInt.Zneg_xI.
  rewrite BinInt.Zneg_plus_distr.
  omega.

  left; split with (Zneg p); reflexivity.

  right; split with (-1); reflexivity.
Qed.

(**********************************************************************)
(** The biggest power of 2 that is stricly less than [a]

    Easy to compute: replace all "1" of the binary representation by
    "0", except the first "1" (or the first one :-) *)

Fixpoint floor_pos (a:positive) : positive :=
  match a with
    | xH => 1%positive
    | xO a' => xO (floor_pos a')
    | xI b' => xO (floor_pos b')
  end.

Definition floor (a:positive) := Zpos (floor_pos a).

Lemma floor_gt0 : forall p:positive, floor p > 0.
Proof.
  intro.
  compute in |- *.
  trivial.
Qed.

Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p.
Proof.
  unfold floor in |- *.
  intro a; induction a as [p| p| ].

  simpl in |- *.
  repeat rewrite BinInt.Zpos_xI.
  rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
  rewrite (BinInt.Zpos_xO (floor_pos p)).
  omega.

  simpl in |- *.
  repeat rewrite BinInt.Zpos_xI.
  rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
  rewrite (BinInt.Zpos_xO (floor_pos p)).
  rewrite (BinInt.Zpos_xO p).
  omega.

  simpl in |- *; omega.
Qed.

(**********************************************************************)
(** Two more induction principles over [Z]. *)

Theorem Z_lt_abs_rec :
  forall P:Z -> Set,
    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
    forall n:Z, P n.
Proof.
  intros P HP p.
  set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
  cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
  unfold Q in |- *; clear Q; intros.
  apply pair; apply HP.
  rewrite Zabs_eq; auto; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
  rewrite Zabs_non_eq; auto with zarith.
  rewrite Zopp_involutive; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
Qed.

Theorem Z_lt_abs_induction :
  forall P:Z -> Prop,
    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
    forall n:Z, P n.
Proof.
  intros P HP p.
  set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
  cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
  unfold Q in |- *; clear Q; intros.
  split; apply HP.
  rewrite Zabs_eq; auto; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
  rewrite Zabs_non_eq; auto with zarith.
  rewrite Zopp_involutive; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
Qed.

(** To do case analysis over the sign of [z] *)

Lemma Zcase_sign :
  forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
Proof.
  intros x P Hzero Hpos Hneg.
  induction  x as [| p| p].
  apply Hzero; trivial.
  apply Hpos; apply Zorder.Zgt_pos_0.
  apply Hneg; apply Zorder.Zlt_neg_0.
Qed.

Lemma sqr_pos : forall n:Z, n * n >= 0.
Proof.
  intro x.
  apply (Zcase_sign x (x * x >= 0)).
  intros H; rewrite H; omega.
  intros H; replace 0 with (0 * 0).
  apply Zmult_ge_compat; omega.
  omega.
  intros H; replace 0 with (0 * 0).
  replace (x * x) with (- x * - x).
  apply Zmult_ge_compat; omega.
  ring.
  omega.
Qed.

(**********************************************************************)
(** A list length in Z, tail recursive.  *)

Require Import List.

Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
  match l with
    | nil => acc
    | _ :: l => Zlength_aux (Zsucc acc) A l
  end.

Definition Zlength := Zlength_aux 0.
Implicit Arguments Zlength [A].

Section Zlength_properties.

  Variable A : Type.

  Implicit Type l : list A.

  Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
  Proof.
    assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)).
    simple induction l.
    simpl in |- *; auto with zarith.
    intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
    simpl in |- *; rewrite H; auto with zarith.
    unfold Zlength in |- *; intros; rewrite H; auto.
  Qed.

  Lemma Zlength_nil : Zlength (A:=A) nil = 0.
  Proof.
    auto.
  Qed.

  Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l).
  Proof.
    intros; do 2 rewrite Zlength_correct.
    simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto.
  Qed.

  Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil.
  Proof.
    intro l; rewrite Zlength_correct.
    case l; auto.
    intros x l'; simpl (length (x :: l')) in |- *.
    rewrite Znat.inj_S.
    intros; exfalso; generalize (Zle_0_nat (length l')); omega.
  Qed.

End Zlength_properties.

Implicit Arguments Zlength_correct [A].
Implicit Arguments Zlength_cons [A].
Implicit Arguments Zlength_nil_inv [A].


Require Import init.

Require Import nat.
Require Import set.

Declare Scope int_scope.
Delimit Scope int_scope with int.

(* begin hide *)
Section IntEquiv.
(* end hide *)
Let int_eq (a b : nat * nat) := fst a + snd b = fst b + snd a.
(* begin hide *)
Local Infix "~" := int_eq.

Lemma int_eq_reflexive : ∀ a, a ~ a.
Proof.
    intros [a1 a2].
    unfold int_eq; cbn.
    reflexivity.
Qed.
Instance int_eq_reflexive_class : Reflexive _ := {
    refl := int_eq_reflexive
}.

Lemma int_eq_symmetric : ∀ a b, a ~ b → b ~ a.
Proof.
    intros [a1 a2] [b1 b2] ab.
    unfold int_eq in *; cbn in *.
    symmetry.
    exact ab.
Qed.
Instance int_eq_symmetric_class : Symmetric _ := {
    sym := int_eq_symmetric
}.

Lemma int_eq_transitive : ∀ a b c, a ~ b → b ~ c → a ~ c.
Proof.
    intros [a1 a2] [b1 b2] [c1 c2] ab bc.
    unfold int_eq in *; cbn in *.
    pose proof (lrplus ab bc) as eq; clear ab bc.
    plus_cancel_left b1 in eq.
    plus_cancel_left b2 in eq.
    rewrite eq.
    apply plus_comm.
Qed.
Instance int_eq_transitive_class : Transitive _ := {
    trans := int_eq_transitive
}.

End IntEquiv.
(* end hide *)

Definition int_equiv := make_equiv _
    int_eq_reflexive_class int_eq_symmetric_class int_eq_transitive_class.
Notation "a ~ b" := (eq_equal int_equiv a b) : int_scope.

Notation "'int'" := (equiv_type int_equiv).

Definition nat_to_int a := to_equiv int_equiv (a, zero).

Theorem nat_to_int_eq : ∀ a b, nat_to_int a = nat_to_int b → a = b.
Proof.
    intros a b eq.
    unfold nat_to_int in eq.
    rewrite equiv_eq in eq; cbn in eq.
    do 2 rewrite plus_rid in eq.
    exact eq.
Qed.