(** * MoreCoq: More About Coq *)

Require Export Poly.

(* ###################################################### *)
(** * More About Coq *)

(* ###################################################### *)
(** ** The [apply] Tactic *)

(** We often encounter situations where the goal to be proved is
    exactly the same as some hypothesis in the context or some
    previously proved lemma. *)

Theorem silly1 : forall (n m o p : nat),
     n = m  ->
     [n,o] = [n,p] ->
     [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  (* At this point, we could finish with "[rewrite -> eq2. reflexivity.]"
     as we have done several times above. But we can achieve the
     same effect in a single step by using the [apply] tactic instead: *)
  apply eq2.  Qed.

(** The [apply] tactic also works with _conditional_ hypotheses
    and lemmas: if the statement being applied is an implication, then
    the premises of this implication will be added to the list of
    subgoals needing to be proved. *)

Theorem silly2 : forall (n m o p : nat),
     n = m  ->
     (forall (q r : nat), q = r -> [q,o] = [r,p]) ->
     [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** You may find it instructive to experiment with this proof
    and see if there is a way to complete it using just [rewrite]
    instead of [apply]. *)

(** Typically, when we use [apply H], the statement [H] will
    begin with a [forall] binding some _universal variables_.  When
    Coq matches the current goal against the conclusion of [H], it
    will try to find appropriate values for these variables.  For
    example, when we do [apply eq2] in the following proof, the
    universal variable [q] in [eq2] gets instantiated with [n] and [r]
    gets instantiated with [m]. *)

Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m)  ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** **** Exercise: 2 stars, optional (silly_ex) *)
(** Complete the following proof without using [simpl]. *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
intros eq1 eq2.
apply eq1. apply eq2.
Qed.

(** [] *)

(** To use the [apply] tactic, the (conclusion of the) fact
    being applied must match the goal _exactly_ -- for example, [apply]
    will not work if the left and right sides of the equality are
    swapped. *)

Theorem silly3_firsttry : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros eq1 eq2.
  simpl.
  (* Here we cannot use [apply] directly *)
Admitted.

(** In this case we can use the [symmetry] tactic, which
    switches the left and right sides of an equality in the goal. *)

Theorem silly3 : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl. (* Actually, this [simpl] is unnecessary, since
            [apply] will do a [simpl] step first. *)
  apply H.  Qed.

(** **** Exercise: 3 stars (apply_exercise1) *)

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  (* Hint: you can use [apply] with previously defined lemmas, not
     just hypotheses in the context.  Remember that [SearchAbout] is
     your friend. *)
 intros l l' eq1.
 rewrite -> eq1.
 symmetry.
 apply rev_involutive.
 Qed.
  (* FILL IN HERE *)
(** [] *)

(** **** Exercise: 1 star (apply_rewrite) *)
(** Briefly explain the difference between the tactics [apply] and
    [rewrite].  Are there situations where both can usefully be
    applied?

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

(* ###################################################### *)
(** ** Inversion *)

(** Recall the definition of natural numbers:
     Inductive nat : Type :=
       | O : nat
       | S : nat -> nat.
    It is clear from this definition that every number has one of two
    forms: either it is the constructor [O] or it is built by applying
    the constructor [S] to another number.  But there is more here than
    meets the eye: implicit in the definition (and in our informal
    understanding of how datatype declarations work in other
    programming languages) are two other facts:

    - The constructor [S] is _injective_.  That is, the only way we can
      have [S n = S m] is if [n = m].

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

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

(** Coq provides a tactic, called [inversion], that allows us to
    exploit these principles in making proofs.

    The [inversion] tactic is used like this.  Suppose [H] is a
    hypothesis in the context (or a previously proven lemma) of the
    form
      c a1 a2 ... an = d b1 b2 ... bm
    for some constructors [c] and [d] and arguments [a1 ... an] and
    [b1 ... bm].  Then [inversion H] instructs Coq to "invert" this
    equality to extract the information it contains about these terms:

    - If [c] and [d] are the same constructor, then we know, by the
      injectivity of this constructor, that [a1 = b1], [a2 = b2],
      etc.; [inversion H] adds these facts to the context, and tries
      to use them to rewrite the goal.

    - If [c] and [d] are different constructors, then the hypothesis
      [H] is contradictory.  That is, a false assumption has crept
      into the context, and this means that any goal whatsoever is
      provable!  In this case, [inversion H] marks the current goal as
      completed and pops it off the goal stack. *)

(** The [inversion] tactic is probably easier to understand by
    seeing it in action than from general descriptions like the above.
    Below you will find example theorems that demonstrate the use of
    [inversion] and exercises to test your understanding. *)

Theorem eq_add_S : forall (n m : nat),
     S n = S m ->
     n = m.
Proof.
  intros n m eq. inversion eq. reflexivity.  Qed.

Theorem silly4 : forall (n m : nat),
     [n] = [m] ->
     n = m.
Proof.
  intros n o eq. inversion eq. reflexivity.  Qed.

(** As a convenience, the [inversion] tactic can also
    destruct equalities between complex values, binding
    multiple variables as it goes. *)

Theorem silly5 : forall (n m o : nat),
     [n,m] = [o,o] ->
     [n] = [m].
Proof.
  intros n m o eq. inversion eq. reflexivity. Qed.

(** **** Exercise: 1 star (sillyex1) *)
Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof.
intros X x y z l j eq.
inversion eq.
intros eq2.
inversion eq2.
reflexivity.
Qed.

(** [] *)

Theorem silly6 : forall (n : nat),
     S n = O ->
     2 + 2 = 5.
Proof.
  intros n contra. inversion contra. Qed.

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

(** **** Exercise: 1 star (sillyex2) *)
Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = [] ->
     y :: l = z :: j ->
     x = z.
Proof.
intros X x y z l j contra.
inversion contra.
Qed.

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

(** While the injectivity of constructors allows us to reason
    [forall (n m : nat), S n = S m -> n = m], the reverse direction of
    the implication, provable by standard equational reasoning, is a
    useful fact to record for cases we will see several times. *)

Lemma eq_remove_S : forall n m,
  n = m -> S n = S m.
Proof. intros n m eq. rewrite -> eq. reflexivity. Qed.

(** Here's another illustration of [inversion].  This is a slightly
    roundabout way of stating a fact that we have already proved
    above.  The extra equalities force us to do a little more
    equational reasoning and exercise some of the tactics we've seen
    recently. *)

Theorem length_snoc' : forall (X : Type) (v : X)
                              (l : list X) (n : nat),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  intros X v l. induction l as [| v' l'].
  Case "l = []". intros n eq. rewrite <- eq. reflexivity.
  Case "l = v' :: l'". intros n eq. simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply eq_remove_S. apply IHl'. inversion eq. reflexivity. Qed.

(* ###################################################### *)
(** ** Varying the Induction Hypothesis *)

(** Here is a more realistic use of inversion to prove a
    property that is useful in many places later on... *)

Theorem beq_nat_eq_FAILED : forall n m,
  true = beq_nat n m -> n = m.
Proof.
  intros n m H. induction n as [| n'].
  Case "n = 0".
    destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl in H. inversion H.
  Case "n = S n'".
    destruct m as [| m'].
    SCase "m = 0". simpl in H. inversion H.
    SCase "m = S m'".
      apply eq_remove_S.
      (* stuck here because the induction hypothesis
         talks about an extremely specific m *)
      Admitted.

(** The inductive proof above fails because we've set up things so
    that the induction hypothesis (in the second subgoal generated by
    the [induction] tactic) is

       [ true = beq_nat n' m -> n' = m ].

     This hypothesis makes a statement about [n'] together with the
     _particular_ natural number [m] -- that is, the number [m], which
     was introduced into the context by the [intros] at the top of the
     proof, is "held constant" in the induction hypothesis.  This
     induction hypothesis is not strong enough to make the induction
     step of the proof go through.

     If we set up the proof slightly differently by introducing just
     [n] into the context at the top, then we get an induction
     hypothesis that makes a stronger claim:

      [ forall m : nat, true = beq_nat n' m -> n' = m ]

     Setting up the induction hypothesis this way makes the proof of
     [beq_nat_eq] go through: *)

Theorem beq_nat_eq : forall n m,
  true = beq_nat n m -> n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m. destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl. intros contra. inversion contra.
  Case "n = S n'".
    intros m. destruct m as [| m'].
    SCase "m = 0". simpl. intros contra. inversion contra.
    SCase "m = S m'". simpl. intros H.
      apply eq_remove_S. apply IHn'. apply H. Qed.

(** Similar issues will come up in _many_ of the proofs below.  If you
    ever find yourself in a situation where the induction hypothesis
    is insufficient to establish the goal, consider going back and
    doing fewer [intros] to make the IH stronger. *)

(** **** Exercise: 2 stars, advanced (beq_nat_eq_informal) *)
(** Give an informal proof of [beq_nat_eq]. *)

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

(** **** Exercise: 3 stars (beq_nat_eq') *)
(** We can also prove beq_nat_eq by induction on [m], though we have
    to be a little careful about which order we introduce the
    variables, so that we get a general enough induction hypothesis --
    this is done for you below.  Finish the following proof.  To get
    maximum benefit from the exercise, try first to do it without
    looking back at the one above. *)

Theorem beq_nat_eq' : forall m n,
  beq_nat n m = true -> n = m.
Proof.
  intros m. induction m as [| m'].
  Case "m = 0".
  intros n. destruct n.
    SCase "n = 0". intros eq1. reflexivity.
    SCase "n = S n'". intros contra1. inversion contra1.
  Case "m = S m'".
  intros n.  destruct n.
    SCase "n = 0". intros contra2. inversion contra2.
    SCase "n = S n'".  simpl. intros eq2. apply eq_remove_S.
    apply IHm'. apply eq2. Qed.
  (* FILL IN HERE *)
(** [] *)

(* ###################################################### *)
(** *** Practice Session *)

(** **** Exercise: 2 stars, optional (practice) *)
(** Some nontrivial but not-too-complicated proofs to work together in
    class, and some for you to work as exercises.  Some of the
    exercises may involve applying lemmas from earlier lectures or
    homeworks. *)

Theorem beq_nat_0_l : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
  intros n eq1. destruct n.
  Case "n = 0". reflexivity.
  Case "n = S n'". inversion eq1.
  Qed.
  (* FILL IN HERE *)

Theorem beq_nat_0_r : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
  intros n eq1. destruct n.
  Case "n = 0". reflexivity.
  Case "n = S n'". inversion eq1.
  Qed.
  (* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars (apply_exercise2) *)
(** In the following proof opening, notice that we don't introduce [m]
    before performing induction.  This leaves it general, so that the
    IH doesn't specify a particular [m], but lets us pick.  Finish the
    proof. *)

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". destruct m as [| m'].
     SCase "m = 0". reflexivity.
     SCase "m = S m'". reflexivity.
  Case "n = S n'". destruct m as [| m'].
     SCase "m = 0". reflexivity.
     SCase "m = S m'". simpl. apply IHn'. Qed.
  (* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, advanced (beq_nat_sym_informal) *)
(** Provide an informal proof of this lemma that corresponds
    to your formal proof above:

   Theorem: For any [nat]s [n] [m], [beq_nat n m = beq_nat m n].

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

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

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

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

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

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

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

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

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

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

(** **** Exercise: 3 stars (plus_n_n_injective) *)
(** You can practice using the "in" variants in this exercise. *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". intros m eq1. destruct m.
     SCase "m = 0". reflexivity.
     SCase "m = S m'". inversion eq1.
  Case "n = S n'". intros m eq2. destruct m as [| m'].
     SCase "m = 0".

    (* Hint: use the plus_n_Sm lemma *)
    (* FILL IN HERE *) Admitted.
(** [] *)

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

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

    Here are some examples: *)

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

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity.  Qed.

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

(** **** Exercise: 1 star (override_shadow) *)
Theorem override_shadow : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (combine_split) *)
(*
Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| [x y] l'].
  (* FILL IN HERE *) Admitted.
*)
(** [] *)

(** **** Exercise: 3 stars (split_combine) *)
(** Thought exercise: We have just proven that for all lists of pairs,
    [combine] is the inverse of [split].  How would you state the
    theorem showing that [split] is the inverse of [combine]?

    Hint: what property do you need of [l1] and [l2] for [split]
    [combine l1 l2 = (l1,l2)] to be true?

    State this theorem in Coq, and prove it. (Be sure to leave your
    induction hypothesis general by not doing [intros] on more things
    than necessary.) *)

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

(* ###################################################### *)
(** ** The [remember] Tactic *)

(** (Note: the [remember] tactic is not strictly needed until a
    bit later, so if necessary this section can be skipped and
    returned to when needed.) *)

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

    Sometimes, however, this substitution process loses information
    that we need in order to complete the proof.  For example, suppose
    we define a function [sillyfun1] like this: *)

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

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

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

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

    What we would really like is not to use [destruct] directly on
    [beq_nat n 3] and substitute away all occurrences of this
    expression, but rather to use [destruct] on something else that is
    _equal_ to [beq_nat n 3].  For example, if we had a variable that
    we knew was equal to [beq_nat n 3], we could [destruct] this
    variable instead.

    The [remember] tactic allows us to introduce such a variable. *)

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
   remember (beq_nat n 3) as e3.
   (* At this point, the context has been enriched with a new
      variable [e3] and an assumption that [e3 = beq_nat n 3].
      Now if we do [destruct e3]... *)
   destruct e3.
   (* ... the variable [e3] gets substituted away (it
     disappears completely) and we are left with the same
      state as at the point where we got stuck above, except
      that the context still contains the extra equality
      assumption -- now with [true] substituted for [e3] --
      which is exactly what we need to make progress. *)
     Case "e3 = true". apply beq_nat_eq in Heqe3.
       rewrite -> Heqe3. reflexivity.
     Case "e3 = false".
      (* When we come to the second equality test in the
        body of the function we are reasoning about, we can
         use [remember] again in the same way, allowing us
         to finish the proof. *)
       remember (beq_nat n 5) as e5. destruct e5.
         SCase "e5 = true".
           apply beq_nat_eq in Heqe5.
           rewrite -> Heqe5. reflexivity.
         SCase "e5 = false". inversion eq.  Qed.

(** **** Exercise: 2 stars *)
Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (override_same) *)
Theorem override_same : forall {X:Type} x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override f k1 x1) k2 = f k2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (filter_exercise) *)
(** This one is a bit challenging.  Be sure your initial [intros] go
    only up through the parameter on which you want to do
    induction! *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** The [apply ... with ...] Tactic *)

(** The following silly example uses two rewrites in a row to
    get from [[a,b]] to [[e,f]]. *)

Example trans_eq_example : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** Since this is a common pattern, we might
    abstract it out as a lemma recording once and for all
    the fact that equality is transitive. *)

Theorem trans_eq : forall {X:Type} (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.  Qed.

(** Now, we should be able to use [trans_eq] to
    prove the above example.  However, to do this we need
    a slight refinement of the [apply] tactic. *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  (* If we simply tell Coq [apply trans_eq] at this point,
     it can tell (by matching the goal against the
     conclusion of the lemma) that it should instantiate [X]
     with [[nat]], [n] with [[a,b]], and [o] with [[e,f]].
     However, the matching process doesn't determine an
     instantiation for [m]: we have to supply one explicitly
     by adding [with (m:=[c,d])] to the invocation of
     [apply]. *)
  apply trans_eq with (m:=[c,d]). apply eq1. apply eq2.   Qed.

(**  Actually, we usually don't have to include the name [m]
    in the [with] clause; Coq is often smart enough to
    figure out which instantiation we're giving. We could
    instead write: apply trans_eq with [c,d]. *)

(** **** Exercise: 3 stars (apply_exercises) *)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem beq_nat_trans : forall n m p,
  true = beq_nat n m ->
  true = beq_nat m p ->
  true = beq_nat n p.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem override_permute : forall {X:Type} x1 x2 k1 k2 k3 (f : nat->X),
  false = beq_nat k2 k1 ->
  (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################## *)
(** * Review *)

(** We've now seen a bunch of Coq's fundamental tactics -- enough to
    do pretty much everything we'll want for a while.  We'll introduce
    one or two more as we go along through the next few lectures, and
    later in the course we'll introduce some more powerful
    _automation_ tactics that make Coq do more of the low-level work
    in many cases.  But basically we've got what we need to get work
    done.

    Here are the ones we've seen:

      - [intros]:
        move hypotheses/variables from goal to context

      - [reflexivity]:
        finish the proof (when the goal looks like [e = e])

      - [apply]:
        prove goal using a hypothesis, lemma, or constructor

      - [apply... in H]:
        apply a hypothesis, lemma, or constructor to a hypothesis in
        the context (forward reasoning)

      - [apply... with...]:
        explicitly specify values for variables that cannot be
        determined by pattern matching

      - [simpl]:
        simplify computations in the goal

      - [simpl in H]:
        ... or a hypothesis

      - [rewrite]:
        use an equality hypothesis (or lemma) to rewrite the goal

      - [rewrite ... in H]:
        ... or a hypothesis

      - [symmetry]:
        changes a goal of the form [t=u] into [u=t]

      - [symmetry in H]:
        changes a hypothesis of the form [t=u] into [u=t]

      - [unfold]:
        replace a defined constant by its right-hand side in the goal

      - [unfold... in H]:
        ... or a hypothesis

      - [destruct... as...]:
        case analysis on values of inductively defined types

      - [induction... as...]:
        induction on values of inductively defined types

      - [inversion]:
        reason by injectivity and distinctness of constructors

      - [remember (e) as x]:
        give a name ([x]) to an expression ([e]) so that we can
        destruct [x] without "losing" [e]

      - [assert (e) as H]:
        introduce a "local lemma" [e] and call it [H]
*)

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

(** **** Exercise: 4 stars (forall_exists_challenge) *)
(** Challenge problem: Define two recursive [Fixpoints],
    [forallb] and [existsb].  The first checks whether every
    element in a list satisfies a given predicate:
      forallb oddb [1,3,5,7,9] = true

      forallb negb [false,false] = true

      forallb evenb [0,2,4,5] = false

      forallb (beq_nat 5) [] = true
    The function [existsb] checks whether there exists an element in
    the list that satisfies a given predicate:
      existsb (beq_nat 5) [0,2,3,6] = false

      existsb (andb true) [true,true,false] = true

      existsb oddb [1,0,0,0,0,3] = true

      existsb evenb [] = false
    Next, create a _nonrecursive_ [Definition], [existsb'], using
    [forallb] and [negb].

    Prove that [existsb'] and [existsb] have the same behavior.
*)

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

(* $Date: 2013-01-22 11:34:02 -0500 (Tue, 22 Jan 2013) $ *)


(*|
##########################################################
What does ``Proof. simpl. reflexivity. Qed.`` mean in Coq?
##########################################################

:Link: https://stackoverflow.com/q/64246592
|*)

(*|
Question
********

I'm reading the book Software Foundations and got stuck at the very
beginning.

The author defined a boolean type and common operations:
|*)

Inductive bool: Type :=
| true
| false.

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

(*|
So let's say we want to prove the correctness of the ``or`` function.
The author wrote a test followed by a proof:
|*)

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

(*|
Could someone explain to me what ``simpl. reflexivity.`` mean? Is
there any other way we can prove this simple test?
|*)

(*|
Answer
******

``simpl`` is a tactic evaluating the goal. In your case, after
executing it, the goal will be left to ``true = true``.
``reflexivity`` is a tactic discharging goals of the shape ``x = x``
(in its simplest incarnation). What it does under the hood is to
provide the proof term ``eq_refl : x = x`` as a solution to the
current proof obligation.

Now, there are many ways to achieve this thing that ultimately will
produce the same (rather trivial) proof ``eq_refl`` (try doing ``Print
test_orb1.``). First, the ``simpl`` operation is not needed because
Coq will do some computations when applying a term (in particular when
calling ``reflexivity``). Second, you could obtain the same effect as
``reflexivity`` by calling ``constructor``, ``apply eq_refl`` or
``refine eq_refl``. These are tactics with different goals but that
happen to coincide here.
|*)


(* (c) Copyright Microsoft Corporation and Inria. You may distribute   *)
(* under the terms of either the CeCILL-B License or the CeCILL        *)
(* version 2 License, as specified in the README file.                 *)
Require Import ssreflect.

(****************************************************************************)
(* This file contains the basic definitions and notations for working with  *)
(* functions. The definitions concern:                                      *)
(*                                                                          *)
(*  Pair projections                                                        *)
(*    p.1  == first element of a pair                                       *)
(*    p.2  == second element of a pair                                      *)
(*                                                                          *)
(*  Simplifying functions, beta-reduced by simpl and /= :                   *)
(*           [fun : T => E] == constant function from type T that returns E *)
(*             [fun x => E] == unary function                               *)
(*         [fun x : T => E] == unary function with explicit domain type     *)
(*           [fun x y => E] == binary function                              *)
(*       [fun x y : T => E] == binary function with explicit domain type    *)
(*     [fun (x : T) y => E] == binary function with explicit domain type    *)
(*     [fun x (y : T) => E] == binary function with explicit domain type    *)
(*    [fun (x : xT) (y : yT) => E]                                          *)
(*                                                                          *)
(* - partial functions using option type,                                   *)
(*     oapp f d ox == if ox is Some x returns f x,        d otherwise       *)
(*      odflt d ox == if ox is Some x returns x,          d otherwise       *)
(*      obind f ox == if ox is Some x returns f x,        None otherwise    *)
(*       omap f ox == if ox is Some x returns Some (f x), None otherwise    *)
(*                                                                          *)
(* - extensional equality for functions and relations (i.e. functions of 2  *)
(*   arguments),                                                            *)
(*    f1 =1 f2      ==  f1 x is equal to f2 x forall x                      *)
(*    f1 =1 f2 :>A  ==    ... and f2 is explicitly typed                    *)
(*    f1 =2 f2      ==  f1 x y is equal to f2 x y forall x y                *)
(*    f1 =2 f2 :> A ==    ... and f2 is explicitly typed                    *)
(*                                                                          *)
(* - composition for total and partial functions,                           *)
(*             f^~y == function f with y as second argument y               *)
(*        f1 \o f2  == composition of f1 and f2                             *)
(*      pcomp f1 f2 == composition of partial functions f1 and f2           *)
(*                                                                          *)
(* - properties of functions                                                *)
(*        injective f == f is injective                                     *)
(*         cancel f g == g is the inverse of f                              *)
(*        pcancel f g == g is the inverse of f where g is partial           *)
(*        ocancel f g == g is the inverse of f where f is partial           *)
(*        bijective f == f is bijective                                     *)
(*       involutive f == f is involutive                                    *)
(*                                                                          *)
(* - properties for operations                                              *)
(*                left_id e op == e is a left identity for op               *)
(*               right_id e op == e is a right identity for op              *)
(*         left_inverse e i op == i is a left inverse for op with unit e    *)
(*        right_inverse e i op == i is a right inverse for op with unit e   *)
(*         self_inverse x e op == x is its own inverse for op               *)
(*             idempotent x op == x is idempotent                           *)
(*                associate op == op is associative                         *)
(*              commutative op == op is commutative                         *)
(*         left_commutative op == op is left commutative                    *)
(*        right_commutative op == op is right commutative                   *)
(*              left_zero z op == z is a right zero for op                  *)
(*             right_zero z op == z is a right zero for op                  *)
(*   left_distributive op1 op2 == op1 is left distributive for op2          *)
(*  right_distributive op1 op2 == op1 is right distributive for op2         *)
(*                                                                          *)
(* - morphisms for functions and relations,                                 *)
(*  {morph f : x / a >-> r } == f is a morphism with respect to functions   *)
(*                                 (fun x => a) and (fun x => r)            *)
(*  {morph f : x / a } == f is a morphism with respect to (fun x => a)      *)
(*  {morph f : x y / a >-> r } == f is a morphism with respect to functions *)
(*                                 (fun x y => a) and (fun x y => r)        *)
(*  {morph f : x / a } == f is a morphism with respect to (fun x y => a)    *)
(*                                                                          *)
(* The file also contains some basic lemmas for the above concepts.         *)
(****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Delimit Scope fun_scope with FUN.
Open Scope fun_scope.

Notation "f ^~ y" := (fun x => f x y)
  (at level 10, y at level 8, no associativity, format "f ^~  y") : fun_scope.

Delimit Scope pair_scope with PAIR.
Open Scope pair_scope.

(* Notations for pair projections *)
Notation "p .1" := (fst p)
  (at level 2, left associativity, format "p .1") : pair_scope.
Notation "p .2" := (snd p)
  (at level 2, left associativity, format "p .2") : pair_scope.

(* Reserved notations for evaluation *)
Reserved Notation "e .[ x ]"
  (at level 2, left associativity, format "e .[ x ]").

Reserved Notation "e .[ x1 , x2 , .. , xn ]"
  (at level 2, left associativity,
   format "e '[ ' .[ x1 , '/'  x2 , '/'  .. , '/'  xn ] ']'").

(* Reserved notations for subscripting and superscripting *)
Reserved Notation "x ^-1"
  (at level 3, left associativity, format "x ^-1").

Reserved Notation "x *+ n" (at level 40, left associativity).
Reserved Notation "x *- n" (at level 40, left associativity).
Reserved Notation "x ^+ n" (at level 29, left associativity).
Reserved Notation "x ^- n" (at level 29, left associativity).

Reserved Notation "s `_ i"
  (at level 3, i at level 2, left associativity, format "s `_ i").

(* Complements on the option type constructor, used below to  *)
(* encode partial functions.                                  *)

Module Option.

Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x.

Definition default T := apply (fun x : T => x).

Definition bind aT rT (f : aT -> option rT) := apply f None.

Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)).

End Option.

Notation oapp := Option.apply.
Notation odflt := Option.default.
Notation obind := Option.bind.
Notation omap := Option.map.
Notation some := (@Some _) (only parsing).

(* Syntax for defining auxiliary recursive function.          *)
(*  Usage:                                                    *)
(* Section FooDefinition.                                     *)
(* Variables (g1 : T1) (g2 : T2).  (globals)                  *)
(* Fixoint foo_auxiliary (a3 : T3) ... :=                     *)
(*        body, using [rec e3, ...] for recursive calls       *)
(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary.          *)
(* Definition foo x y .. := [rec e1, ...].                    *)
(* + proofs about foo                                         *)
(* End FooDefinition.                                         *)

Reserved Notation "[ 'rec' a0 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"
  (at level 0).

(* Definitions and notation for explicit functions with simplification,     *)
(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *)

Section SimplFun.

Variables aT rT : Type.

CoInductive simpl_fun : Type := SimplFun of aT -> rT.

Definition fun_of_simpl := fun f x => let: SimplFun lam := f in lam x.

Coercion fun_of_simpl : simpl_fun >-> Funclass.

End SimplFun.

Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E))
  (at level 0,
   format "'[hv' [ 'fun' :  T  => '/ '  E ] ']'") : fun_scope.

Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E))
  (at level 0, x ident,
   format "'[hv' [ 'fun'  x  => '/ '  E ] ']'") : fun_scope.

Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E))
  (at level 0, x ident, only parsing) : fun_scope.

Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E])
  (at level 0, x ident, y ident,
   format "'[hv' [ 'fun'  x  y  => '/ '  E ] ']'") : fun_scope.

Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" :=
    (fun x : xT => [fun y : yT => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

(* For delta functions in eqtype.v. *)
Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z].

(* Shorthand for some basic equality lemmas. *)

Definition erefl := refl_equal.
Definition esym := sym_eq.
Definition nesym := sym_not_eq.
Definition etrans := trans_eq.
Definition congr1 := f_equal.
Definition congr2 := f_equal2.
(* Force at least one implicit when used as a view. *)
Prenex Implicits esym nesym.

(* Extensional equality, for unary and binary functions, including syntactic *)
(* sugar.                                                                    *)

Section ExtensionalEquality.

Variables A B C : Type.

Definition eqfun (f g : B -> A) : Prop := forall x, f x = g x.

Definition eqrel (r s : C -> B -> A) : Prop := forall x y, r x y = s x y.

Lemma frefl : forall f, eqfun f f. Proof. by []. Qed.
Lemma fsym : forall f g, eqfun f g -> eqfun g f. Proof. by move=> f g E x. Qed.

Lemma ftrans : forall f g h, eqfun f g -> eqfun g h -> eqfun f h.
Proof. by move=> f g h eqfg eqgh x; rewrite eqfg. Qed.

Lemma rrefl : forall r, eqrel r r. Proof. by []. Qed.

End ExtensionalEquality.

Hint Resolve frefl rrefl.

Notation "f1 =1 f2" := (eqfun f1 f2)
  (at level 70, no associativity) : fun_scope.
Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A))
  (at level 70, f2 at next level, A at level 90) : fun_scope.
Notation "f1 =2 f2" := (eqrel f1 f2)
  (at level 70, no associativity) : fun_scope.
Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A))
  (at level 70, f2 at next level, A, B at level 90) : fun_scope.

Section Composition.

Variables A B C : Type.

Definition comp (f : B -> A) (g : C -> B) := [fun x => f (g x)].

Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x).

Lemma eq_comp : forall f f' g g', f =1 f' -> g =1 g' -> comp f g =1 comp f' g'.
Proof. by move=> f f' g g' Ef Eg x; rewrite /= Eg Ef. Qed.

End Composition.

Notation "[ 'eta' f ]" := (fun x => f x)
  (at level 0, format "[ 'eta'  f ]") : fun_scope.

Notation id := (fun x => x).
Notation "@ 'id' T " := (fun x : T => x)
  (at level 10, T at level 8, only parsing) : fun_scope.

Notation "f1 \o f2" := (comp f1 f2) (at level 50) : fun_scope.

Definition idfun T := @id T.
Prenex Implicits idfun.

Section OperationProperties.

Variable T : Type.
Variables zero one: T.
Variable inv : T -> T.
Variables mul add : T -> T -> T.

Notation Local "1" := one.
Notation Local "0" := zero.
Notation Local "x ^-1" := (inv x).
Notation Local "x * y"  := (mul x y).
Notation Local "x + y"  := (add x y).

Definition left_id          := forall x,     1 * x = x.
Definition right_id         := forall x,     x * 1 = x.
Definition left_inverse       := forall x,     x^-1 * x = 1.
Definition right_inverse      := forall x,     x * x^-1 = 1.
Definition self_inverse       := forall x,     x * x = 1.
Definition idempotent         := forall x,     x * x = x.
Definition associative        := forall x y z, x * (y * z) = x * y * z.
Definition commutative        := forall x y,   x * y = y * x.
Definition left_commutative   := forall x y z, x * (y * z) = y * (x * z).
Definition right_commutative  := forall x y z, x * y * z = x * z * y.
Definition left_zero          := forall x,     0 * x = 0.
Definition right_zero         := forall x,     x * 0 = 0.
Definition left_distributive  := forall x y z, (x + y) * z = x * z + y * z.
Definition right_distributive := forall x y z, x * (y + z) = x * y + x * z.

End OperationProperties.

Section Morphism.

Variables (aT rT sT : Type) (f : aT -> rT).

Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x).
Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y).

End Morphism.

Notation "{ 'morph' f : x / a >-> r }" :=
  (morphism_1 f (fun x => a) (fun x => r))
  (at level 0, f at level 99, x ident,
   format "{ 'morph'  f  :  x  /  a  >->  r }") : type_scope.

Notation "{ 'morph' f : x / a }" :=
  (morphism_1 f (fun x => a) (fun x => a))
  (at level 0, f at level 99, x ident,
   format "{ 'morph'  f  :  x  /  a }") : type_scope.

Notation "{ 'morph' f : x y / a >-> r }" :=
  (morphism_2 f (fun x y => a) (fun x y => r))
  (at level 0, f at level 99, x ident, y ident,
   format "{ 'morph'  f  :  x  y  /  a  >->  r }") : type_scope.

Notation "{ 'morph' f : x y / a }" :=
  (morphism_2 f (fun x y => a) (fun x y => a))
  (at level 0, f at level 99, x ident, y ident,
   format "{ 'morph'  f  :  x  y  /  a }") : type_scope.

(* In an intuitionistic setting, we have two degrees of injectivity. The     *)
(* weaker one gives only simplification, and the strong one provides a left  *)
(* inverse (we show in `fintype' that they coincide for finite types).       *)
(* We also define an intermediate version where the left inverse is only a   *)
(* partial function.                                                         *)

Section Injections.

(* rT must come first so we can use @ to mitigate the Coq 1st order   *)
(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *)
Variables (rT aT : Type) (f : aT -> rT).

Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2.

Definition cancel g := forall x, g (f x) = x.

Definition pcancel g := forall x, g (f x) = Some x.

Definition ocancel (g : aT -> option rT) h := forall x, oapp h x (g x) = x.

Lemma can_pcan : forall g, cancel g -> pcancel (fun y => Some (g y)).
Proof. by move=> g fK x; congr (Some _). Qed.

Lemma pcan_inj : forall g, pcancel g -> injective.
Proof. by move=> g fK x y; move/(congr1 g); rewrite !fK => [[]]. Qed.

Lemma can_inj : forall g, cancel g -> injective.
Proof. by move=> g; move/can_pcan; exact: pcan_inj. Qed.

Lemma canLR : forall g x y, cancel g -> x = f y -> g x = y.
Proof. by move=> g x y fK ->. Qed.

Lemma canRL : forall g x y, cancel g -> f x = y -> x = g y.
Proof. by move=> g x y fK <-. Qed.

End Injections.

Section InjectionsTheory.

Variables (A B C : Type) (f g : B -> A) (h : C -> B).

Lemma inj_id : injective (@id A).
Proof. by []. Qed.

Lemma inj_can_sym : forall f', cancel f f' -> injective f' -> cancel f' f.
Proof. move=> f' fK injf' x; exact: injf'. Qed.

Lemma inj_comp : injective f -> injective h -> injective (f \o h).
Proof. move=> injf injh x y; move/injf; exact: injh. Qed.

Lemma can_comp : forall f' h',
  cancel f f' -> cancel h h' -> cancel (f \o h) (h' \o f').
Proof. by move=> f' h' fK hK x; rewrite /= fK hK. Qed.

Lemma pcan_pcomp : forall f' h',
  pcancel f f' -> pcancel h h' -> pcancel (f \o h) (pcomp h' f').
Proof. by move=> f' h' fK hK x; rewrite /pcomp fK /= hK. Qed.

Lemma eq_inj : injective f -> f =1 g -> injective g.
Proof. by move=> injf eqfg x y; rewrite -2!eqfg; exact: injf. Qed.

Lemma eq_can : forall f' g', cancel f f' -> f =1 g -> f' =1 g' -> cancel g g'.
Proof. by move=> f' g' fK eqfg eqfg' x; rewrite -eqfg -eqfg'. Qed.

Lemma inj_can_eq : forall f',
  cancel f f' -> injective f' -> cancel g f' -> f =1 g.
Proof. by move=> f' fK injf' gK x; apply: injf'; rewrite fK. Qed.

End InjectionsTheory.

Section Bijections.

Variables (A B : Type) (f : B -> A).

Definition bijective : Prop := exists2 g, cancel f g & cancel g f.

Hypothesis bijf : bijective.

Lemma bij_inj : injective f.
Proof. by case: bijf => [h fK _]; apply: can_inj fK. Qed.

Lemma bij_can_sym : forall f', cancel f' f <-> cancel f f'.
Proof.
move=> f'; split=> fK; first exact: inj_can_sym fK bij_inj.
by case: bijf => [h _ hK] x; rewrite -[x]hK fK.
Qed.

Lemma bij_can_eq : forall f' f'', cancel f f' -> cancel f f'' -> f' =1 f''.
Proof.
by move=> f' f'' fK fK'; apply: (inj_can_eq _ bij_inj); apply/bij_can_sym.
Qed.

End Bijections.

Section BijectionsTheory.

Variables (A B C : Type) (f : B -> A) (h : C -> B).

Lemma eq_bij : bijective f -> forall g, f =1 g -> bijective g.
Proof. by move=> [f' fK f'K] g eqfg; exists f'; eapply eq_can; eauto. Qed.

Lemma bij_comp : bijective f -> bijective h -> bijective (f \o h).
Proof.
move=> [f' fK f'K] [h' hK h'K].
by exists (h' \o f' : _ -> _); apply can_comp; auto.
Qed.

Lemma bij_can_bij : bijective f -> forall f', cancel f f' -> bijective f'.
Proof. by move=> bijf; exists f; first by apply/(bij_can_sym bijf). Qed.

End BijectionsTheory.

Section Involutions.

Variables (A : Type) (f : A -> A).

Definition involutive := cancel f f.

Hypothesis Hf : involutive.

Lemma inv_inj : injective f. Proof. exact: can_inj Hf. Qed.
Lemma inv_bij : bijective f. Proof. by exists f. Qed.

End Involutions.


Require Import ssreflect.

Definition one : nat := 1.

(* Definition one := 1. *)

Definition one' := 1.
Print one'.

Definition double x := x + x.
Print double.

Eval compute in double 2.

Definition double' := fun x => x + x.
Print double'.

Definition quad x := let y := double x in 2 * y.
Eval compute in quad 2.

Definition quad' x := double (double x).
Eval compute in quad' 2.

Definition triple x :=
    let double x := x + x in
    double x + x.
Eval compute in triple 3.

Inductive janken : Set :=
| gu
| choki
| pa.

Definition weakness t :=
    match t with
    | gu => pa
    | choki => gu
    | pa => choki
    end.
Eval compute in weakness pa.

Print bool.
Print janken.

Definition wins t1 t2 :=
    match t1, t2 with
    | gu, choki => true
    | choki, pa => true
    | pa, gu => true
    | _, _ => false
    end.

Check wins.
Eval compute in wins gu pa.

Lemma weakness_wins t1 t2 :
    wins t1 t2 = true <-> weakness t2 = t1.
Proof.
    split.
    - by case: t1; case: t2.
    - move => <-; by case: t2.
Qed.

Module MyNat. (* nat を新しく定義 *)
Inductive nat : Set :=
| O : nat
| S : nat -> nat.

(*
Fixpoint plus (m n : nat) {struct m} : nat := (* 帰納法の対象を明示する 減らないとエラー *)
    match m with
    | O => n
    | S m' => S (plus m n)
    end.
*)

Fixpoint plus (m n : nat) {struct m} : nat := (* 同じ型の引数をまとめる *)
    match m with
    | O => n
    | S m' => S (plus m' n)
    end.

Print plus.
Check plus (S (S O)) (S O).
Eval compute in plus (S (S O)) (S O).

Fixpoint mult (m n : nat) {struct m} : nat :=
    match m with
    | O => O
    | S m' => plus n (mult m' n)
    end.
Eval compute in mult (S (S O)) (S O).
Eval compute in mult (S (S (S O))) (S (S O)).
End MyNat.

Check nat_ind.

Lemma plusnS m n : m + S n = S (m + n).
Proof.
    elim: m => /=.
    - done.
    - move => m IH.
      by rewrite IH.
Restart.
    elim: m => /=.
    - done.
    - move => m -> //.
Restart.
    elim: m => /= [|m ->] //.
Qed.

Lemma plusSn m n : S m + n = S (m + n).
Proof.
    rewrite /=. done.
    Show Proof.
Qed.

Lemma plusn0 n : n + 0 = n.
Proof.
    by rewrite /=.
Qed.
Lemma plusC m n : m + n = n + m.
Proof.
    elim n => /= [|o <-] //.
Qed.
Lemma plusA m n p : m + (n + p) = (m + n) + p.
Proof.
    elim m => /= [|q <-] //.
Qed.

Lemma multnS m n : m * S n = m + m * n.
Proof.
    elim: m => /= [|m ->] //.
    by rewrite !plusA [n + m]plusC.
Qed.

Lemma multn0 n : n * 0 = 0.
Proof.
    elim n.
    - done.
    - move => m //.
Restart.
    elim: n => [|m] //.
Qed.
Lemma multC m n : m * n = n * m.
Proof.
    elim m.
    - done.
    - move => o /= ->.
      by rewrite multnS.
Restart.
    elim: m => /= [|o ->] //.
    by rewrite multnS.
Qed.
Lemma multnDr m n p : (m + n) * p = m * p + n * p.
Proof.
    elim m.
    - done.
    - move => o /= ->.
      by rewrite plusA.
Restart.
    elim: m => /= [|o ->] //.
    by rewrite plusA.
Qed.
Lemma multA m n p : m * (n * p) = (m * n) * p.
Proof.
    elim m.
    - done.
    - move => /= q ->.
      by rewrite multnDr.
Restart.
    elim: m => /= [|q ->] //.
    by rewrite multnDr.
Qed.

Fixpoint sum n :=
    if n is S m then n + sum m else 0.
Print sum.

Lemma double_sum n : 2 * sum n = n * (n + 1).
Proof.
    elim n.
    - done.
    - move => m.
      rewrite plusSn multnS [S m * (m + 1)]multC multnS [(m + 1) * m]multC.
      move => <- //=.
      rewrite -plusnS -plusnS plusn0 plusnS.
      rewrite [m + 1 + (sum m + sum m)]plusC.
      rewrite -!plusA.
      rewrite [sum m + (m + 1)]plusA.
      by rewrite [sum m + m]plusC -plusA.
Qed.
Lemma square_eq a b : (a + b) * (a + b) = a * a + 2 * a * b + b * b.
Proof.
    by rewrite /= !multnDr ![_ * (a + b)]multC !multnDr [b * a]multC [0 * b]multC multn0 plusn0 !plusA.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (y : natural) (lf1 : natural) : natural :=
  plus y (plus lf1 lf2).


(*
  Exercises for <Software Foundations> V2 CH8.
  Author : Brethland, Early 2020.
*)

Set Warnings "-notation-overridden,-parsing".
Require Import Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Add LoadPath "C:\Users\ycy12\Documents\Workspace\LEARNING-STUFF\Coq".
Load Coq31.

Module STLCProp.
Import STLC.

Lemma canonical_forms_bool : ∀t,
  empty ⊢ t ∈ Bool →
  value t →
  (t = tru) ∨ (t = fls).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma canonical_forms_fun : ∀t T1 T2,
  empty ⊢ t ∈ (Arrow T1 T2) →
  value t →
  exists x u, t = abs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x0, t0. auto.
Qed.

Theorem progress : ∀t T,
  empty ⊢ t ∈ T →
  value t ∨ ∃t', t -->> t'.
Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  - (* T_Var *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.
  - (* T_App *)
    (* t = t1 t2.  Proceed by cases on whether t1 is a
       value or steps... *)
    right. destruct IHHt1...
    + (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (∃x0 t0, t1 = abs x0 T11 t0).
        eapply canonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...
      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (app t1 t2')...
    + (* t1 steps *)
      inversion H as [t1' Hstp]. exists (app t1' t2)...
  - (* T_Test *)
    right. destruct IHHt1...
    + (* t1 is a value *)
      destruct (canonical_forms_bool t1); subst; eauto.
    + (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (test t1' t2 t3)...
Qed.

Theorem progress' : ∀t T,
     empty ⊢ t ∈ T →
     value t ∨ ∃t', t -->> t'.
Proof with eauto.
  intros t.
  induction t; intros T Ht; auto.
  - inversion Ht;subst. inversion H1.
  - inversion Ht;subst. right. destruct (IHt1 (Arrow T11 T))...
    destruct (IHt2 T11)... assert(exists x0 t0, t1 = abs x0 T11 t0).
    eapply canonical_forms_fun; eauto. destruct H1 as [x0 [t0 H1]];subst.
    exists ([x0:=t2]t0)...
    destruct H0. exists (app t1 x0)... destruct H. exists (app x0 t2)...
  - right. inversion Ht;subst. destruct (IHt1 Bool)...
    destruct (canonical_forms_bool t1); subst; eauto. destruct H. exists (test x0 t2 t3)...
Qed.

Inductive appears_free_in : string → tm → Prop :=
  | afi_var : ∀x,
      appears_free_in x (var x)
  | afi_app1 : ∀x t1 t2,
      appears_free_in x t1 →
      appears_free_in x (app t1 t2)
  | afi_app2 : ∀x t1 t2,
      appears_free_in x t2 →
      appears_free_in x (app t1 t2)
  | afi_abs : ∀x y T11 t12,
      y ≠ x →
      appears_free_in x t12 →
      appears_free_in x (abs y T11 t12)
  | afi_test1 : ∀x t1 t2 t3,
      appears_free_in x t1 →
      appears_free_in x (test t1 t2 t3)
  | afi_test2 : ∀x t1 t2 t3,
      appears_free_in x t2 →
      appears_free_in x (test t1 t2 t3)
  | afi_test3 : ∀x t1 t2 t3,
      appears_free_in x t3 →
      appears_free_in x (test t1 t2 t3).
Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  ∀x, ¬appears_free_in x t.

Lemma free_in_context : ∀x t T Gamma,
   appears_free_in x t →
   Gamma ⊢ t ∈ T →
   ∃T', Gamma x = Some T'.
Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7. unfold update in H7.
    rewrite t_update_neq in H7; assumption.
Qed.

Corollary typable_empty__closed : ∀t T,
    empty ⊢ t ∈ T →
    closed t.
Proof.
  intros. inversion H;subst;unfold closed in *.
  1 : inversion H0.
  all : intros x contra.
  1 : apply (free_in_context _ _ (Arrow T11 T12) empty) in contra;auto.
  3 - 4 : apply (free_in_context _ _ Bool empty) in contra;inversion contra;inversion H0;auto.
  2 - 3 : apply (free_in_context _ _ T empty) in contra;auto.
  all : destruct contra as [m H']; inversion H'.
Qed.

Lemma context_invariance : ∀Gamma Gamma' t T,
     Gamma ⊢ t ∈ T →
     (∀x, appears_free_in x t → Gamma x = Gamma' x) →
     Gamma' ⊢ t ∈ T.
Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; auto.
  - apply T_Var. rewrite <- H0...
  - apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    unfold update. unfold t_update. destruct (beq_string x0 x1) eqn: Hx0x1...
    rewrite beq_string_false_iff in Hx0x1. auto.
  - apply T_App with T11...
Qed.

Lemma t_update_shadow : ∀(A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros.
  apply functional_extensionality.
  intros. unfold t_update.
  destruct (beq_string x0 x1) eqn:HE.
  - auto.
  - auto.
Qed.

Theorem beq_string_refl : ∀ s, true = beq_string s s.
Proof.
  intros s. unfold beq_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

Theorem beq_string_true_iff : ∀ x y : string,   beq_string x y = true ↔ x = y.
Proof.
  intros x y.
  unfold beq_string.
  destruct (string_dec x y) as [|Hs].
  - subst. split. auto. auto.
  - split.
    + intros contra. inversion contra.
    + intros H. destruct Hs. auto.
Qed.

Theorem beq_string_false_iff : ∀ x y : string,   beq_string x y = false   ↔ x ≠ y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Lemma substitution_preserves_typing : ∀Gamma x U t v T,
  (x ⊢> U ; Gamma) ⊢ t ∈ T →
  empty ⊢ v ∈ U →
  Gamma ⊢ [x:=v]t ∈ T.
Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* var *)
    rename s into y. destruct (eqb_spec x y) as [Hxy|Hxy].
    + (* x=y *)
      subst. unfold update in H2.
      rewrite t_update_eq in H2.
      inversion H2; subst.
      eapply context_invariance. eassumption.
      apply typable_empty__closed in Ht'. unfold closed in Ht'.
      intros. apply (Ht' x0) in H0. inversion H0.
    + (* x<>y *)
      apply T_Var. unfold update in H2. rewrite t_update_neq in H2...
  - (* abs *)
    rename s into y. rename t into T. apply T_Abs.
    destruct (eqb_spec x y) as [Hxy | Hxy].
    + (* x=y *)
      subst. unfold update in H5. rewrite t_update_shadow in H5. apply H5.
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_spec y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_string_false_iff in Hxy.
      rewrite Hxy... rewrite <- beq_string_false_iff in *. rewrite Hyz...
Qed.

Theorem preservation : ∀t t' T,
  empty ⊢ t ∈ T →
  t -->> t' →
  empty ⊢ t' ∈ T.
Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and eauto takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

Definition stuck (t:tm) : Prop :=
  (normal_form step) t ∧ ¬value t.
Corollary soundness : ∀t t' T,
  empty ⊢ t ∈ T →
  t -->* t' →
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  - eapply progress in Hhas_type. destruct Hhas_type;auto.
  - eapply IHHmulti;auto. eapply preservation. apply Hhas_type. auto.
Qed.

Theorem unique_types : ∀Gamma e T T',
  Gamma ⊢ e ∈ T →
  Gamma ⊢ e ∈ T' →
  T = T'.
Proof.
  intros Gamma e. generalize dependent Gamma.
  induction e;intros;inversion H;subst;inversion H0;subst;auto.
  - rewrite H3 in H4. inversion H4;auto.
  - specialize (IHe2 _ _ _ H6 H8);subst. specialize (IHe1 _ _ _ H4 H5). inversion IHe1. auto.
  - specialize (IHe _ _ _ H6 H7);subst;auto.
  - specialize (IHe2 _ _ _ H7 H10);auto.
Qed.

Module STLCArith.
Import STLC.

Inductive ty : Type :=
  | Arrow : ty → ty → ty
  | Nat : ty.

Inductive tm : Type :=
  | var : string → tm
  | app : tm → tm → tm
  | abs : string → ty → tm → tm
  | const : nat → tm
  | scc : tm → tm
  | prd : tm → tm
  | mlt : tm → tm → tm
  | test0 : tm → tm → tm → tm.

(* Leaving STLCArith *)


From mathcomp Require Import all_ssreflect.
Require Import Omega.
(*
(* https://github.com/affeldt-aist/seplog/blob/master/lib/ssrnat_ext.v *)
Require Import ssrnat_ext.                  (* ssromega *)
*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

Ltac ssromega :=
  (repeat ssrnat2coqnat_hypo ;
   ssrnat2coqnat_goal ;
   omega)
with ssrnat2coqnat_hypo :=
  match goal with
    | H : context [?L < ?R] |- _ => move/ltP: H => H
    | H : context [?L <= ?R] |- _ => move/leP: H => H
    | H : context [?L < ?M < ?R] |- _ => let H1 := fresh in case/andP: H => H H1
    | H : context [?L <= ?M < ?R] |- _ => let H1 := fresh in case/andP: H => H H1
    | H : context [?L <= ?M <= ?R] |- _ => let H1 := fresh in case/andP: H => H H1
    | H : context [addn ?L ?R] |- _ => rewrite <- plusE in H
    | H : context [muln ?L ?R] |- _ => rewrite <- multE in H
    | H : context [subn ?L ?R] |- _ => rewrite <- minusE in H
    | H : ?x == _ |- _ => match type of x with nat => move/eqP in H end; idtac x
    | H : _ == ?x |- _ => match type of x with nat => move/eqP in H end; idtac x
    | H : _ != ?x |- _ => match type of x with nat => move/eqP in H end
  end
with ssrnat2coqnat_goal :=
  rewrite -?plusE -?minusE -?multE;
  match goal with
    | |- is_true (_ < _)%nat => apply/ltP
    | |- is_true (_ <= _)%nat => apply/leP
    | |- is_true (_ && _) => apply/andP; split; ssromega
    | |- is_true (?x != _) => match type of x with nat => apply/eqP end
    | |- is_true (_ != ?x) => match type of x with nat => apply/eqP end
    | |- is_true (?x == _) => match type of x with nat => apply/eqP end
    | |- is_true (_ == ?x) => match type of x with nat => apply/eqP end
    | |- _ /\ _ => split; ssromega
    | |- _ \/ _ => (left; ssromega) || (right; ssromega)
    | |- _ => idtac
  end.

Goal forall x y : nat, x + 4 - 2 > y + 4 -> (x + 2) + 2 >= y + 6.
Proof.
  intros.
  ssromega.
Qed.

(* どちらも、m < n での場合分けで良い。 *)
Print maxn.            (* = fun m n : nat => if m < n then n else m *)
Print minn.            (* = fun m n : nat => if m < n then m else n *)

Ltac linear_arithmetic' :=
  intros;
  repeat match goal with
         | [ |- context[maxn ?a ?b] ] =>
           rewrite {1}/maxn; case: (leqP b a); intros

         | [ H : context[maxn ?a ?b] |- _ ] =>
           let H' := fresh in
           rewrite {1}/maxn in H; case: (leqP b a) => H'; try rewrite H' in H

         | [ |- context[minn ?a ?b] ] =>
           rewrite {1}/minn; case: (leqP b a); intros

         | [ H : context[minn ?a ?b] |- _ ] =>
           let H' := fresh in
           rewrite {1}/minn in H; case: (leqP b a) => H';
           try (rewrite leqNgt in H'; move/Bool.negb_true_iff in H'; rewrite H' in H)

         | _ => idtac
         end.
(* case H' : (a < b) の H' が展開できないため、それを使うのを避ける。 *)
(* destruct (a < b) eqn:H' としてもよい。 *)
(*
           let H' := fresh in
           rewrite {1}/maxn; destruct (a < b) eqn: H'; intros
*)

Ltac linear_arithmetic :=
  linear_arithmetic';
  try ssromega;
  rewrite //=.

(* sample *)

Goal forall n m, maxn n m = n <-> m <= n.
Proof.
  split.
  - move=> H.
    rewrite {1}/maxn in H.
    case: (leqP m n) => H'.
    + done.
    + rewrite H' in H.
      by ssromega.
  - move=> H.
    rewrite {1}/maxn.
    case: (leqP m n) => H'.
    + done.
    + ssromega.

  Restart.

  split.
  - by linear_arithmetic.
  - by linear_arithmetic.
Qed.

Lemma leq_ltF m n : m <= n <-> (n < m) = false.
Proof.
  rewrite leqNgt.
  split.
  - by move/Bool.negb_true_iff.
  - by move=> H; apply/Bool.negb_true_iff.
Qed.

Goal forall n m, minn n m = n <-> n <= m.
Proof.
  split.
  - move=> H.
    rewrite {1}/minn in H.
    case: (leqP m n) => H'.
    + move/leq_ltF in H'.
      rewrite H' in H.
      by ssromega.
    + by ssromega.

  - move=> H.
    rewrite {1}/minn.
    case: (leqP m n) => H'.
    + by ssromega.
    + done.

  Restart.

  split.
  - by linear_arithmetic.
  - by linear_arithmetic.
Qed.

Goal forall m1 n1 m2 n2, m1 <= m2 -> n1 <= n2 -> maxn m1 n1 <= m2 + n2.
Proof.
  linear_arithmetic'.
  - ssromega.
  - ssromega.

  Restart.

  move=> m1 n1 m2 n2.
  rewrite /maxn.
  Check leqP n1 m1.
  case: (leqP n1 m1) => H1 H2 H'.
  - ssromega.
  - ssromega.
Qed.

(* ***** *)

Ltac simplify := intros;
                 try autorewrite with core in *;
                 simpl in *.

Ltac equality := intuition congruence.

Ltac cases E := let Heq := fresh "Heq" in
                destruct E eqn: Heq. (* eqn: のスペースが要る。 *)

(* ***** *)

Require Import Ascii.
Require Import String.
Open Scope string_scope.

Section SSRAscii.

  Definition eqAscii (a b : ascii) : bool :=
    match ascii_dec a b with
    | left _ => true
    | right _ => false
    end.

  Compute eqAscii "a" "a".                  (* true *)
  Compute eqAscii "a" "b".                  (* false *)

  Lemma ascii_eqP (a b : ascii) : reflect (a = b) (eqAscii a b).
  Proof.
    rewrite /eqAscii.
    (* reflect (a = b) (if ascii_dec a b then true else false) *)
    apply: (iffP idP); by case: (ascii_dec a b).
  Qed.

  Fail Canonical ascii_eqType := [eqType of ascii].

  Definition ascii_eqMixin := @EqMixin ascii eqAscii ascii_eqP.
  Canonical ascii_eqType := @EqType ascii ascii_eqMixin.

  Canonical ascii_eqType' := [eqType of ascii].
End SSRAscii.

Check ascii_eqType : eqType.
Check "a"%char : ascii.
Check "a"%char : ascii_eqType.

Check true : bool.
Check true : bool_eqType.

Check 1 : nat.
Check 1 : nat_eqType.

Section SSRString.

  Definition eqString (s t : string) : bool :=
    match string_dec s t with
    | left _ => true
    | right _ => false
    end.

  Compute eqString "aaaa" "aaaa".             (* true *)
  Compute eqString "aaaa" "aa".               (* false *)

  Lemma string_eqP (x y : string) : reflect (x = y) (eqString x y).
  Proof.
    rewrite /eqString.
    apply: (iffP idP); by case: (string_dec x y).
  Qed.

  Definition string_eqMixin := @EqMixin string eqString string_eqP.
  Canonical string_eqType := @EqType string string_eqMixin.

End SSRString.

Check "aaa" = "aaa" : Prop.
Check "aaa" == "aaa" : bool.
Check "aaa" == "aaa" : Prop.

(* Notation var := string. *)

(* END *)


From mathcomp Require Import all_ssreflect.
Require Import Program.

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

(* **** *)
(* perm *) (* seq.v *)
(* **** *)

Variable T : eqType.

Check perm_eq : seq T -> seq T -> bool.
Search _ perm_eq.
Compute perm_eq [:: 1; 2] [:: 1; 2].        (* true *)

Check perm_eq_refl : forall (T : eqType) (s : seq T), perm_eq s s.
Check perm_eq_sym : forall T : eqType, symmetric perm_eq.
Check perm_eq_trans : forall T : eqType, transitive perm_eq.
Check perm_cons : forall (T : eqType) (x : T) (s1 s2 : seq T),
    perm_eq (x :: s1) (x :: s2) = perm_eq s1 s2.

Lemma perm_cons' : forall (n : T) (l l' : seq T),
    perm_eq l l' -> perm_eq (n :: l) (n :: l').
Proof.
  move=> n l l' H.
  by rewrite perm_cons.
Qed.

(*
Lemma perm_cons'2 :  forall (T : eqType) (n1 n2 : T) (s1 s2 : seq T),
    perm_eq [:: n1, n2 & s1] [:: n2, n1 & s2] = perm_eq (n1 :: s1) (n1 :: s2).
Proof.
Admitted.
 *)

Lemma perm_iff : forall (m n : seq T),
                   (forall l, perm_eq m l = perm_eq n l) <-> perm_eq m n.
Proof.
  move=> m n.
  split=> H.
  - by rewrite H.
  - by apply/perm_eqlP.
Qed.

Lemma perm_swap : forall (l l' : seq T) (x a : T),
                    perm_eq [:: x, a & l] l' = perm_eq [:: a, x & l] l'.
Proof.
  move=> l l' x a.
  apply perm_iff.
  Check cat1s.
  rewrite -[[:: x, a & l]]cat1s.
  rewrite -[[:: a & l]]cat1s.
  rewrite -[[:: a, x & l]]cat1s.
  rewrite -[[:: x & l]]cat1s.
  apply/perm_eqlP.
  by apply (perm_catCA [:: x] [:: a] l).
Qed.

Lemma perm_swap_cat : forall (l l' l'' : seq T),
    perm_eq (l ++ l') l'' = perm_eq (l' ++ l) l''.
Proof.
  move=> l l' l''.
  apply perm_iff.
  by rewrite perm_catC.
Qed.

(* :: と ++ は左結合で、同じ優先順位である。 *)
Lemma perm_swap_cons_cat : forall (x : T) (l l' l'' : seq T),
    perm_eq (x :: l ++ l') l'' = perm_eq (l ++ x :: l') l''.
Proof.
  move=> x l l' l''.
  apply perm_iff.
  rewrite -[x :: l ++ l']cat1s.
  rewrite -[x :: l']cat1s.
  by rewrite -perm_catCA.
Qed.

Hint Resolve perm_cons perm_eq_refl perm_eq_sym perm_eq_trans : perm.
Hint Rewrite perm_iff perm_swap perm_swap_cat : perm.

(* **** *)
(* sort *) (* path.v *)
(* **** *)

Variable leT : rel T.
Hypothesis leT_tr : transitive leT.
Hypothesis leT_false : forall x y, leT x y = false -> leT y x. (* ???? *)

Check sorted leT : seq T -> bool.
Search _ sorted.

Lemma sorted_nil : sorted leT [::].
Proof.
    by [].
Qed.

Lemma sorted_cons1 n : sorted leT [:: n].
Proof.
    by [].
Qed.

Lemma sorted_consn m n l :
  sorted leT (n :: l) -> leT m n -> sorted leT [:: m, n & l].
Proof.
  move=> /= H R.
    by apply/andP.                            (* path の定義のまま。 *)
Qed.

Hint Resolve sorted_nil sorted_cons1 sorted_consn : sort.

Lemma sorted_cons_inv h l : sorted leT (h :: l) -> sorted leT l.
Proof.
  apply: subseq_sorted.
  - by apply: leT_tr.
  - by apply: subseq_cons.
Qed.

Lemma sorted_inv m n l :
  sorted leT [:: m, n & l] -> (leT m n /\ sorted leT (n :: l)).
Proof.
  by move/andP.                             (* path の定義のまま。 *)
Qed.

Lemma cat__sorted l l' :
  sorted leT (l ++ l') -> (sorted leT l /\ sorted leT l').
Proof.
  elim: l.
  - by [].
  - move=> a l IHl H.
Admitted.                                   (* XXXX *)

(*
Lemma sorted_cons_inv2 m n l :
  sorted leT [:: m, n & l] -> sorted leT (m :: l).
Proof.
  apply: subseq_sorted.
  - by apply: leT_tr.
  - rewrite -[(m :: l)]cat1s.
    rewrite -[[:: m, _ & _]]cat1s.
    apply: cat_subseq.
    + by apply: subseq_refl.
    + by apply: subseq_cons.
Qed.

Lemma subseq_cons2 (n : T) (l l' : seq T) :
  subseq l l' -> subseq (n :: l) (n :: l').
Proof.
  rewrite -[(n :: l)]cat1s.
  rewrite -[(n :: l')]cat1s.
  by apply: cat_subseq.
Qed.

Lemma perm__subseq l l' :
  (exists l'', perm_eq (l' ++ l'') l) ->
  (sorted leT l -> sorted leT l') -> subseq l' l.
Proof.
Admitted.

Lemma perm__sorted n l l' :
  (exists l'', perm_eq (l' ++ l'') l) ->    (* perm__subseq *)
  (sorted leT l -> sorted leT l') ->        (* perm__subseq *)
  sorted leT (n :: l) -> sorted leT (n :: l').
Proof.
  move=> He Hs H.
  Check (@subseq_sorted T leT leT_tr (n :: l') (n :: l)).
  apply (@subseq_sorted T leT leT_tr (n :: l') (n :: l)).
  - apply subseq_cons2.
    apply perm__subseq; by [].
  - by [].
Admitted.

Lemma perm_app : forall (n : nat) (l'' l l' : seq nat),
    perm_eq l'' (l ++ l') -> perm_eq (n :: l'') (l ++ n :: l').
Admitted.
 *)

Lemma sorted__sorted' (x : T) (l : seq T) :
  (forall y, y \in l -> leT x y) -> sorted leT l -> sorted leT (x :: l).
Proof.
  move=> Hxy.
  Check @path_min_sorted T leT x l.
  rewrite -(@path_min_sorted T leT x l).
  - by [].
  - (* Goal : {in l, forall y0 : T, leT x y0}, ssrbool.v l.222, l.1571 *)
    (*             {in A, P1} <-> forall x, x \in A -> Qx.             *)
    move=> y Hyl.
      by apply: (Hxy y).
Qed.
(* 別証明 *)
(* (forall y0 : T, y0 \in x' -> leT x y0) <-> {in x', forall y : T, leT x y} *)
(* であることにも。 *)
Lemma sorted__sorted (x : T) (l : seq T) :
  {in l, forall y : T, leT x y} -> sorted leT l -> sorted leT (x :: l).
Proof.
  move=> H Hs.
  rewrite /sorted.
  by rewrite path_min_sorted.
Qed.

Lemma sorted__in (n n' : T) (l l' : seq T) :
  perm_eq (n :: l') l ->
  (sorted leT l' -> sorted leT l) ->
(*  head n l = n \/ head n l = head n l' *)
  leT n' n -> path leT n' l' ->
  {in l, forall y : T, leT n' y}.
Proof.
Admitted.                                   (* XXX *)

Check path_min_sorted : forall (T : eqType) (leT : rel T) (x : T) (s : seq_predType T),
    {in s, forall y : T, leT x y} -> path leT x s = sorted leT s.

Program Fixpoint merge (ls1 ls2 : seq T)
  {measure (size ls1 + size ls2)} :
  {l' : seq T | perm_eq (ls1 ++ ls2) l' /\
                (sorted leT ls1 -> sorted leT ls2 -> sorted leT l')} :=
  (* match (ls1, ls2) とすると、ペアどうしの代入の前提が解けない。 *)
  (* 「'」をつけてもだめのよう。 *)
  match ls1 with
  | [::] => ls2
  | x :: ls1' => match ls2 with
                 | [::] => ls1
                 | y :: ls2' => if (leT x y) then
                                  x :: (merge ls1' ls2)
                                else
                                  y :: (merge ls1 ls2')
                 end
  end.
Obligations.
Next Obligation.
  split.
  - by rewrite [ls1' ++ []%list]List.app_nil_r.
  - by [].
Defined.
Next Obligation.
  apply PeanoNat.Nat.add_le_lt_mono.
  - by [].
  - by [].
Defined.
Next Obligation.
  split.
  - remember (merge ls1' (y :: ls2') _).
    case Hx : s => /= [x' [Hxp Hxs]].
    remember (merge (x :: ls1') ls2' _).
    case Hy : s0 => /= [y' [Hyp Hys]].
    case H : (leT x y); subst.
    + by rewrite perm_cons.
    + rewrite -cat_cons.
      rewrite perm_swap_cat.
      rewrite cat_cons.
      rewrite perm_cons.
        by rewrite perm_swap_cat.
  - remember (merge ls1' (y :: ls2') _).
    case Hx : s => /= [x' [Hxp Hxs]].
    (* x' は ls1 ++ ls2 = x::ls1' ++ y::ls2' から x を抜いたもの。 *)

    remember (merge (x :: ls1') ls2' _).
    case Hy : s0 => /= [y' [Hyp Hys]].
    (* y' は ls1 ++ ls2 = x::ls1' ++ y::ls2' から y を抜いたもの。 *)

    case H : (leT x y); subst.
    + move=> H1 H2.
      apply sorted__sorted.
      * Check (@sorted__in y x x' (ls1' ++ ls2')).
        apply (@sorted__in y x x' (ls1' ++ ls2')).
        ** by rewrite perm_swap_cons_cat.
        ** move=> H'.
           apply cat__sorted in H'.
           case: H' => H'1 H'2.
           by apply Hxs.
        ** by [].
        ** admit.                           (* XXXX *)
      * apply Hxs.
        eapply path_sorted.
        apply H1.
        by apply H2.
    + move=> H1 H2.
      apply sorted__sorted.
      * Check (@sorted__in x y y' (ls1' ++ ls2')).
        apply (@sorted__in x y y' (ls1' ++ ls2')).
        ** by [].
        ** move=> H'.
           apply cat__sorted in H'.
           case: H' => H'1 H'2.
           by apply Hys.
        ** by apply leT_false.              (* ???? *)
        ** admit.                           (* XXXX *)
      * apply Hys.
        apply H1.
        eapply path_sorted.
        by apply H2.
Defined.

(* ******************* *)
(* insert を使う merge *)
(* ******************* *)
Program Fixpoint insert n l {struct l} :
  {l' : seq T | perm_eq (n :: l) l' /\
                (sorted leT l -> sorted leT l') /\
                (head n l' = n \/ head n l' = head n l)} :=
  match l with
  | [::] => [:: n]
  | n' :: l' =>
    if leT n n' then
      n :: n' :: l'
    else
      n' :: insert n l'
  end.
Obligations.
Next Obligation.
  case Hnn' : (leT n n').
  - by auto with sort.
  - split.
    + erewrite perm_swap.
      by rewrite perm_cons.
    + split.
      * move=> H.
        apply sorted__sorted.
(*
        have H1 : sorted leT l' by apply: (@sorted_cons_inv n' l'). l', x : seq T
        have H2 : sorted leT x by auto.
*)
        ** apply (@sorted__in n n' x l').
           *** by apply i.
           *** by apply i0.
           *** by apply leT_false.          (* ????? *)
           *** by apply H.
        ** apply i0.
           eapply path_sorted.
             by apply H.
      * by auto.
Defined.

Hint Resolve sorted_cons_inv : sort.
Hint Resolve perm_cons' : perm.

Program Fixpoint merge' (ls1 ls2 : seq T) :
  {l' : seq T | perm_eq (ls1 ++ ls2) l' /\
                (sorted leT ls1 /\ sorted leT ls2 -> sorted leT l')} :=
  match ls1 with
  | nil => ls2
  | h :: ls' => insert h (merge' ls' ls2)
  end.
Obligations.
Next Obligation.
  split.
  - by [].
  - by case.
Defined.
Next Obligation.
  remember (insert h x) as s.
  case H : s => /= {Heqs}; subst.
  intuition.                          (* ゴールの /\ をsplit する。 *)
  - Check @perm_eq_trans T (h :: x) (h :: ls' ++ ls2) _.
    eapply (@perm_eq_trans T (h :: x) (h :: ls' ++ ls2) _). (* _ は _x_ *)
    + by rewrite perm_cons.
    + by [].
  - apply H1, H2.
    + by apply path_sorted with (x := h).
    + by [].
  - eapply (@perm_eq_trans T (h :: x) (h :: ls' ++ ls2) _). (* _ は _x_ *)
    + by rewrite perm_cons.
    + by [].
  - apply H1, H2.
    + by apply path_sorted with (x := h).
    + by [].
Defined.

(* 証明のないinsertを呼ぶと、ゴールにinsertが残り、証明できない。 *)

(* END *)