(** * IndPrinciples: Induction Principles *)

(** With the Curry-Howard correspondence and its realization in Coq in
    mind, we can now take a deeper look at induction principles. *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Export ProofObjects.

(* ################################################################# *)
(** * Basics *)

(** Every time we declare a new [Inductive] datatype, Coq
    automatically generates an _induction principle_ for this type.
    This induction principle is a theorem like any other: If [t] is
    defined inductively, the corresponding induction principle is
    called [t_ind].  Here is the one for natural numbers: *)

Check nat_ind.
(*  ===> nat_ind :
           forall P : nat -> Prop,
              P 0  ->
              (forall n : nat, P n -> P (S n))  ->
              forall n : nat, P n  *)

(** The [induction] tactic is a straightforward wrapper that, at its
    core, simply performs [apply t_ind].  To see this more clearly,
    let's experiment with directly using [apply nat_ind], instead of
    the [induction] tactic, to carry out some proofs.  Here, for
    example, is an alternate proof of a theorem that we saw in the
    [Basics] chapter. *)

Theorem mult_0_r' : forall n:nat,
  n * 0 = 0.
Proof.
  apply nat_ind.
  - (* n = O *) reflexivity.
  - (* n = S n' *) simpl. intros n' IHn'. rewrite -> IHn'.
    reflexivity.  Qed.

(** This proof is basically the same as the earlier one, but a
    few minor differences are worth noting.

    First, in the induction step of the proof (the ["S"] case), we
    have to do a little bookkeeping manually (the [intros]) that
    [induction] does automatically.

    Second, we do not introduce [n] into the context before applying
    [nat_ind] -- the conclusion of [nat_ind] is a quantified formula,
    and [apply] needs this conclusion to exactly match the shape of
    the goal state, including the quantifier.  By contrast, the
    [induction] tactic works either with a variable in the context or
    a quantified variable in the goal.

    These conveniences make [induction] nicer to use in practice than
    applying induction principles like [nat_ind] directly.  But it is
    important to realize that, modulo these bits of bookkeeping,
    applying [nat_ind] is what we are really doing. *)

(** **** Exercise: 2 stars, standard, optional (plus_one_r')

    Complete this proof without using the [induction] tactic. *)

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Coq generates induction principles for every datatype defined with
    [Inductive], including those that aren't recursive.  Although of
    course we don't need induction to prove properties of
    non-recursive datatypes, the idea of an induction principle still
    makes sense for them: it gives a way to prove that a property
    holds for all values of the type.

    These generated principles follow a similar pattern. If we define
    a type [t] with constructors [c1] ... [cn], Coq generates a
    theorem with this shape:

    t_ind : forall P : t -> Prop,
              ... case for c1 ... ->
              ... case for c2 ... -> ...
              ... case for cn ... ->
              forall n : t, P n

    The specific shape of each case depends on the arguments to the
    corresponding constructor.  Before trying to write down a general
    rule, let's look at some more examples. First, an example where
    the constructors take no arguments: *)

Inductive yesno : Type :=
  | yes
  | no.

Check yesno_ind.
(* ===> yesno_ind : forall P : yesno -> Prop,
                      P yes  ->
                      P no  ->
                      forall y : yesno, P y *)

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

    Write out the induction principle that Coq will generate for the
    following datatype.  Write down your answer on paper or type it
    into a comment, and then compare it with what Coq prints. *)

Inductive rgb : Type :=
  | red
  | green
  | blue.
Check rgb_ind.
(** [] *)

(** Here's another example, this time with one of the constructors
    taking some arguments. *)

Inductive natlist : Type :=
  | nnil
  | ncons (n : nat) (l : natlist).

Check natlist_ind.
(* ===> (modulo a little variable renaming)
   natlist_ind :
      forall P : natlist -> Prop,
         P nnil  ->
         (forall (n : nat) (l : natlist),
            P l -> P (ncons n l)) ->
         forall n : natlist, P n *)

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

    Suppose we had written the above definition a little
   differently: *)

Inductive natlist1 : Type :=
  | nnil1
  | nsnoc1 (l : natlist1) (n : nat).

(** Now what will the induction principle look like?

    [] *)

(** From these examples, we can extract this general rule:

    - The type declaration gives several constructors; each
      corresponds to one clause of the induction principle.
    - Each constructor [c] takes argument types [a1] ... [an].
    - Each [ai] can be either [t] (the datatype we are defining) or
      some other type [s].
    - The corresponding case of the induction principle says:

        - "For all values [x1]...[xn] of types [a1]...[an], if [P]
          holds for each of the inductive arguments (each [xi] of type
          [t]), then [P] holds for [c x1 ... xn]".
*)

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

    Write out the induction principle that Coq will generate for the
    following datatype.  (Again, write down your answer on paper or
    type it into a comment, and then compare it with what Coq
    prints.) *)

Inductive byntree : Type :=
 | bempty
 | bleaf (yn : yesno)
 | nbranch (yn : yesno) (t1 t2 : byntree).
(** [] *)

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

    Here is an induction principle for an inductively defined
    set.

      ExSet_ind :
         forall P : ExSet -> Prop,
             (forall b : bool, P (con1 b)) ->
             (forall (n : nat) (e : ExSet), P e -> P (con2 n e)) ->
             forall e : ExSet, P e

    Give an [Inductive] definition of [ExSet]: *)

Inductive ExSet : Type :=
  (* FILL IN HERE *)
.
(** [] *)

(* ################################################################# *)
(** * Polymorphism *)

(** Next, what about polymorphic datatypes?

    The inductive definition of polymorphic lists

      Inductive list (X:Type) : Type :=
        | nil : list X
        | cons : X -> list X -> list X.

    is very similar to that of [natlist].  The main difference is
    that, here, the whole definition is _parameterized_ on a set [X]:
    that is, we are defining a _family_ of inductive types [list X],
    one for each [X].  (Note that, wherever [list] appears in the body
    of the declaration, it is always applied to the parameter [X].)
    The induction principle is likewise parameterized on [X]:

      list_ind :
        forall (X : Type) (P : list X -> Prop),
           P [] ->
           (forall (x : X) (l : list X), P l -> P (x :: l)) ->
           forall l : list X, P l

    Note that the _whole_ induction principle is parameterized on
    [X].  That is, [list_ind] can be thought of as a polymorphic
    function that, when applied to a type [X], gives us back an
    induction principle specialized to the type [list X]. *)

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

    Write out the induction principle that Coq will generate for
   the following datatype.  Compare your answer with what Coq
   prints. *)

Inductive tree (X:Type) : Type :=
  | leaf (x : X)
  | node (t1 t2 : tree X).
Check tree_ind.
(** [] *)

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

    Find an inductive definition that gives rise to the
    following induction principle:

      mytype_ind :
        forall (X : Type) (P : mytype X -> Prop),
            (forall x : X, P (constr1 X x)) ->
            (forall n : nat, P (constr2 X n)) ->
            (forall m : mytype X, P m ->
               forall n : nat, P (constr3 X m n)) ->
            forall m : mytype X, P m
*)
(** [] *)

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

    Find an inductive definition that gives rise to the
    following induction principle:

      foo_ind :
        forall (X Y : Type) (P : foo X Y -> Prop),
             (forall x : X, P (bar X Y x)) ->
             (forall y : Y, P (baz X Y y)) ->
             (forall f1 : nat -> foo X Y,
               (forall n : nat, P (f1 n)) -> P (quux X Y f1)) ->
             forall f2 : foo X Y, P f2
*)
(** [] *)

(** **** Exercise: 1 star, standard, optional (foo')

    Consider the following inductive definition: *)

Inductive foo' (X:Type) : Type :=
  | C1 (l : list X) (f : foo' X)
  | C2.

(** What induction principle will Coq generate for [foo']?  Fill
   in the blanks, then check your answer with Coq.)

     foo'_ind :
        forall (X : Type) (P : foo' X -> Prop),
              (forall (l : list X) (f : foo' X),
                    _______________________ ->
                    _______________________   ) ->
             ___________________________________________ ->
             forall f : foo' X, ________________________
*)

(** [] *)

(* ################################################################# *)
(** * Induction Hypotheses *)

(** Where does the phrase "induction hypothesis" fit into this story?

    The induction principle for numbers

       forall P : nat -> Prop,
            P 0  ->
            (forall n : nat, P n -> P (S n))  ->
            forall n : nat, P n

   is a generic statement that holds for all propositions
   [P] (or rather, strictly speaking, for all families of
   propositions [P] indexed by a number [n]).  Each time we
   use this principle, we are choosing [P] to be a particular
   expression of type [nat->Prop].

   We can make proofs by induction more explicit by giving
   this expression a name.  For example, instead of stating
   the theorem [mult_0_r] as "[forall n, n * 0 = 0]," we can
   write it as "[forall n, P_m0r n]", where [P_m0r] is defined
   as... *)

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

(** ... or equivalently: *)

Definition P_m0r' : nat->Prop :=
  fun n => n * 0 = 0.

(** Now it is easier to see where [P_m0r] appears in the proof. *)

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  - (* n = O *) reflexivity.
  - (* n = S n' *)
    (* Note the proof state at this point! *)
    intros n IHn.
    unfold P_m0r in IHn. unfold P_m0r. simpl. apply IHn. Qed.

(** This extra naming step isn't something that we do in
    normal proofs, but it is useful to do it explicitly for an example
    or two, because it allows us to see exactly what the induction
    hypothesis is.  If we prove [forall n, P_m0r n] by induction on
    [n] (using either [induction] or [apply nat_ind]), we see that the
    first subgoal requires us to prove [P_m0r 0] ("[P] holds for
    zero"), while the second subgoal requires us to prove [forall n',
    P_m0r n' -> P_m0r (S n')] (that is "[P] holds of [S n'] if it
    holds of [n']" or, more elegantly, "[P] is preserved by [S]").
    The _induction hypothesis_ is the premise of this latter
    implication -- the assumption that [P] holds of [n'], which we are
    allowed to use in proving that [P] holds for [S n']. *)

(* ################################################################# *)
(** * More on the [induction] Tactic *)

(** The [induction] tactic actually does even more low-level
    bookkeeping for us than we discussed above.

    Recall the informal statement of the induction principle for
    natural numbers:
      - If [P n] is some proposition involving a natural number n, and
        we want to show that P holds for _all_ numbers n, we can
        reason like this:
          - show that [P O] holds
          - show that, if [P n'] holds, then so does [P (S n')]
          - conclude that [P n] holds for all n.
    So, when we begin a proof with [intros n] and then [induction n],
    we are first telling Coq to consider a _particular_ [n] (by
    introducing it into the context) and then telling it to prove
    something about _all_ numbers (by using induction).

    What Coq actually does in this situation, internally, is to
    "re-generalize" the variable we perform induction on.  For
    example, in our original proof that [plus] is associative... *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  (* ...we first introduce all 3 variables into the context,
     which amounts to saying "Consider an arbitrary [n], [m], and
     [p]..." *)
  intros n m p.
  (* ...We now use the [induction] tactic to prove [P n] (that
     is, [n + (m + p) = (n + m) + p]) for _all_ [n],
     and hence also for the particular [n] that is in the context
     at the moment. *)
  induction n as [| n'].
  - (* n = O *) reflexivity.
  - (* n = S n' *)
    (* In the second subgoal generated by [induction] -- the
       "inductive step" -- we must prove that [P n'] implies
       [P (S n')] for all [n'].  The [induction] tactic
       automatically introduces [n'] and [P n'] into the context
       for us, leaving just [P (S n')] as the goal. *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** It also works to apply [induction] to a variable that is
    quantified in the goal. *)

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

(** Note that [induction n] leaves [m] still bound in the goal --
    i.e., what we are proving inductively is a statement beginning
    with [forall m].

    If we do [induction] on a variable that is quantified in the goal
    _after_ some other quantifiers, the [induction] tactic will
    automatically introduce the variables bound by these quantifiers
    into the context. *)

Theorem plus_comm'' : forall n m : nat,
  n + m = m + n.
Proof.
  (* Let's do induction on [m] this time, instead of [n]... *)
  induction m as [| m'].
  - (* m = O *) simpl. rewrite <- plus_n_O. reflexivity.
  - (* m = S m' *) simpl. rewrite <- IHm'.
    rewrite <- plus_n_Sm. reflexivity.  Qed.

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

    Rewrite both [plus_assoc'] and [plus_comm'] and their proofs in
    the same style as [mult_0_r''] above -- that is, for each theorem,
    give an explicit [Definition] of the proposition being proved by
    induction, and state the theorem and proof in terms of this
    defined proposition.  *)

(* FILL IN HERE

    [] *)

(* ################################################################# *)
(** * Induction Principles in [Prop] *)

(** Earlier, we looked in detail at the induction principles that Coq
    generates for inductively defined _sets_.  The induction
    principles for inductively defined _propositions_ like [even] are a
    tiny bit more complicated.  As with all induction principles, we
    want to use the induction principle on [even] to prove things by
    inductively considering the possible shapes that something in [even]
    can have.  Intuitively speaking, however, what we want to prove
    are not statements about _evidence_ but statements about
    _numbers_: accordingly, we want an induction principle that lets
    us prove properties of numbers by induction on evidence.

    For example, from what we've said so far, you might expect the
    inductive definition of [even]...

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

    ...to give rise to an induction principle that looks like this...

    ev_ind_max : forall P : (forall n : nat, even n -> Prop),
         P O ev_0 ->
         (forall (m : nat) (E : even m),
            P m E ->
            P (S (S m)) (ev_SS m E)) ->
         forall (n : nat) (E : even n),
         P n E

     ... because:

     - Since [even] is indexed by a number [n] (every [even] object [E] is
       a piece of evidence that some particular number [n] is even),
       the proposition [P] is parameterized by both [n] and [E] --
       that is, the induction principle can be used to prove
       assertions involving both an even number and the evidence that
       it is even.

     - Since there are two ways of giving evidence of evenness ([even]
       has two constructors), applying the induction principle
       generates two subgoals:

         - We must prove that [P] holds for [O] and [ev_0].

         - We must prove that, whenever [n] is an even number and [E]
           is an evidence of its evenness, if [P] holds of [n] and
           [E], then it also holds of [S (S n)] and [ev_SS n E].

     - If these subgoals can be proved, then the induction principle
       tells us that [P] is true for _all_ even numbers [n] and
       evidence [E] of their evenness.

    This is more flexibility than we normally need or want: it is
    giving us a way to prove logical assertions where the assertion
    involves properties of some piece of _evidence_ of evenness, while
    all we really care about is proving properties of _numbers_ that
    are even -- we are interested in assertions about numbers, not
    about evidence.  It would therefore be more convenient to have an
    induction principle for proving propositions [P] that are
    parameterized just by [n] and whose conclusion establishes [P] for
    all even numbers [n]:

       forall P : nat -> Prop,
       ... ->
       forall n : nat,
       even n -> P n

    For this reason, Coq actually generates the following simplified
    induction principle for [even]: *)

Check even_ind.
(* ===> ev_ind
        : forall P : nat -> Prop,
          P 0 ->
          (forall n : nat, even n -> P n -> P (S (S n))) ->
          forall n : nat,
          even n -> P n *)

(** In particular, Coq has dropped the evidence term [E] as a
    parameter of the the proposition [P]. *)

(** In English, [ev_ind] says:

    - Suppose, [P] is a property of natural numbers (that is, [P n] is
      a [Prop] for every [n]).  To show that [P n] holds whenever [n]
      is even, it suffices to show:

      - [P] holds for [0],

      - for any [n], if [n] is even and [P] holds for [n], then [P]
        holds for [S (S n)]. *)

(** As expected, we can apply [ev_ind] directly instead of using
    [induction].  For example, we can use it to show that [even'] (the
    slightly awkward alternate definition of evenness that we saw in
    an exercise in the \chap{IndProp} chapter) is equivalent to the
    cleaner inductive definition [even]: *)
Theorem ev_ev' : forall n, even n -> even' n.
Proof.
  apply even_ind.
  - (* ev_0 *)
    apply even'_0.
  - (* ev_SS *)
    intros m Hm IH.
    apply (even'_sum 2 m).
    + apply even'_2.
    + apply IH.
Qed.

(** The precise form of an [Inductive] definition can affect the
    induction principle Coq generates.

    For example, in chapter [IndProp], we defined [<=] as: *)

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

(** This definition can be streamlined a little by observing that the
    left-hand argument [n] is the same everywhere in the definition,
    so we can actually make it a "general parameter" to the whole
    definition, rather than an argument to each constructor. *)

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

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

(** The second one is better, even though it looks less symmetric.
    Why?  Because it gives us a simpler induction principle. *)

Check le_ind.
(* ===>  forall (n : nat) (P : nat -> Prop),
           P n ->
           (forall m : nat, n <= m -> P m -> P (S m)) ->
           forall n0 : nat, n <= n0 -> P n0 *)

(* ################################################################# *)
(** * Formal vs. Informal Proofs by Induction *)

(** Question: What is the relation between a formal proof of a
    proposition [P] and an informal proof of the same proposition [P]?

    Answer: The latter should _teach_ the reader how to produce the
    former.

    Question: How much detail is needed??

    Unfortunately, there is no single right answer; rather, there is a
    range of choices.

    At one end of the spectrum, we can essentially give the reader the
    whole formal proof (i.e., the "informal" proof will amount to just
    transcribing the formal one into words).  This may give the reader
    the ability to reproduce the formal one for themselves, but it
    probably doesn't _teach_ them anything much.

   At the other end of the spectrum, we can say "The theorem is true
   and you can figure out why for yourself if you think about it hard
   enough."  This is also not a good teaching strategy, because often
   writing the proof requires one or more significant insights into
   the thing we're proving, and most readers will give up before they
   rediscover all the same insights as we did.

   In the middle is the golden mean -- a proof that includes all of
   the essential insights (saving the reader the hard work that we
   went through to find the proof in the first place) plus high-level
   suggestions for the more routine parts to save the reader from
   spending too much time reconstructing these (e.g., what the IH says
   and what must be shown in each case of an inductive proof), but not
   so much detail that the main ideas are obscured.

   Since we've spent much of this chapter looking "under the hood" at
   formal proofs by induction, now is a good moment to talk a little
   about _informal_ proofs by induction.

   In the real world of mathematical communication, written proofs
   range from extremely longwinded and pedantic to extremely brief and
   telegraphic.  Although the ideal is somewhere in between, while one
   is getting used to the style it is better to start out at the
   pedantic end.  Also, during the learning phase, it is probably
   helpful to have a clear standard to compare against.  With this in
   mind, we offer two templates -- one for proofs by induction over
   _data_ (i.e., where the thing we're doing induction on lives in
   [Type]) and one for proofs by induction over _evidence_ (i.e.,
   where the inductively defined thing lives in [Prop]). *)

(* ================================================================= *)
(** ** Induction Over an Inductively Defined Set *)

(** _Template_:

       - _Theorem_: <Universally quantified proposition of the form
         "For all [n:S], [P(n)]," where [S] is some inductively defined
         set.>

         _Proof_: By induction on [n].

           <one case for each constructor [c] of [S]...>

           - Suppose [n = c a1 ... ak], where <...and here we state
             the IH for each of the [a]'s that has type [S], if any>.
             We must show <...and here we restate [P(c a1 ... ak)]>.

             <go on and prove [P(n)] to finish the case...>

           - <other cases similarly...>                        []

    _Example_:

      - _Theorem_: For all sets [X], lists [l : list X], and numbers
        [n], if [length l = n] then [index (S n) l = None].

        _Proof_: By induction on [l].

        - Suppose [l = []].  We must show, for all numbers [n],
          that, if [length [] = n], then [index (S n) [] =
          None].

          This follows immediately from the definition of [index].

        - Suppose [l = x :: l'] for some [x] and [l'], where
          [length l' = n'] implies [index (S n') l' = None], for
          any number [n'].  We must show, for all [n], that, if
          [length (x::l') = n] then [index (S n) (x::l') =
          None].

          Let [n] be a number with [length l = n].  Since

            length l = length (x::l') = S (length l'),

          it suffices to show that

            index (S (length l')) l' = None.

          But this follows directly from the induction hypothesis,
          picking [n'] to be [length l'].  [] *)

(* ================================================================= *)
(** ** Induction Over an Inductively Defined Proposition *)

(** Since inductively defined proof objects are often called
    "derivation trees," this form of proof is also known as _induction
    on derivations_.

    _Template_:

       - _Theorem_: <Proposition of the form "[Q -> P]," where [Q] is
         some inductively defined proposition (more generally,
         "For all [x] [y] [z], [Q x y z -> P x y z]")>

         _Proof_: By induction on a derivation of [Q].  <Or, more
         generally, "Suppose we are given [x], [y], and [z].  We
         show that [Q x y z] implies [P x y z], by induction on a
         derivation of [Q x y z]"...>

           <one case for each constructor [c] of [Q]...>

           - Suppose the final rule used to show [Q] is [c].  Then
             <...and here we state the types of all of the [a]'s
             together with any equalities that follow from the
             definition of the constructor and the IH for each of
             the [a]'s that has type [Q], if there are any>.  We must
             show <...and here we restate [P]>.

             <go on and prove [P] to finish the case...>

           - <other cases similarly...>                        []

    _Example_

       - _Theorem_: The [<=] relation is transitive -- i.e., for all
         numbers [n], [m], and [o], if [n <= m] and [m <= o], then
         [n <= o].

         _Proof_: By induction on a derivation of [m <= o].

           - Suppose the final rule used to show [m <= o] is
             [le_n]. Then [m = o] and we must show that [n <= m],
             which is immediate by hypothesis.

           - Suppose the final rule used to show [m <= o] is
             [le_S].  Then [o = S o'] for some [o'] with [m <= o'].
             We must show that [n <= S o'].
             By induction hypothesis, [n <= o'].

             But then, by [le_S], [n <= S o'].  [] *)

(* Wed Jan 9 12:02:46 EST 2019 *)


Require Import ssreflect ssrbool eqtype ssrnat.

(**
# 第8回

http://qnighy.github.io/coqex2014/ex6.html

## 課題37 (種別:A / 締め切り : 2014/06/01)

自然数の対の商集合として整数を定義する。下の証明の空欄を埋めよ。
omega等を使ってもよい。
*)
Require Import SetoidClass.

Record int :=
  {
    Ifst : nat;
    Isnd : nat
  }.

Lemma addn2r p m n : (m + p = n + p) -> (m = n).
Proof.
  move/eqP => H.
  apply/eqP.
  by rewrite -(eqn_add2r p).
Qed.

Program Instance ISetoid : Setoid int :=
  {|
    equiv x y :=                            (* == *)
      Ifst x + Isnd y = Ifst y + Isnd x
  |}.
Next Obligation.
Proof.
  (* http://d.hatena.ne.jp/m-a-o/20110112 *)
  apply Build_Equivalence.
  by rewrite /Reflexive.
  by rewrite /Symmetric.
  rewrite /Transitive.
  move=> x y z.
  move=> Hxy Hyz.
  apply (addn2r (Ifst y + Isnd y)).
  rewrite !addnA.
  rewrite [Ifst x + Isnd z + Ifst y + Isnd y]addnC.
  rewrite [Ifst z + Isnd x + Ifst y + Isnd y]addnC.
  rewrite !addnA.
  rewrite [Isnd y + Ifst x]addnC.
  rewrite [Isnd y + Ifst z]addnC.
  rewrite Hxy.
  rewrite -Hyz.
  rewrite [Ifst y + Isnd z + Isnd x + Ifst y]addnC.
  rewrite [Ifst y + Isnd z + Isnd x]addnC.
  rewrite [Ifst y + Isnd z]addnC.
  rewrite !addnA.
  by [].
Qed.

Definition zero : int :=
  {|
    Ifst := 0;
    Isnd := 0
  |}.

Definition int_plus (x y : int) : int :=
  {|
    Ifst := Ifst x + Ifst y;
    Isnd := Isnd x + Isnd y
  |}.

Definition int_minus (x y : int) : int :=
  {|
    Ifst := Ifst x + Isnd y;
    Isnd := Isnd x + Ifst y
  |}.

Lemma int_sub_diag : forall x, int_minus x x == zero.
Proof.
  move=> x.
  by rewrite /= addn0 add0n addnC.
Qed.

(* まず、int_minus_compatを証明せずに、下の2つの証明を実行して、
どちらも失敗することを確認せよ。*)

Instance int_plus_compat :
  Proper (equiv ==> equiv ==> equiv) int_plus.
Proof.
  unfold Proper.
  unfold respectful.                        (* ==> *)
  move=> x y Hxy x' y' Hx'y'.
  rewrite /int_plus /=.

  have Hxy2 : (Ifst x + Isnd y = Ifst y + Isnd x) by apply Hxy.
  have Hx'y'2 : (Ifst x' + Isnd y' = Ifst y' + Isnd x') by apply Hx'y'.

  rewrite 2!addnA.
  rewrite -[Ifst x + Ifst x' + Isnd y]addnA.
  rewrite [Ifst x' + Isnd y]addnC.
  rewrite addnA.
  rewrite Hxy2.
  rewrite -[(Ifst y + Isnd x) + Ifst x' + Isnd y']addnA.
  rewrite Hx'y'2.
  rewrite addnA.
  rewrite -[Ifst y + Isnd x + Ifst y']addnA.
  rewrite [Isnd x + Ifst y']addnC.
  rewrite addnA.
  by [].
Qed.

Instance int_minus_compat :
  Proper (equiv ==> equiv ==> equiv) int_minus.
Proof.
  unfold Proper.
  unfold respectful.                        (* ==> *)
  move=> x y Hxy x' y' Hx'y'.
  rewrite /int_minus /=.

  have Hxy2 : (Ifst x + Isnd y = Ifst y + Isnd x) by apply Hxy.
  have Hx'y'2 : (Ifst x' + Isnd y' = Ifst y' + Isnd x') by apply Hx'y'.

  rewrite 2!addnA.
  rewrite [Ifst x + Isnd x' + Isnd y]addnC.
  rewrite [Ifst y + Isnd y' + Isnd x]addnC.
  rewrite 2!addnA.
  rewrite [Isnd y + Ifst x]addnC.
  rewrite -addnA.
  rewrite [Isnd x' + Ifst y']addnC.
  rewrite [Isnd x + Ifst y]addnC.
  rewrite -Hx'y'2.
  rewrite -Hxy2.
  rewrite -[(Ifst x + Isnd y) + Isnd y' + Ifst x']addnA.
  rewrite [Isnd y' + Ifst x']addnC.
  by [].
Qed.

Goal forall x y, int_minus x (int_minus y y) == int_minus x zero.
Proof.
  intros x y.
  rewrite int_sub_diag.
  reflexivity.
Qed.

Goal forall x y, int_minus x (int_minus y y) == int_minus x zero.
Proof.
  intros x y.
  rewrite -!{1}int_sub_diag.                (* SSReflectのタクティカルも使える。 *)
  reflexivity.
Qed.

Goal forall x y, int_minus x (int_minus y y) == int_minus x zero.
Proof.
  intros x y.
  setoid_rewrite int_sub_diag.
  reflexivity.
Qed.

(**

おまけ : ISetoidの定義においてProgram InstanceをInstanceに変更し、Next Obligation. を取り除
いてもISetoidは定義できるが、続きがうまくいかなくなる。これは何故か？

ヒント

通常のイコール (Coq.Init.Logic.eq) 以外の同値関係を入れたい場合、Setoidを使います。Setoidに
よる書き換えは、通常rewriteで行えます。明示的にSetoidを使う場合は、setoid_rewriteを使います。

Setoidによってreplaceを行いたい場合はsetoid_replaceを使えます。通常のイコールと違い、
Setoidの同値関係を保存しない写像が存在する可能性があります。例えば、この問題におけるIfst関
数はSetoidの同値関係を保存しません。Setoidによる書き換えを行うためには、それぞれの関数が同
値関係を保存することを逐一証明する必要があります。

Recordは単一のコンストラクタを持ち再帰的でない型を定義するのに使えるコマンドです。メンバを
取り出す関数(この例ではIfst, Isnd)が自動的に定義されることや、{| ... |} という構文でRecord
型の値を記述できるという利点があります。
*)

(* END *)


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
From LF Require Import exercise8.

Module AExp.

Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BNeq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BGt (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

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

Compute aeval (APlus (ANum 2) (ANum 2)). (* it evaluates to 4. *)

Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval a1) =? (aeval a2)
  | BNeq a1 a2 => negb ((aeval a1) =? (aeval a2))
  | BLe a1 a2 => (aeval a1) <=? (aeval a2)
  | BGt a1 a2 => negb ((aeval a1) <=? (aeval a2))
  | BNot b1 => negb (beval b1)
  | BAnd b1 b2 => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | APlus (ANum 0) e2 => optimize_0plus e2
  | APlus e1 e2 => APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 => AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 => AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros. induction a.
  - trivial.
  - destruct a1; try destruct n; try destruct a2; simpl; auto.
  - simpl. auto.
  - simpl. auto.
Qed.

(* Since the optimize_0plus transformation doesn't change the value of aexps, we should be able to apply
it to all the aexps that appear in a bexp without changing the bexp's value. Write a function that
performs this transformation on bexps and prove it is sound. Use the tacticals we've just seen to make
the proof as short and elegant as possible. *)
Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b1 => BNot (optimize_0plus_b b1)
  | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  | _ => b
  end.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros. induction b; simpl; repeat rewrite optimize_0plus_sound; trivial.
  - rewrite IHb. trivial.
  - rewrite IHb1. rewrite IHb2. trivial.
Qed.

Ltac invert H := inversion H; subst; clear H.

Reserved Notation "e '==>' n" (at level 90, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum (n : nat) :
      (ANum n) ==> n
  | E_APlus (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 ==> n1) ->
      (e2 ==> n2) ->
      (APlus e1 e2) ==> (n1 + n2)
  | E_AMinus (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 ==> n1) ->
      (e2 ==> n2) ->
      (AMinus e1 e2) ==> (n1 - n2)
  | E_AMult (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 ==> n1) ->
      (e2 ==> n2) ->
      (AMult e1 e2) ==> (n1 * n2)

      where "e '==>' n" := (aevalR e n) : type_scope.

Theorem aeval_iff_aevalR : forall a n,
  (a ==> n) <-> aeval a = n.
Proof.
  split; intros.
  - induction H; simpl; auto.
  - generalize dependent n.
    induction a; simpl; intros; subst; constructor;
    try apply IHa1; try apply IHa2; trivial.
Qed.

Reserved Notation "e '==>b' b" (at level 90, left associativity).

Inductive bevalR : bexp -> bool -> Prop :=
  | E_BTrue : BTrue ==>b true
  | E_BFalse : BFalse ==>b false
  | E_BEq (e1 e2 : aexp) (n1 n2 : nat) :
    e1 ==> n1 ->
    e2 ==> n2 ->
    (BEq e1 e2 ==>b n1 =? n2)
  | E_BNeq (e1 e2 : aexp) (n1 n2 : nat) :
    e1 ==> n1 ->
    e2 ==> n2 ->
    (BNeq e1 e2 ==>b negb (n1 =? n2))
  | E_BLe (e1 e2 : aexp) (n1 n2 : nat) :
    e1 ==> n1 ->
    e2 ==> n2 ->
    (BLe e1 e2 ==>b n1 <=? n2)
  | E_BGt (e1 e2 : aexp) (n1 n2 : nat) :
    e1 ==> n1 ->
    e2 ==> n2 ->
    (BGt e1 e2 ==>b negb (n1 <=? n2))
  | E_BNot (e : bexp) (b : bool) :
    e ==>b b ->
    BNot e ==>b negb b
  | E_BAnd (e1 e2 : bexp) (b1 b2 : bool) :
    (e1 ==>b b1) ->
    (e2 ==>b b2) ->
    BAnd e1 e2 ==>b andb b1 b2

  where "e '==>b' b" := (bevalR e b) : type_scope.

Lemma beval_iff_bevalR : forall b bv,
  b ==>b bv <-> beval b = bv.
Proof.
  split; intro.
  - induction H; simpl; auto; try apply aeval_iff_aevalR in H, H0; try rewrite H, H0; trivial.
    + rewrite IHbevalR. trivial.
    + rewrite IHbevalR1, IHbevalR2. trivial.
  - generalize dependent bv.
    induction b; simpl; intros; subst; constructor; try apply aeval_iff_aevalR; trivial.
    + apply IHb. trivial.
    + apply IHb1. trivial.
    + apply IHb2. trivial.
Qed.

End AExp.

Definition state := total_map nat.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : string) (* <--- NEW *)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BNeq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BGt (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.
Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom com at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : com_scope.
Notation "x + y" := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y" := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y" := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'" := true (at level 1).
Notation "'true'" := BTrue (in custom com at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := BFalse (in custom com at level 0).
Notation "x <= y" := (BLe x y) (in custom com at level 70, no associativity).
Notation "x > y" := (BGt x y) (in custom com at level 70, no associativity).
Notation "x = y" := (BEq x y) (in custom com at level 70, no associativity).
Notation "x <> y" := (BNeq x y) (in custom com at level 70, no associativity).
Notation "x && y" := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b" := (BNot b) (in custom com at level 75, right associativity).
Open Scope com_scope.

(* We can now write 3 + (X × 2) instead of APlus 3 (AMult X 2), and true && ~(X ≤ 4) instead of BAnd
true (BNot (BLe X 4)). *)

Fixpoint aeval (st : state) (* <--- NEW *) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x (* <--- NEW *)
  | <{a1 + a2}> => (aeval st a1) + (aeval st a2)
  | <{a1 - a2}> => (aeval st a1) - (aeval st a2)
  | <{a1 * a2}> => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (* <--- NEW *) (b : bexp) : bool :=
  match b with
  | <{true}> => true
  | <{false}> => false
  | <{a1 = a2}> => (aeval st a1) =? (aeval st a2)
  | <{a1 <> a2}> => negb ((aeval st a1) =? (aeval st a2))
  | <{a1 <= a2}> => (aeval st a1) <=? (aeval st a2)
  | <{a1 > a2}> => negb ((aeval st a1) <=? (aeval st a2))
  | <{~ b1}> => negb (beval st b1)
  | <{b1 && b2}> => andb (beval st b1) (beval st b2)
  end.

Definition empty_st := (_ !-> 0).

(* singleton state *)
Notation "x '!->' v" := (x !-> v ; empty_st) (at level 100).

Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com).

Notation "'skip'" :=
    CSkip (in custom com at level 0) : com_scope.
Notation "x := y" :=
    (CAsgn x y)
       (in custom com at level 0, x constr at level 0,
        y at level 85, no associativity) : com_scope.
Notation "x ; y" :=
    (CSeq x y)
      (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
    (CIf x y z)
      (in custom com at level 89, x at level 99,
       y at level 99, z at level 99) : com_scope.
Notation "'while' x 'do' y 'end'" :=
    (CWhile x y)
       (in custom com at level 89, x at level 99, y at level 99) : com_scope.

Fixpoint ceval_fun_no_while (st : state) (c : com) : state :=
  match c with
    | <{ skip }> =>
        st
    | <{ x := a }> =>
        (x !-> (aeval st a) ; st)
    | <{ c1 ; c2 }> =>
        let st' := ceval_fun_no_while st c1 in
        ceval_fun_no_while st' c2
    | <{ if b then c1 else c2 end}> =>
        if (beval st b)
          then ceval_fun_no_while st c1
          else ceval_fun_no_while st c2
    | <{ while b do c end }> =>
        st (* bogus *)
  end.

(* Operational Semantics *)
Reserved Notation
         "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99,
          st constr, st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn : forall st a n x,
      aeval st a = n ->
      st =[ x := a ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st =[ while b do c end ]=> st''

  where "st =[ c ]=> st'" := (ceval c st st').

Example ceval_example1:
  empty_st =[
     X := 2;
     if (X <= 1)
       then Y := 3
       else Z := 4
     end
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Asgn. trivial.
  - apply E_IfFalse.
    + trivial.
    + apply E_Asgn. trivial.
Qed.

Example ceval_example2:
  empty_st =[
    X := 0;
    Y := 1;
    Z := 2
  ]=> (Z !-> 2 ; Y !-> 1 ; X !-> 0).
Proof.
  apply E_Seq with (X !-> 0).
  - apply E_Asgn. trivial.
  - apply E_Seq with (Y !-> 1; X !-> 0); (* Treat as a whole. *)
  apply E_Asgn; trivial.
Qed.

Definition fact_in_coq : com :=
  <{ Z := X;
     Y := 1;
     while Z <> 0 do
       Y := Y * Z;
       Z := Z - 1
     end }>.

(* Write an Imp program that sums the numbers from 1 to X (inclusive: 1 + 2 + ... + X) in the variable Y.  *)
Definition pup_to_n : com :=
  <{
    Y := 0;
    while X <> 0 do
      Y := Y + X;
      X := X - 1
    end
  }>.

Theorem pup_to_2_ceval :
  (X !-> 2) =[
    pup_to_n
  ]=> (X !-> 0 ; Y !-> 3 ; X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2).
  (* can be treated as a reverse-ordered state list? *)
  (* final, prev1, prev2, initial. *)
Proof.
  unfold pup_to_n.
  apply E_Seq with (Y !-> 0 ; X !-> 2).
  - apply E_Asgn. trivial.
  - apply E_WhileTrue with (X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2).
    * trivial.
    * apply E_Seq with (Y !-> 2; Y !-> 0; X !-> 2); apply E_Asgn; trivial.
    * apply E_WhileTrue with (X !-> 0 ; Y !-> 3 ; X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2).
      + trivial.
      + apply E_Seq with (Y !-> 3 ; X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2); apply E_Asgn; trivial.
      + apply E_WhileFalse. trivial.
Qed.

Theorem ceval_deterministic : forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1; intros; inversion E2; subst.
  - trivial.
  - trivial.
  - apply IHE1_2. apply IHE1_1 in H1. subst. apply H4.
  - apply IHE1. apply H6.
  - rewrite H in H5. discriminate.
  - rewrite H in H5. discriminate.
  - apply IHE1. apply H6.
  - trivial.
  - rewrite H in H2. discriminate.
  - rewrite H in H4. discriminate.
  - apply IHE1_2. apply IHE1_1 in H3. rewrite H3. apply H6.
Qed.

Definition plus2 : com :=
  <{ X := X + 2 }>.

Theorem plus2_spec: forall st n st',
  st X = n ->
  st =[ plus2 ]=> st' ->
  st' X = n + 2.
Proof.
  unfold plus2. intros. inversion H0. subst.
  trivial.
Qed.

Definition XtimesYinZ : com :=
  <{ Z := X * Y }>.

Theorem XtimesYinZ_spec: forall st n1 n2 st',
  st X = n1 ->
  st Y = n2 ->
  st =[ XtimesYinZ ]=> st' ->
  st' Z = n1 * n2.
Proof.
  unfold XtimesYinZ. intros.
  inversion H1. subst.
  trivial.
Qed.

Definition loop : com :=
  <{ while true do
       skip
     end }>.

Theorem loop_never_stops : forall st st',
  ~(st =[ loop ]=> st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember <{ while true do skip end }> as loopdef
           eqn : Heqloopdef.
  induction contra; try discriminate.
  - inversion Heqloopdef. rewrite H1 in H. discriminate.
  - inversion Heqloopdef. subst. apply IHcontra2. apply Heqloopdef.
Qed.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | <{ skip }> =>
      true
  | <{ _ := _ }> =>
      true
  | <{ c1 ; c2 }> =>
      andb (no_whiles c1) (no_whiles c2)
  | <{ if _ then ct else cf end }> =>
      andb (no_whiles ct) (no_whiles cf)
  | <{ while _ do _ end }> =>
      false
  end.

Inductive no_whilesR: com -> Prop :=
  | R_skip : no_whilesR <{ skip }>
  | R_asgn : forall lhs rhs, no_whilesR <{ lhs := rhs }>
  | R_seq : forall c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR <{ c1 ; c2 }>
  | R_ifesle : forall exp c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR <{ if exp then c1 else c2 end }>.

Theorem no_whiles_eqv:
  forall c, no_whiles c = true <-> no_whilesR c.
Proof.
  split; intros.
  - induction c.
    + apply R_skip.
    + apply R_asgn.
    + inversion H. apply andb_true_iff in H1. destruct H1. apply R_seq. apply IHc1. auto. apply IHc2. auto.
    + inversion H. apply andb_true_iff in H1. destruct H1. apply R_ifesle. apply IHc1. auto. apply IHc2. auto.
    + inversion H.
  - induction H; auto; simpl; apply andb_true_iff; split; auto.
Qed.

Theorem no_whiles_terminating : forall st c,
  no_whilesR c ->
  exists st', st =[ c ]=> st'.
Proof.
  intros. (* There is no meaning introducing st. *)
  generalize dependent st. induction H; intros.
  - exists st. apply E_Skip.
  - exists (lhs !-> aeval st rhs; st). apply E_Asgn. trivial.
  - destruct IHno_whilesR1 with st. destruct IHno_whilesR2 with x. (* fix some existing state. *)
    exists x0. apply E_Seq with x; auto.
  - destruct IHno_whilesR1 with st. destruct IHno_whilesR2 with st.
    destruct (beval st exp) eqn : H'. (* destruct condition. *)
    + exists x. apply E_IfTrue. apply H'. apply H1.
    + exists x0. apply E_IfFalse. apply H'. apply H2.
Qed.

Inductive sinstr : Type :=
| SPush (n : nat)
| SLoad (x : string)
| SPlus
| SMinus
| SMult.

Fixpoint s_execute (st : state) (stack : list nat)
                   (prog : list sinstr)
                 : list nat :=
  match prog with
  | [] => stack
  | cons inst l' =>
      match inst with
      | SPush n => s_execute (st) (n :: stack)  (l')
      | SLoad x => s_execute (st) ((aeval st (AId x)) :: stack) (l')
      | SPlus =>
        match stack with
        | n1 :: n2 :: l'' => s_execute (st) ((n2 + n1) :: l'') (l')
        | _ => s_execute st stack l'
        end
      | SMinus =>
        match stack with
        | n1 :: n2 :: l'' => s_execute (st) ((n2 - n1) :: l'') (l')
        | _ => s_execute st stack l'
        end
      | SMult =>
        match stack with
        | n1 :: n2 :: l'' => s_execute (st) ((n2 * n1) :: l'') (l')
        | _ => s_execute st stack l'
        end
      end
  end.

Example s_execute1 :
     s_execute empty_st []
       [SPush 5; SPush 3; SPush 1; SMinus]
   = [2; 5].
Proof. trivial. Qed.

Example s_execute2 :
     s_execute (X !-> 3) [3;4]
       [SPush 4; SLoad X; SMult; SPlus]
   = [15; 4].
Proof. trivial. Qed.

Fixpoint s_compile (e : aexp) : list sinstr :=
  match e with
  | ANum n => [SPush n]
  | AId x => [SLoad x]
  | APlus exp1 exp2 => s_compile (exp1) ++ s_compile (exp2) ++ [SPlus]
  | AMinus exp1 exp2 => s_compile (exp1) ++ s_compile (exp2) ++ [SMinus]
  | AMult exp1 exp2 => s_compile (exp1) ++ s_compile (exp2) ++ [SMult]
  end.

Example s_compile1 :
  s_compile <{ X - (2 * Y) }>
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
Proof. trivial. Qed.

Theorem execute_app : forall st p1 p2 stack,
  s_execute st stack (p1 ++ p2) = s_execute st (s_execute st stack p1) p2.
Proof.
  induction p1.
  - trivial.
  - induction a; intros.
    + simpl. auto.
    + simpl. auto.
    + induction stack; simpl; auto; induction stack; simpl; auto.
    + induction stack; simpl; auto; induction stack; simpl; auto.
    + induction stack; simpl; auto; induction stack; simpl; auto.
Qed.

Lemma s_compile_correct_aux : forall st e stack,
  s_execute st stack (s_compile e) = aeval st e :: stack.
Proof.
  induction e; trivial; intros; simpl;
  try (rewrite app_assoc; repeat rewrite execute_app; rewrite IHe1; rewrite IHe2; trivial).
Qed.

Theorem s_compile_correct : forall (st : state) (e : aexp),
  s_execute st [] (s_compile e) = [ aeval st e ].
Proof.
  intros. rewrite s_compile_correct_aux. trivial.
Qed.

Fixpoint beval_sc (st : state) (* <--- NEW *) (b : bexp) : bool :=
  match b with
  | <{b1 && b2}> => if negb (beval_sc st b1) then false else beval_sc st b2
  | _ => beval st b
  end.

Theorem beval_sc_is_beval : forall st b,
  beval st b = beval_sc st b.
Proof.
  induction b; trivial; simpl.
  destruct (negb (beval_sc st b1)) eqn : H.
  - apply negb_true_iff in H. rewrite H in IHb1. rewrite IHb1. trivial.
  - apply negb_false_iff in H. rewrite H in IHb1. rewrite IHb1. trivial.
Qed.


From Coq Require Export String.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.
Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.
Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).
Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => true
  | true => negb b2
  end.
Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1 with
  | false => false
  | true => match b2 with
            | false => false
            | true => match b3 with
                      | false => false
                      | true => true
                      end
            end
  end.
Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

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

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

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

Definition oddb (n:nat) : bool :=
  negb (evenb n).
Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

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

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => plus m (mult n' m)
  end.
Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O , _ => O
  | S _ , O => n
  | S n', S m' => minus n' m'
  end.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => 1
  | S n' => mult n (factorial n')
  end.
Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.
Check ((0 + 1) + 1) : nat.

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

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

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Definition ltb (n m : nat) : bool :=
  match eqb n m with
  | true => false
  | false => leb n m
  end.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.
Example test_ltb1: (ltb 2 2) = false.
Proof. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H.
  intros P.
  rewrite H.
  rewrite P.
  reflexivity.
Qed.

Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
    intros p.
    rewrite <- mult_n_Sm.
    rewrite <- mult_n_O.
    simpl.
    reflexivity.
Qed.

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

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

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

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

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
    intros b c. destruct b eqn: Eb.
    - destruct c eqn: Ec.
        + simpl. reflexivity.
        + intro H. rewrite <- H. simpl. reflexivity.
    - destruct c eqn: Ec.
        + intro H. rewrite <- H. simpl. reflexivity.
        + intro H. rewrite <- H. simpl. reflexivity.
Qed.

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

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
    intros [|n].
    - simpl. reflexivity.
    - simpl. reflexivity.
Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

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

Definition manual_grade_for_negation_fn_applied_twice : option (nat*string) := None.

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

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b eqn: Eb.
  - destruct c eqn: Ec.
    + simpl. reflexivity.
    + simpl. rewrite <- Ec. rewrite <- Eb. intro H. rewrite -> H. reflexivity.
  - destruct c eqn: Ec.
    + simpl. rewrite <- Ec. rewrite <- Eb. intro H. rewrite -> H. reflexivity.
    + simpl. reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (m:bin) : bin :=
  match m with
  | Z => B1 Z
  | B0 n => B1 (n)
  | B1 n => B0 (incr n)
  end.
Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z => O
  | B0 n => 2 * (bin_to_nat n)
  | B1 n => 1 + 2 * (bin_to_nat n)
  end.
Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
Proof. simpl. reflexivity. Qed.
Example test_bin_incr5 :
        bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr6 :
        bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.


Require Import BenB.

(* Domeinen *)
Variables S: Set. (* Alle studenten van de RU. *)
Variables V: Set. (* Alle vakken bij FNWI. *)

(* Constanten *)
Variable BB: V. (* Beweren en Bewijzen *)
Variable WS: V. (* Wiskundige Structuren *)
Variable FD: V. (* Formeel Denken *)

(* Predikaten *)
Variable GNR (* s v *): S -> V  -> Prop.
  (* Student s gaat naar responsiecolleges van vak v. *)
  (* Presentielijsten van die responsiecolleges bekijken. *)

Variable HV (* s v *): S -> V -> Prop.
  (* Student s haalt vak v. *)
  (* Cijfer in Osiris opzoeken. *)

Theorem ResponsieCollegesBBLonen:
      (forall s:S, GNR s BB -> HV s BB)
    /\
      (exists s:S, GNR s BB)
  ->
      (exists s:S, HV s BB)
.
Proof.
imp_i a1.
exi_e (exists b:S, GNR b BB) b a2.
con_e2 (forall s:S, GNR s BB -> HV s BB).
hyp a1.
exi_i b.
imp_e (GNR b BB).
all_e (forall b:S, GNR b BB -> HV b BB) b.
con_e1 (exists s:S, GNR s BB).
hyp a1.
hyp a2.
Qed.


Require Export Logic.

Definition even (n : nat) : Prop :=
  evenb n = true.

Theorem even20 : even 20.
Proof. reflexivity. Qed.
Print even20.

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

Theorem double_even : forall n,
  ev (double n).
Proof.
  intros n. induction n.
  Case "n = O". simpl. apply ev_O.
  Case "n = S n". simpl. apply ev_SS. assumption.
Qed.

Inductive beautiful : nat -> Prop :=
| b_0 : beautiful 0
| b_3 : beautiful 3
| b_5 : beautiful 5
| b_sum n m : beautiful n -> beautiful m -> beautiful (n + m).

Theorem three_is_beautiful : beautiful 3.
Proof. apply b_3. Qed.

Theorem eight_is_beautiful : beautiful 8.
Proof.
  apply b_sum with (n := 3) (m := 5). apply b_3. apply b_5.
Qed.

Theorem beautiful_plus_eight n : beautiful n -> beautiful (8+n).
Proof.
  intros H. apply b_sum with (n := 3) (m := 5 + n).
  apply b_3. apply b_sum with (n := 5) (m := n). apply b_5.
  assumption.
Qed.

Theorem b_times2: forall n, beautiful n -> beautiful (2 * n).
Proof.
  intros n. intros H. simpl. apply b_sum with (n := n) (m := (n + 0)).
  assumption. SearchAbout (_ + 0 = _). rewrite NPeano.Nat.add_0_r.
  assumption.
Qed.

Theorem b_timesm: forall n m, beautiful n -> beautiful (m * n).
Proof.
  intros n m H. induction m.
  Case "m = O". apply b_0.
  Case "m = S m". simpl. apply b_sum with (n := n ) (m := m * n). assumption.
  assumption.
Qed.
(* This is best example of not following the nose *)
Print b_timesm.

Inductive gorgeous : nat -> Prop :=
| g_0 : gorgeous 0
| g_3 : forall n : nat, gorgeous n -> gorgeous (3 + n)
| g_5 : forall n : nat, gorgeous n -> gorgeous (5 + n).

Theorem gorgeous_plus13: forall n,
  gorgeous n -> gorgeous (13+n).
Proof.
  intros n H. apply g_5 with (n := 8 + n). apply g_5. apply g_3. assumption.
Qed.

Theorem gorgeous__beautiful_FAILED : forall n,
  gorgeous n -> beautiful n.
Proof.
  intros n H. induction n.
  Case "n = O". apply b_0.
  Abort.

Theorem gorgeous__beautiful : forall n,
  gorgeous n -> beautiful n.
Proof.
  intros n H. induction H.
  Case "H = b_0". apply b_0.
  Case "H = b_3". apply b_sum with (n := 3). apply b_3. assumption.
  Case "H = b_5". apply b_sum with (n := 5). apply b_5. assumption.
Qed.

Theorem gorgeous_sum : forall n m,
  gorgeous n -> gorgeous m -> gorgeous (n + m).
Proof.
  intros n m Hn Hm. induction Hn.
  Case "g_0". simpl. assumption.
  Case "g_3". apply g_3 with (n := n + m). assumption.
  Case "g_5". apply g_5 with (n := n + m). assumption.
Qed.

Theorem beautiful__gorgeous : forall n, beautiful n -> gorgeous n.
Proof.
  intros n H. induction H.
  Case "b_0". apply g_0.
  Case "b_3". apply g_3. apply g_0.
  Case "b_5". apply g_5. apply g_0.
  Case "b_sum". apply gorgeous_sum. assumption. assumption.
Qed.

Lemma helper_g_times2 : forall x y z, x + (z + y)= z + x + y.
Proof.
  intros x y z. induction x.
  Case "x = O".
    simpl. rewrite plus_0_r. reflexivity.
  Case "x = S x".
   assert ( H : z + S x = S x + z ).
       apply plus_comm.
       rewrite H. simpl. rewrite plus_assoc. reflexivity.
Qed.

Theorem g_times2: forall n, gorgeous n -> gorgeous (2 * n).
Proof.
   intros n H. simpl. induction H.
   Case "g_0". simpl. apply g_0.
   Case "g_3". apply g_3 with (n := n + (3 + n + 0)).
   rewrite plus_0_r. rewrite helper_g_times2. apply g_3 with (n := n + n).
   rewrite plus_0_r in IHgorgeous. assumption.
   Case "g_5". apply g_5 with (n := n + (5 + n + 0)). rewrite helper_g_times2.
   rewrite plus_0_r. rewrite plus_0_r in IHgorgeous. apply g_5 with (n := n + n).
   assumption.
Qed.
Print g_times2.

Theorem g_times2': forall n, gorgeous n -> gorgeous (2 * n).
Proof.
  intros n H. apply beautiful__gorgeous with (n := 2 * n).
  apply b_timesm.  apply  gorgeous__beautiful. assumption.
Qed.
(* prevous proof is about moving gorgeous (2 * n ) => beautiful n
and beautiful n to gorgeous n *)

Theorem ev__even : forall n,
  ev n -> even n.
Proof.
  intros n H. induction H. unfold even. simpl. reflexivity.
  unfold even. simpl. assumption.
Qed.

Theorem l : forall n, ev n.
Proof.
  induction n. apply ev_O.
  Abort.

Theorem ev_sum : forall n m,
   ev n -> ev m -> ev (n+m).
Proof.
  intros n m Hn Hm. induction Hn.
  Case "ev_O". simpl. assumption.
  Case "ev_n". simpl. apply ev_SS. assumption.
Qed.

Theorem ev_minus2: forall n, ev n -> ev (pred (pred n)).
Proof.
  intros n H. induction H. simpl. apply ev_O.
  simpl. assumption.
Qed.

Theorem ev_minus2': forall n, ev n -> ev (pred (pred n)).
Proof.
  intros n H. inversion H. simpl. apply ev_O.
  simpl. assumption.
Qed.

Theorem ev_minus2'': forall n, ev n -> ev (pred (pred n)).
Proof.
  intros n H. destruct H eqn: Ht. simpl. apply ev_O.
  simpl. assumption.
Qed.

Theorem SSev__even : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n H. inversion H. assumption.
Qed.

Theorem SSSSev__even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros n H. apply SSev__even in H. apply SSev__even in H. assumption.
Qed.

Theorem SSSSev__even' : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros n H. inversion H. inversion H1. assumption.
Qed.

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros H. inversion H. inversion H1.
  inversion H3.
Qed.

Theorem ev_ev__ev : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros n m E1 E2. induction E2.
  Case "ev_O". assumption.
  Case "ev_SS". apply IHE2. simpl in E1. inversion E1. assumption.
Qed.

Theorem ev_ev_even : forall n m,
   ev n -> ev m -> ev (n + m).
Proof.
  intros n m E1. induction E1. intros. simpl. assumption.
  intros H. simpl. apply ev_SS. apply IHE1. assumption.
Qed.

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
  intros n m p H1 H2.

(*

2 subgoals, subgoal 1 (ID 720)

  n : nat
  m : nat
  p : nat
  H1 : ev (n + m)
  H2 : ev (n + p)
  ============================
   ev m

subgoal 2 (ID 721) is:
 ev p

I am not able to extact the any information from H1 and H2 so stuck
 *)
Abort.

Inductive ev_list {X : Type} : list X -> Prop :=
| el_nil : ev_list []
| el_cc x y l : ev_list l -> ev_list ( x :: y :: l).

Lemma ev_list__ev_length: forall X (l : list X), ev_list l -> ev (length l).
Proof.
  intros X l H. induction H.
  Case "el_nil". apply ev_O.
  Case "el_cc". simpl. apply ev_SS. apply IHev_list.
Qed.

Lemma ev_length__ev_list:
  forall X n, ev n -> forall (l : list X), n = length l -> ev_list l.
Proof.
  intros X n H. induction H.
  Case "ev_O".
  {
    induction l.
    SCase "[]". intros. apply el_nil.
    SCase "Cons n l". intros H. inversion H.
  }
  Case "ev_SS".
  {
    intros l H2. destruct l.
    SCase "[]". inversion H2. destruct l.
    SCase "[x]". inversion H2.
    SCase "{x :: y :: l]". apply el_cc. apply IHev. inversion H2. reflexivity.
  }
Qed.

Inductive pal {X : Type} : list X -> Prop :=
| empty : pal []
| oneelem : forall x,  pal [x]
| manyelem : forall x l, pal l -> pal ( x :: l ++ [x]).

Theorem snoc_list : forall (X : Type) (l : list X) (n : X),
                          snoc l n = l ++ [n].
Proof.
    induction l.
    Case "l = nil". reflexivity.
    Case "l = cons n l". simpl. intros n0. rewrite IHl. reflexivity.
Qed.

Theorem app_assoc : forall  (X : Type) (l1 l2 l3 : list X),
                        (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
    induction l1 as [ | n l'].
    Case "l1 = nil". reflexivity.
    Case "l1 = cons n l'".
    simpl. intros l2 l3. rewrite IHl'. reflexivity.
Qed.

Theorem pal_app_rev : forall (X : Type) (l : list X), pal (l ++ rev l).
Proof.
  intros X l. induction l.
  Case "nil". simpl. apply empty.
  Case "Cons n l". simpl. rewrite snoc_list.
  rewrite <- app_assoc. apply manyelem. assumption.
Qed.

Lemma rev_list : forall ( X : Type ) ( a : X ) ( l : list X ),
  rev ( l ++ [a] ) = a :: rev l.
Proof.
  intros X a l. induction l as [ | v' l'].
  Case "l = nil".
     reflexivity.
  Case "l = Cons v' l'".
    simpl. rewrite -> snoc_list. rewrite -> snoc_list.
    rewrite IHl'. simpl. reflexivity.
Qed.

Theorem pal_rev : forall (X : Type) (l : list X),
                    pal l -> l = rev l.
Proof.
  intros X l H. induction H.
  Case "empty". simpl. reflexivity.
  Case "oneelem". simpl. reflexivity.
  Case "manyelem". simpl. rewrite snoc_list. rewrite rev_list. simpl.
  rewrite <- IHpal. reflexivity.
Qed.

Theorem rev_pal : forall (X : Type) (l : list X),
                    l = rev l -> pal l.
Proof.
  intros X l H. destruct l.
  Case "nil". apply empty. destruct l.
  Case "[x]". apply oneelem.
  Case "x :: y :: l". simpl in H. rewrite snoc_list in H. rewrite snoc_list in H.
  rewrite app_assoc in H.
Abort.

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

Notation "m <= n" := (le m n).
Theorem test_le1 :
  3 <= 3.
Proof.
  apply le_n.
Qed.

Theorem test_le2 :
  3 <= 6.
Proof.
  apply le_S. apply (le_S 3 4). apply (le_S 3 3). apply (le_n 3).
Qed.

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

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

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

Inductive square_of : nat -> nat -> Prop :=
  sq : forall n, square_of n (n * n).

Theorem square3 : square_of 3 9.
Proof.
  apply sq.
Qed.

Inductive next_nat : nat -> nat -> Prop :=
  nn : forall n, next_nat n (S n).

Inductive next_even : nat -> nat -> Prop :=
| ne_1 : forall n, ev (S n) -> next_even n (S n)
| ne_2 : forall n, ev (S (S n)) -> next_even n (S (S n)).

Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o.
Proof.
  intros m n o H1 H2. induction H2.
  assumption.
  apply le_S. apply IHle. assumption.
Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  intros n. induction n. apply le_n. apply le_S. assumption.
Qed.

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

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros n m.  generalize dependent n. induction m.
  Case "m = O". intros n H. inversion H. apply le_n. inversion H2.
  Case "m = S m". intros n H. inversion H.
  apply le_n. apply le_S. apply IHm. apply H2.
Qed.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  intros a b. generalize dependent a. induction b.
  Case "b = O". simpl. intros a. rewrite plus_0_r. apply le_n.
  Case "b = S b". intros a. SearchAbout ( _ + S _).
  rewrite NPeano.Nat.add_succ_r. apply le_S. apply IHb.
Qed.

Theorem plus_lt : forall n1 n2 m,
                    n1 + n2 < m -> n1 < m /\ n2 < m.
Proof.
  unfold lt. intros n1 n2 m H. split.
  Case "left". inversion H.
Abort.

Theorem lt_S : forall n m,
  n < m ->
  n < S m.
Proof.
  unfold lt. intros n m H. apply le_S. assumption.
Qed.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
Proof.
  intros n m H. generalize dependent m. induction n.
  Case "n = O". intros m H. unfold ble_nat in H. induction m.
  apply le_n. apply le_S. assumption.
  Case "n = S n". intros m H. induction m. inversion H. simpl in H. apply IHn in H.
  apply n_le_m__Sn_le_Sm in H. assumption.
Qed.

Theorem le_ble_nat : forall n m,
  n <= m ->
  ble_nat n m = true.
Proof.
  intros n m H. generalize dependent n. induction m.
  Case "m = O". intros n H. inversion H. reflexivity.
  Case "m = S m".
  {
    induction n.
    simpl. intros H. reflexivity.
    simpl. intros H. apply IHm. apply Sn_le_Sm__n_le_m in H. assumption.
  }
Qed.

Theorem ble_nat_true_trans : forall n m o,
  ble_nat n m = true -> ble_nat m o = true -> ble_nat n o = true.
Proof.
  intros n m o H1 H2. apply ble_nat_true in H1. apply ble_nat_true in H2.
  apply le_ble_nat. generalize dependent H2. generalize dependent H1.
  apply le_trans.
Qed.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
Proof.
  unfold not. intros n m H1 H2. apply le_ble_nat in H2.
  rewrite H1 in H2. inversion H2.
Qed.

Inductive sortedlist : list nat -> Prop :=
| nilsorted : sortedlist []
| onesorted : forall x, sortedlist [x]
| morsorted : forall x y ys,
                le x y -> sortedlist (y :: ys) -> sortedlist (x :: y :: ys).

Theorem sorted : sortedlist [1; 2; 3].
Proof.
  apply morsorted. apply le_S. apply le_n.
  apply morsorted. apply le_S. apply le_n.
  apply onesorted.
Qed.

Theorem sorted_inv : forall (n : nat) (l : list nat),
                       sortedlist (n :: l) -> sortedlist l.
Proof.
  intros n l H. induction l.
  Case "l = []". apply nilsorted.
  Case "Cons n l". inversion H. assumption.
Qed.

Module R.

  Inductive R : nat -> nat -> nat -> Prop :=
  | c1 : R 0 0 0
  | c2 : forall m n o, R m n o -> R (S m) n (S o)
  | c3 : forall m n o, R m n o -> R m (S n) (S o)
  | c4 : forall m n o, R (S m) (S n) (S (S o)) -> R m n o
  | c5 : forall m n o, R m n o -> R n m o.

  (* R 1 1 2 is provalbe. c2 -> c3 -> c1 *)
  Theorem provalber112 : R 1 1 2.
  Proof.
    apply c2. apply c3. apply c1.
  Qed.

  Theorem provalber226 : R 2 2 6.
  Proof.
    apply c3. apply c3. apply c5.
    apply c3. apply c3.
  Abort.
End R.

Inductive subseq {X : Type} : list X -> list X -> Prop :=
| emptysubseq : forall l, subseq [] l
| dropsubseq : forall x l1 l2, subseq l1 l2 -> subseq l1 (x :: l2)
| keepsubseq : forall x l1 l2, subseq l1 l2 -> subseq (x :: l1) (x :: l2).

Example subseqexample : subseq [1; 2; 3] [5; 6; 1; 9; 9; 2; 7; 3; 8].
Proof.
  apply dropsubseq. apply dropsubseq. apply keepsubseq.
  apply dropsubseq. apply dropsubseq. apply keepsubseq.
  apply dropsubseq. apply keepsubseq. apply emptysubseq.
Qed.

Theorem subseqreflexive : forall (X : Type) (l : list X), subseq l l.
Proof.
  intros X l. induction l.
  Case "l = []". apply emptysubseq.
  Case "l = x :: l". apply keepsubseq. apply IHl.
Qed.

Lemma app_right : forall (X : Type) (l : list X), l ++ [] = l.
Proof.
  intros X l. induction l.
  Case "l = []". reflexivity.
  Case "l = Cons n l".
  {
    simpl. rewrite IHl. reflexivity.
  }
Qed.

Theorem subseq_app : forall (X : Type) (l1 l2 l3 : list X),
                       subseq l1 l2 -> subseq l1 (l2 ++ l3).
Proof.
  intros X l1 l2 l3 H. induction H.
  Case "emptysubseq". apply emptysubseq.
  Case "dropsubseq". simpl. apply dropsubseq. assumption.
  Case "keepsubseq". simpl. apply keepsubseq. assumption.
Qed.

Theorem subseq_trans : forall (X : Type) (l1 l2 l3 : list X),
                         subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
  intros X l1 l2 l3 H1 H2. induction H1.
  Case "emptysubseq". apply emptysubseq.
Abort.

Inductive R : nat -> list nat -> Prop :=
 | c1 : R 0 []
 | c2 : forall n l, R n l -> R (S n) (n :: l)
 | c3 : forall n l, R (S n) l -> R n l.

(* first  provable. second third is not *)

Theorem r210 : R 2 [1; 0].
Proof. apply c2. apply c2. apply c1. Qed.
Theorem r11210 : R 1 [1;2;1;0].
Proof. Abort.
Theorem r63210 : R 6 [3;2;1;0].
Proof. Abort.

Check (2 + 2 = 4).
Check (ble_nat 2 3 = false).
Check (beautiful 8).
Check (2 + 2 = 5).
Check (beautiful 4).
Theorem plus_2_2_is_4 : 2 + 2 = 4.
Proof. compute. reflexivity. Qed.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true : plus_fact.
Proof. unfold plus_fact. reflexivity. Qed.

Check (even 3).
Check (even 4).
Check even.

Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

Definition teen : nat -> Prop := between 13 19.
Check teen.

Definition true_for_zero (P : nat -> Prop) : Prop := P 0.

Definition true_for_all_number (P : nat -> Prop) : Prop :=
  forall n, P n.

Definition preserverd_by_S (P : nat -> Prop) : Prop :=
  forall n, P n -> P (S n).

Definition natural_number_induction_valid : Prop :=
  forall (P : nat -> Prop),
    true_for_zero P -> preserverd_by_S P -> true_for_all_number P.

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop :=
  fun n => if evenb n then Peven n else Podd n.

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros Podd Peven n H1 H2.
  unfold combine_odd_even. destruct (evenb n) eqn:Hev.
  apply H2. unfold oddb. rewrite Hev. simpl. reflexivity.
  apply H1. unfold oddb. rewrite Hev. simpl. reflexivity.
Qed.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
  unfold combine_odd_even. unfold oddb.
  assert (forall n, negb (evenb n) = true -> evenb n = false).
  {
    intros n. destruct (evenb n) eqn:Hev.
    Case "true". intros H. simpl in H. inversion H.
    Case "false". simpl. intros H. reflexivity.
  }
  intros Podd Peven n H1 H2. apply H in H2. rewrite H2 in H1. assumption.
Qed.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  unfold combine_odd_even, oddb.
  assert (forall n, negb (evenb n) = false -> evenb n = true).
  {
    intros n. destruct (evenb n) eqn: Hev.
    Case "true". intros H. reflexivity.
    Case "false". simpl. intros H. inversion H.
  }
  intros Podd Peven n H1 H2. apply H in H2. rewrite H2 in H1. assumption.
Qed.

(* finished all the problems *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Global Set Automatic Coercions Import.
Global Set Asymmetric Patterns.
Set Implicit Arguments.
Unset Strict Implicit.
(** Title "Sets, relations, maps" *)
Section Sets1.
Comments
  "Basically, algebraic structures are sets, in which we talk about elements, belonging, equality,"
  "applications, equivalence relations, quotient sets, etc".
Comments
  "Types in Coq are not well-suited to represent sets, because they cannot be quotiented".
Comments "We will define sets in Coq as types with an equivalence relation".
Comments "First, we need some definitions on binary relations on types:".
Section Relations.
Variable E : Type.

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

Definition app_rel (R : relation E) (x y : E) := R x y.

Definition reflexive (R : relation E) : Prop := forall x : E, app_rel R x x.

Definition symmetric (R : relation E) : Prop :=
  forall x y : E, app_rel R x y -> app_rel R y x.

Definition transitive (R : relation E) : Prop :=
  forall x y z : E, app_rel R x y -> app_rel R y z -> app_rel R x z.
Comments "A partial equivalence on" E
  " is a relation which is transitive and symmetric:".

Definition partial_equivalence (R : relation E) : Prop :=
  transitive R /\ symmetric R.
Comments "An equivalence relation is reflexive, symmetric and transitive:".

Definition equivalence (R : relation E) : Prop :=
  reflexive R /\ partial_equivalence R.
Comments "Some immediate properties:".

Lemma equiv_refl : forall R : relation E, equivalence R -> reflexive R.
compute in |- *. tauto.
Qed.

Lemma equiv_sym : forall R : relation E, equivalence R -> symmetric R.
compute in |- *; tauto.
Qed.

Lemma equiv_trans : forall R : relation E, equivalence R -> transitive R.
compute in |- *; tauto.
Qed.
End Relations.
Hint Unfold reflexive transitive symmetric partial_equivalence equivalence:
  algebra.
Hint Resolve equiv_refl equiv_sym equiv_trans: algebra.
Comments "Then we define a dedicated structure to represent sets:".

Record Setoid : Type :=
  {Carrier :> Type; Equal : relation Carrier; Prf_equiv :> equivalence Equal}.
Hint Resolve Prf_equiv: algebra.
Comments
  "A set is then given by a type (for its elements), a binary relation"
  "and a proof that this relation is an equivalence relation".
Comments "We will write" (Equal x y)
  "for the equality of two elements of a set".

Lemma Refl : forall (E : Setoid) (x : E), Equal x x.
intros E; try assumption.
cut (reflexive (Equal (s:=E))); auto with algebra.
Qed.

Lemma Sym : forall (E : Setoid) (x y : E), Equal x y -> Equal y x.
intros E; try assumption.
cut (symmetric (Equal (s:=E))); auto with algebra.
Qed.

Lemma Trans :
 forall (E : Setoid) (x y z : E), Equal x y -> Equal y z -> Equal x z.
intros E; try assumption.
cut (transitive (Equal (s:=E))); auto with algebra.
Qed.
Hint Resolve Refl: algebra.
Hint Immediate Sym: algebra.
Comments
  "Every type in Coq can be seen as a set, with the Leibnitz equality:".

Let eqT_equiv : forall A : Type, equivalence (eq (A:=A)).
intros A; try assumption.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
unfold app_rel in |- *; auto with algebra.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
unfold app_rel in |- *; auto with algebra.
intros x y z H' H'0; try assumption.
rewrite H'; auto with algebra.
red in |- *.
unfold app_rel in |- *; auto with algebra.
Qed.

Definition Leibnitz_set (A : Type) : Setoid := Build_Setoid (eqT_equiv A).

Lemma Leibnitz_set_prop :
 forall (A : Type) (x y : Leibnitz_set A), Equal x y -> x = y.
auto with algebra.
Qed.

Lemma Leibnitz_set_prop_rev :
 forall (A : Type) (x y : Leibnitz_set A), x = y -> Equal x y.
auto with algebra.
Qed.
Section Quotient1.
Comments
  "We can now define quotient sets, using equivalence relations on sets".
Comments
  "A binary relation on a set is a binary relation on its carrier, which is compatible with equality:".
Variable E : Setoid.

Definition rel_compatible (R : relation E) : Prop :=
  forall x x' y y' : E,
  Equal x x' -> Equal y y' -> app_rel R x y -> app_rel R x' y'.

Record Relation : Type :=
  {Rel_fun :> relation E; Rel_compatible_prf : rel_compatible Rel_fun}.

Lemma Rel_comp :
 forall (R : Relation) (x x' y y' : E),
 Equal x x' -> Equal y y' -> app_rel R x y -> app_rel R x' y'.
intros R; try assumption.
exact (Rel_compatible_prf (r:=R)).
Qed.
Hint Resolve Rel_comp: algebra.
Variable R : Relation.
Hypothesis R_equiv : equivalence R.
Set Strict Implicit.
Unset Implicit Arguments.

Definition quotient : Setoid := Build_Setoid R_equiv.
Set Implicit Arguments.
Unset Strict Implicit.
End Quotient1.
Section Maps1.
Comments
  "Maps between two sets are functions which are compatible with equalities:".
Section Maps1_1.
Variable A B : Setoid.

Definition fun_compatible (f : A -> B) : Prop :=
  forall x y : A, Equal x y -> Equal (f x) (f y).

Record Map : Type :=
  {Ap :> A -> B; Map_compatible_prf :> fun_compatible Ap:Prop}.
Comments "Two maps are equal when they have the same values:".

Definition Map_eq (f g : Map) : Prop := forall x : A, Equal (f x) (g x).

Let Map_eq_equiv : equivalence Map_eq.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
unfold Map_eq, app_rel in |- *; simpl in |- *; auto with algebra.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
unfold Map_eq, app_rel in |- *; simpl in |- *; auto with algebra.
intros x y z H' H'0 x0; try assumption.
apply Trans with (y x0); auto with algebra.
red in |- *.
unfold Map_eq, app_rel in |- *; simpl in |- *; auto with algebra.
Qed.

Definition MAP : Setoid := Build_Setoid Map_eq_equiv.
Comments "We note" (MAP A B) "the set of maps between" A "and" B.
End Maps1_1.
Comments "Some immediate properties of maps:".

Lemma Ap_comp :
 forall (A B : Setoid) (f g : MAP A B) (x y : A),
 Equal x y -> Equal f g -> Equal (f x) (g y).
intros A B f g x y H' H'0; try assumption.
apply Trans with (f y).
apply (Map_compatible_prf f); auto with algebra.
simpl in H'0.
unfold Map_eq in H'0.
auto with algebra.
Qed.
Hint Resolve Ap_comp: algebra.

Lemma map_ext :
 forall (A B : Setoid) (f g : MAP A B),
 (forall x : A, Equal (f x) (g x)) -> Equal f g.
simpl in |- *.
unfold Map_eq in |- *.
auto with algebra.
Qed.
Hint Resolve map_ext: algebra.
Section Maps1_2.
Comments "We define now injections, surjections and bijections.".
Variable A B : Setoid.

Definition injective (f : MAP A B) : Prop :=
  forall x y : A, Equal (f x) (f y) -> Equal x y.

Definition surjective (f : MAP A B) : Prop :=
  forall y : B, exists x : A, Equal y (f x).

Definition bijective (f : MAP A B) : Prop := injective f /\ surjective f.
End Maps1_2.
Comments "These definitions are coherent with equality of maps:".

Lemma injective_comp :
 forall (A B : Setoid) (f f' : MAP A B),
 injective f -> Equal f f' -> injective f'.
unfold injective in |- *.
intros A B f f' H' H'0 x y H'1; try assumption.
apply H'.
apply Trans with (Ap f' x); auto with algebra.
apply Trans with (Ap f' y); auto with algebra.
Qed.

Lemma surjective_comp :
 forall (A B : Setoid) (f f' : MAP A B),
 surjective f -> Equal f f' -> surjective f'.
unfold surjective in |- *.
intros A B f f' H' H'0 y; try assumption.
elim (H' y); intros x E; try exact E.
exists x; try assumption.
apply Trans with (Ap f x); auto with algebra.
Qed.

Lemma bijective_comp :
 forall (A B : Setoid) (f f' : MAP A B),
 bijective f -> Equal f f' -> bijective f'.
unfold bijective in |- *.
intros A B f f' H' H'0; try assumption.
split; [ try assumption | idtac ].
elim H'; intros H'1 H'2; try exact H'1; clear H'.
apply injective_comp with (f := f); auto with algebra.
elim H'; intros H'1 H'2; try exact H'2; clear H'.
apply surjective_comp with (f := f); auto with algebra.
Qed.
Comments "Trivialities:".

Lemma bijective_injective :
 forall (A B : Setoid) (f : MAP A B), bijective f -> injective f.
intros A B f H'; red in H'; auto with algebra.
elim H'; auto with algebra.
Qed.
Hint Resolve bijective_injective: algebra.

Lemma bijective_surjective :
 forall (A B : Setoid) (f : MAP A B), bijective f -> surjective f.
intros A B f H'; red in H'; auto with algebra.
elim H'; auto with algebra.
Qed.
Hint Resolve bijective_surjective: algebra.
Set Strict Implicit.
Unset Implicit Arguments.

Definition surj_set_quo :
  forall (E : Setoid) (R : Relation E) (p : equivalence R),
  MAP E (quotient E R p).
intros E R p; try assumption.
apply (Build_Map (A:=E) (B:=quotient E R p) (Ap:=fun x : E => x)).
generalize p; clear p.
elim R.
intros Rel_fun' Rel_compatible_prf0 p; try assumption.
red in |- *.
red in Rel_compatible_prf0.
intros x y H'; try assumption.
simpl in |- *.
unfold app_rel in Rel_compatible_prf0.
apply Rel_compatible_prf0 with (x := x) (y := x); auto with algebra.
elim p.
intros H'0 H'1; try assumption.
simpl in H'0.
red in H'0.
unfold app_rel in H'0.
auto with algebra.
Defined.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma surj_set_quo_surjective :
 forall (E : Setoid) (R : Relation E) (p : equivalence R),
 surjective (surj_set_quo E R p).
intros E R p; try assumption.
red in |- *.
intros y; exists y; try assumption.
simpl in |- *.
elim p.
intros H'; red in H'.
unfold app_rel in H'.
auto with algebra.
Qed.
Section Maps1_3.
Comments "We define the composition of maps:".
Variable E F G : Setoid.
Variable g : MAP F G.
Variable f : MAP E F.
Comments
  "First, we define the composition of the functions associated to two maps:"
  f "and" g.

Definition comp_map_fun (x : E) := g (f x).
Comments "Then, we proof that the result is compatible with equality:".

Lemma comp_map_fun_compatible : fun_compatible comp_map_fun.
red in |- *.
unfold comp_map_fun in |- *.
auto with algebra.
Qed.
Comments "With this result, we can build the composed map:".

Definition comp_map_map : MAP E G := Build_Map comp_map_fun_compatible.
End Maps1_3.
Comments "We note" (comp_map_map g f) "the composition of" g "and" f.
Comments "Composition is compatible with equality of maps:".

Lemma comp_map_comp :
 forall (A B C : Setoid) (f f' : MAP A B) (g g' : MAP B C),
 Equal f f' -> Equal g g' -> Equal (comp_map_map g f) (comp_map_map g' f').
unfold comp_map_map in |- *; simpl in |- *.
unfold Map_eq in |- *; simpl in |- *; auto with algebra.
unfold comp_map_fun in |- *.
auto with algebra.
Qed.
Hint Resolve comp_map_comp: algebra.
Comments "Composition is associative:".

Lemma comp_map_assoc :
 forall (A B C D : Setoid) (f : MAP A B) (g : MAP B C) (h : MAP C D),
 Equal (comp_map_map h (comp_map_map g f))
   (comp_map_map (comp_map_map h g) f).
unfold comp_map_map in |- *; simpl in |- *.
unfold Map_eq in |- *; simpl in |- *; auto with algebra.
Qed.
Hint Resolve comp_map_assoc: algebra.
Comments "We define now the identity map:".

Definition Id : forall A : Setoid, MAP A A.
intros A; try assumption.
apply (Build_Map (A:=A) (B:=A) (Ap:=fun x : A => x)).
red in |- *.
auto with algebra.
Defined.
Comments "Identity map is a unit element for composition:".

Lemma Id_unit_r :
 forall (A B : Setoid) (f : MAP A B), Equal (comp_map_map f (Id A)) f.
unfold comp_map_map in |- *; simpl in |- *.
unfold Map_eq in |- *; simpl in |- *; auto with algebra.
Qed.
Hint Resolve Id_unit_r: algebra.

Lemma Id_unit_l :
 forall (A B : Setoid) (f : MAP A B), Equal (comp_map_map (Id B) f) f.
unfold comp_map_map in |- *; simpl in |- *.
unfold Map_eq in |- *; simpl in |- *; auto with algebra.
Qed.
Hint Resolve Id_unit_l: algebra.

Lemma Id_is_bijective : forall A : Setoid, bijective (Id A).
intros A; red in |- *.
split; [ red in |- * | idtac ].
simpl in |- *; auto with algebra.
red in |- *.
intros y; exists y; try assumption; auto with algebra.
Qed.
Hint Resolve Id_is_bijective: algebra.
Comments "Some properties of composition:".

Lemma comp_injective :
 forall (A B C : Setoid) (f : MAP A B) (g : MAP B C),
 injective (comp_map_map g f) -> injective f.
unfold injective in |- *.
intros A B C f g H' x y H'0; try assumption.
apply H'.
unfold comp_map_map in |- *; simpl in |- *.
unfold comp_map_fun in |- *.
auto with algebra.
Qed.
Hint Resolve comp_injective: algebra.

Lemma comp_surjective :
 forall (A B C : Setoid) (f : MAP A B) (g : MAP B C),
 surjective (comp_map_map g f) -> surjective g.
unfold surjective in |- *.
intros A B C f g H' y; try assumption.
elim (H' y); intros x E; try exact E.
simpl in E.
unfold comp_map_fun in E.
exists (Ap f x); try assumption; auto with algebra.
Qed.

Lemma comp_is_id_then_bijective :
 forall (A B : Setoid) (f : MAP A B) (g : MAP B A),
 Equal (comp_map_map g f) (Id A) ->
 Equal (comp_map_map f g) (Id B) -> bijective f.
intros A B f g H' H'0; try assumption.
unfold bijective in |- *.
split; [ try assumption | idtac ].
apply comp_injective with A g; auto with algebra.
apply injective_comp with (f := Id A); auto with algebra.
apply comp_surjective with B g; auto with algebra.
apply surjective_comp with (f := Id B); auto with algebra.
Qed.

Lemma comp_is_id_then_injective :
 forall (A B : Setoid) (f : MAP A B) (g : MAP B A),
 Equal (comp_map_map g f) (Id A) -> injective f.
intros A B f g H'; try assumption.
apply comp_injective with A g; auto with algebra.
apply injective_comp with (f := Id A); auto with algebra.
Qed.

Lemma comp_is_id_then_surjective :
 forall (A B : Setoid) (f : MAP A B) (g : MAP B A),
 Equal (comp_map_map f g) (Id B) -> surjective f.
intros A B f g H'; try assumption.
apply comp_surjective with B g; auto with algebra.
apply surjective_comp with (f := Id B); auto with algebra.
Qed.
End Maps1.
End Sets1.
Hint Immediate Sym: algebra.
Hint Unfold reflexive transitive symmetric partial_equivalence equivalence:
  algebra.
Hint Resolve equiv_refl equiv_sym equiv_trans Prf_equiv Refl Rel_comp Ap_comp
  map_ext bijective_injective bijective_surjective surj_set_quo_surjective
  comp_map_comp comp_map_assoc Id_unit_r Id_unit_l Id_is_bijective
  comp_injective: algebra.


(** * 6.822 Formal Reasoning About Programs, Spring 2022 - Pset 13 *)

Require Import Frap MessagesAndRefinement.

Module Type S.

  Inductive request :=
  | GET (client_id key : nat).

  Definition get_key (req : request) : nat :=
    match req with
    | GET _ key => key
    end.

  Inductive response :=
  | FOUND (client_id key : nat) (value : nat)
  | NOT_FOUND (client_id key : nat).

  Definition request_handler (store : fmap nat nat) (source output : channel) : proc :=
    ??source(req: request);
    match req with
    | GET client_id key =>
      match store $? key with
      | Some v => !!output(FOUND client_id key v); Done
      | None => !!output(NOT_FOUND client_id key); Done
      end
    end.

  Definition split_store (full_store even_store odd_store : fmap nat nat) : Prop :=
    (forall k, k mod 2 = 0  -> even_store $? k = full_store $? k) /\
    (forall k, k mod 2 = 0  -> odd_store  $? k = None) /\
    (forall k, k mod 2 <> 0 -> even_store $? k = None) /\
    (forall k, k mod 2 <> 0 -> odd_store  $? k = full_store $? k).

  Definition request_dispatcher (input forward_even forward_odd : channel) : proc :=
    ??input(req: request);
    if get_key req mod 2 ==n 0 then
      !!forward_even(req); Done
    else
      !!forward_odd(req); Done.

  Definition balanced_handler (even_store odd_store : fmap nat nat) (input output : channel) : proc :=
    New[input; output](forward_even);
    New[input; output; forward_even](forward_odd);
    request_dispatcher input forward_even forward_odd
    || (request_handler even_store forward_even output)
    || (request_handler odd_store forward_odd output).

  Definition correctness: Prop := forall full_store even_store odd_store input output,
      split_store full_store even_store odd_store ->
      input <> output ->
      forall trace,
        couldGenerate (balanced_handler even_store odd_store input output) trace ->
        couldGenerate (request_handler full_store input output) trace.

  (*[30%]*)
  Parameter R_alias_for_grading : fmap nat nat -> fmap nat nat ->
                                  fmap nat nat -> channel -> channel ->
                                  proc -> proc -> Prop.

  (*[70%]*)
  Parameter balanced_handler_correct : correctness.
End S.

(*|
HINTS: A few hints to help you if you get stuck on certain
       problems in Pset 13.
       Beware! Don't read further if you don't want spoilers!
=============================================================
|*)

(*|
HINT 1: First stage of simulation relation R
============================================

Here's the first case of our simulation relation R:

| Stage0 :
    NoDup [input; output] ->
    R fs es os input output
      (balanced_handler es os input output)
      (request_handler fs input output)
|*)

(*|
HINT 2: Second stage of simulation relation R
=============================================

Here's the second case of our simulation relation R:

| Stage1 : forall forward_even,
    NoDup [input; output; forward_even] ->
    R fs es os input output
      (Block forward_even;
       New [input; output; forward_even] (forward_odd);
       request_dispatcher input forward_even forward_odd
       || request_handler es forward_even output
       || request_handler os forward_odd output)
      (request_handler fs input output)
|*)

(*|
HINT 3: Order of invert
=======================

To prove the simulation, you'll get to assume an lstepSilent (or an lstep with an action, in the second subgoal) as well as an R, and you'll have to invert both of them. Depending on which of the two you invert first, your proof might become shorter or longer.
|*)

(*|
HINT 4: Going from Stage0 to Stage1 in case of a silent step
============================================================

In our solution, there's a case where we have to prove that when the implementation takes a silent step starting at what we called Stage0, then the specification can simulate this.
Our goal looks as follows:

  full_store, even_store, odd_store : fmap nat nat
  input, output : nat
  H : split_store full_store even_store odd_store
  H0 : input = output -> False
  pr1' : proc
  H2 : lstepSilent (balanced_handler even_store odd_store input output) pr1'
  H3 : NoDup [input; output]
  ============================
  exists pr2' : proc,
    (lstepSilent) ^* (request_handler full_store input output) pr2' /\
    R full_store even_store odd_store input output pr1' pr2'

And we prove it with the following code:

    + (* After Stage0: generate fresh forward_even channel *)
      invert H2. rename ch into forward_even.
      eexists. split.
      * eapply TrcRefl.
      * eapply Stage1. lists.
|*)

(*|
HINT 5: Going from Stage0 to Stage1 in case of a non-silent step
================================================================

In our solution, there's a case where we have to prove that when the implementation takes a non-silent step starting at what we called Stage0, then the specification can simulate this.
Our goal looks as follows:

  full_store, even_store, odd_store : fmap nat nat
  input, output : nat
  H : split_store full_store even_store odd_store
  H0 : input = output -> False
  a : action
  pr1' : proc
  H2 : lstep (balanced_handler even_store odd_store input output) (Action a) pr1'
  H3 : NoDup [input; output]
  ============================
  exists pr2' pr2'' : proc,
    (lstepSilent) ^* (request_handler full_store input output) pr2' /\
    lstep pr2' (Action a) pr2'' /\ R full_store even_store odd_store input output pr1' pr2''

This is a contradiction, because H2 claims that balanced_handler takes a non-silent step, but the first step it takes is to execute a New, which is silent. So, all we have to do in this case is "invert H2."
|*)