(**
This file verifies some of the logic of Interval.hs from
bisect-binary. <https://github.com/nomeata/bisect-binary/>

It is a variant of Proofs.v that uses the Function command to use [deferredFix] in a safer ay and get a nice induction lemma. I stopped after the proof for [union].
*)

Require Import Intervals.

Require Import GHC.Base.
Require Import GHC.DeferredFix.

Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Powerset_facts.
Require Import Ensemble_facts.
Import ListNotations.
Require Import Omega.

Require Import Coq.Logic.FunctionalExtensionality.

Definition goodI (i : Interval) : Prop :=
  match i with I f t => (f < t)%Z end.

Fixpoint goodLIs (is : list Interval) (lb : Z) : Prop :=
  match is with
    | [] => True
    | (I f t :: is) => (lb <= f)%Z /\ (f < t)%Z /\ goodLIs is t
  end.

Definition good is := match is with
  ival is => exists n, goodLIs is n end.

Definition range (f t : Z) : Ensemble Z :=
  (fun z => (f <= z)%Z /\ (z < t)%Z).

Definition semI (i : Interval) : Ensemble Z :=
  match i with I f t => range f t end.

Fixpoint semLIs (is : list Interval) : Ensemble Z :=
  match is with
    | [] => Empty_set Z
    | (i :: is) => Union Z (semI i) (semLIs is)
  end.

Definition sem is := match is with
  ival is => semLIs is end.

(* utils *)

Lemma range_empty (z : Z) :
  (z <= 0)%Z -> range 0 z = Empty_set Z.
Proof.
  intro H. apply Extensionality_Ensembles. split.
  * intros z' H2.
    unfold range, In in *.
    contradict H2.
    intuition.
  * apply Included_Empty.
Qed.

Lemma goodLIs_mono : forall is lb lb', (lb' <= lb)%Z -> goodLIs is lb -> goodLIs is lb'.
Proof.
  intros.
  induction is.
  * auto.
  * destruct a. simpl in *. intuition.
Qed.

Lemma good_sem_lb:
  forall is lb x,
  goodLIs is lb -> In Z (semLIs is) x -> (lb <= x)%Z.
Proof.
  intros.
  unfold In in *.
  induction is.
  * simpl in *. exfalso. intuition.
  * destruct a as [f t]; simpl in *; intuition.
    destruct H0; unfold In, range in *; intuition.
    apply IHis.
    refine (goodLIs_mono _ _ _ _ H3). intuition.
    auto.
Qed.

Lemma Intersection_range_range:
  forall f1 t1 f2 t2,
  Intersection Z (range f1 t1) (range f2 t2)
  = range (Z.max f1 f2) (Z.min t1 t2).
Proof.
  intros. apply Extensionality_Ensembles. split.
  * intros x H1. destruct H1. unfold In, range in *.
    rewrite Z.max_lub_iff.
    rewrite Z.min_glb_lt_iff.
    intuition.
  * intros x H. constructor;
    unfold In, range in *;
    rewrite Z.max_lub_iff in *;
    rewrite Z.min_glb_lt_iff in *;
    intuition.
Qed.

Lemma Intersection_range_range_empty:
  forall f1 t1 f2 t2,
  (t1 <= f2)%Z \/ (t2 <= f1)%Z ->
  Intersection Z (range f1 t1) (range f2 t2) = Empty_set Z.
Proof.
  intros. apply Extensionality_Ensembles. split.
  * intros x H1. destruct H1. unfold In, range in *.
    exfalso. intuition.
  * intuition.
Qed.

Lemma Included_range_range:
  forall f1 t1 f2 t2,
  (f2 <= f1)%Z /\ (t1 <= t2)%Z ->
  Included Z (range f1 t1) (range f2 t2).
Proof.
  intros.
  intros x H1.
  unfold In, range in *. intuition.
Qed.

Lemma Intersection_range_semLIs_empty:
  forall f t is lb,
  goodLIs is lb -> (t <= lb)%Z ->
  Intersection Z (range f t) (semLIs is) = Empty_set Z.
Proof.
  induction is; intros.
  * apply Disjoint_Empty_set_r.
  * destruct a as [f' t']. simpl in *.
    rewrite Distributivity.
    rewrite Intersection_range_range_empty.
    rewrite Empty_set_zero.
    apply IHis with (lb := t').
    intuition.
    intuition.
    intuition.
Qed.

(** proofs *)

(** [nullIntervals] *)

Theorem nullIntervals_good : good nullInterval.
Proof.
  exists 0%Z. constructor.
Qed.

Theorem nullIntervals_spec : sem nullInterval = Empty_set Z.
Proof. reflexivity. Qed.

(** [fullIntervals] *)

Theorem fullIntervals_good : forall z, good (fullIntervals z).
Proof.
  intros.
  unfold fullIntervals, mkInterval.
  unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
  simpl in *.
  destruct (Z.ltb_spec 0 z).
  * exists 0%Z. unfold goodLIs. intuition.
  * exists 0%Z. unfold goodLIs. intuition.
Qed.

Theorem fullIntervals_spec (z : Z) : sem (fullIntervals z) = range 0 z.
Proof.
  intros.
  unfold fullIntervals, mkInterval.
  unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
  simpl in *.
  destruct (Z.ltb_spec 0 z).
  * simpl. rewrite Union_commutative. rewrite Empty_set_zero. reflexivity.
  * simpl. rewrite range_empty by assumption. reflexivity.
Qed.

(** [isEmpty] *)

Lemma isEmpty_specL (is : list Interval) (lb : Z) (Hgood : goodLIs is lb) :
  is = [] <-> (semLIs is = Empty_set Z).
Proof.
  split; intros.
  * subst. reflexivity.
  * destruct is; try congruence.
    destruct i.
    simpl in *.
    assert (In Z (range from to) from).
    - unfold range. intuition.
    - eapply Union_introl in H0.
      rewrite H in H0.
      apply Noone_in_empty in H0.
      contradict H0.
Qed.

Theorem isEmpty_spec (i : Intervals) (Hgood : good i) :
  isEmpty i = true <-> (sem i = Empty_set Z).
Proof.
  destruct i.
  simpl.
  simpl in Hgood; destruct Hgood.
  unfold Foldable.null, Foldable.Foldable__list, Foldable.null__, Foldable.Foldable__list_null.
  rewrite <- isEmpty_specL by eassumption.
  destruct l; simpl; intuition; try congruence.
Qed.

(** deferred fix *)

(* Variant of the axiom that is safe to use. *)
Axiom deferredFix2_safe_eq: forall {a b r} `{Default r} (f : (a -> b -> r) -> (a -> b -> r)) x,
  f x = x -> deferredFix2 f = f (deferredFix2 f).

(** induction principle *)

Definition needs_reorder (is1 is2 : list Interval) : bool :=
  match is1, is2 with
    | (I f1 t1 :: _), (I f2 t2 :: _) => (t1 <? t2)%Z
    | _, _ => false
  end.

Definition size2 (is1_is2 : list Interval * list Interval) : nat := match is1_is2 with
  (is1, is2) => (if needs_reorder is1 is2 then 1 else 0) + 2 * length is1 + 2 * length is2 end.

(** Function definitions using Program Fixpoint. We use them only
  to show that the axiomatized fixpoints in the code exist, and to
  get a nice termination principle.

  The code was copied out of the argument to [deferredFix], and case splits pulled out of function arguments.
  *)

Ltac solve_size2 :=
  intros;
  try match goal with [ H :  _<_ ?x ?y = true |- _ ] =>
      unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in H;
      destruct (Z.ltb_spec x y); try congruence
  end;
  repeat match goal with [ i : Interval |- _ ] => destruct i end;
  match goal with [ |- context [size2 (?is1, ?is2)]] =>
    try (lazymatch is1 with | _ :: _ => fail | _ => destruct is1 as [|[??]?] end);
    try (lazymatch is2 with | _ :: _ => fail | _ => destruct is2 as [|[??]?] end)
  end;
  unfold size2; simpl in *;
  repeat rewrite Z.ltb_irrefl;
  repeat (
    match goal with [ |- context [if (?x <? ?y)%Z then _ else _] ] => destruct (Z.ltb_spec x y) end
  );
  try omega.

Require Import Recdef.

Function union_go_witness' (is1_is2 : list Interval * list Interval)  {measure size2 is1_is2} :list Interval :=
  match is1_is2 with (arg_25__, arg_26__) =>
     match arg_25__ with
     | [] => match arg_26__ with
             | [] => arg_25__
             | _ :: _ => arg_26__
             end
     | i1 :: is1 =>
         match arg_26__ with
         | [] => arg_25__
         | i2 :: is2 =>
            if _<_ (to i1) (to i2)
            then union_go_witness' (i2 :: is2, i1 :: is1)
            else if _>_ (from i1) (to i2)
               then i2 :: union_go_witness' (i1 :: is1, is2)
               else match i1 with | I _ to_29__ =>
                 union_go_witness' ( I (min (from i1) (from i2)) to_29__ :: is1, is2) end
         end
     end
   end.
Proof. all: solve_size2. Qed.
Definition union_go_witness (is1 is2 : list Interval) : list Interval :=
  union_go_witness' (is1, is2).

Definition union_go_f :=
  fun (go : list Interval -> list Interval -> list Interval)
               (arg_25__ arg_26__ : list Interval) =>
             match arg_25__ with
             | [] =>
                 match arg_26__ with
                 | [] => arg_25__
                 | _ :: _ => arg_26__
                 end
             | i1 :: is3 =>
                 match arg_26__ with
                 | [] => arg_25__
                 | i2 :: is4 =>
                     let f' := min (from i1) (from i2) in
                     let j_32__ :=
                       go
                         (match i1 with
                          | I _ to_29__ => I f' to_29__
                          end :: is3) is4 in
                     let j_33__ :=
                       if _>_ (from i1) (to i2) : bool
                       then i2 :: go (i1 :: is3) is4
                       else j_32__ in
                     if _<_ (to i1) (to i2) : bool
                     then go (i2 :: is4) (i1 :: is3)
                     else j_33__
                 end
             end.

Lemma union_go_eq :
  deferredFix2 union_go_f = union_go_f (deferredFix2 union_go_f).
Proof.
  apply deferredFix2_safe_eq with (x := union_go_witness).
  extensionality is1. extensionality is2.
  unfold union_go_f.
  unfold union_go_witness at 4.
  rewrite union_go_witness'_equation.
  unfold union_go_witness.
  repeat (match goal with [ |- context [match ?scrut with | _ => _ end ] ] => destruct scrut end;simpl);
  reflexivity.
Qed.

Definition union_go_ind P : _ :=
  (union_go_witness'_ind (fun is1_is2 _ => match is1_is2 with (is1, is2) => P is1 is2 end)).

(** [union] *)

Lemma union_good : forall (is1 is2 : Intervals),
    good is1 -> good is2 -> good (union is1 is2).
Proof.
  intros.
  destruct is1 as [is1], is2 as [is2].
  destruct H as [lb1 H1] , H0 as [lb2 H2].
  exists (Z.min lb1 lb2).
  fold union_go_f.
  apply (goodLIs_mono _ _ _ (Z.le_min_l lb1 lb2)) in H1.
  apply (goodLIs_mono _ _ _ (Z.le_min_r lb1 lb2)) in H2.
  generalize dependent (Z.min lb1 lb2). clear lb1 lb2.
  (* ready for induction *)
  refine (union_go_ind (fun is1 is2 => forall lb : Z,
  goodLIs is1 lb -> goodLIs is2 lb -> goodLIs (deferredFix2 union_go_f is1 is2) lb) _ _ _ _ _ _ (is1, is2)); clear is1 is2;
  intros is1_is2_ is1 is2.
  * intros ???;subst.
    intros lb H1 H2.
    rewrite union_go_eq. unfold union_go_f at 1.
    simpl. trivial.
  * intros ?? i2 is2' ?; subst. intros lb H1 H2.
    rewrite union_go_eq. unfold union_go_f at 1.
    assumption.
  * intros ?? i1 is1' ?; subst. intros lb H1 H2.
    rewrite union_go_eq. unfold union_go_f at 1.
    assumption.
  * rename is1 into is1', is2 into is2'.
    intros ???????? IH lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    simpl.
    rewrite e2.
    unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
    unfold GHC.Base.op_zg__, Ord_Integer___, op_zg____ in *.
    apply IH; try assumption.
  * rename is1 into is1', is2 into is2'.
    intros ????????? IH lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    rewrite e2, e3.
    unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
    unfold GHC.Base.op_zg__, Ord_Integer___, op_zg____ in *.
    destruct i1 as [f1 t1], i2 as [f2 t2].
    simpl in *.
    repeat match goal with [ H :  (?x <? ?y)%Z = true |- _ ] =>
      unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in H;
      destruct (Z.ltb_spec x y); try congruence
    end.
    intuition.
  * rename is1 into is1', is2 into is2'.
    intros ???????????? IH lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    rewrite e2, e3.
    unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
    unfold GHC.Base.op_zg__, Ord_Integer___, op_zg____ in *.
    destruct i2 as [f2 t2].
    simpl in *.
    repeat match goal with [ H :  (?x <? ?y)%Z = _ |- _ ] =>
      unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in H;
      destruct (Z.ltb_spec x y); try congruence
    end.
    intuition.
    apply IH.
    rewrite Z.min_glb_iff in *. intuition.
    rewrite  Z.min_lt_iff in *. intuition.
    refine (goodLIs_mono _ _ _ _ H7). intuition.
Qed.

Lemma union_spec : forall (is1 is2 : Intervals),
    good is1 -> good is2 -> sem (union is1 is2) = Union Z (sem is1) (sem is2).
Proof.
  intros.
  destruct is1 as [is1], is2 as [is2].
  destruct H as [lb1 H1] , H0 as [lb2 H2].
  unfold union.
  fold union_go_f.
  apply (goodLIs_mono _ _ _ (Z.le_min_l lb1 lb2)) in H1.
  apply (goodLIs_mono _ _ _ (Z.le_min_r lb1 lb2)) in H2.
  generalize dependent (Z.min lb1 lb2). clear lb1 lb2.

  (* ready for induction *)
  refine (union_go_ind (fun is1 is2 => forall lb : Z,
  goodLIs is1 lb -> goodLIs is2 lb -> semLIs (deferredFix2 union_go_f is1 is2) = Union Z (semLIs is1) (semLIs is2)) _ _ _ _ _ _ (is1, is2)); clear is1 is2;
  intros is1_is2_ is1' is2'.
  * intros ??? lb H1 H2;subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    simpl.  rewrite Empty_set_zero. reflexivity.
  * intros ?? i2 is2 ? lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    simpl in *. intuition.
  * intros ?? i1 is1 ?; subst. intros lb H1 H2.
    rewrite union_go_eq. unfold union_go_f at 1.
    simpl in *. rewrite  Empty_set_zero_l. intuition.
  * intros ???????? IH lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    simpl.
    rewrite e2.
    unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
    unfold GHC.Base.op_zg__, Ord_Integer___, op_zg____ in *.
    rewrite IH with (lb:=lb).
      + intuition.
      + assumption.
      + assumption.
  * intros ????????? IH lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    rewrite e2, e3.
    unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
    unfold GHC.Base.op_zg__, Ord_Integer___, op_zg____ in *.
    destruct i1 as [f1 t1], i2 as [f2 t2].
    simpl in *.
    repeat match goal with [ H :  (?x <? ?y)%Z = true |- _ ] =>
      unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in H;
      destruct (Z.ltb_spec x y); try congruence
    end.
    rewrite IH with (lb:=t2).
    + simpl. intuition.
      (* reorder Union *)
      repeat rewrite Union_associative.
      rewrite Union_commutative.
      repeat rewrite Union_associative.
      do 2 f_equal.
      rewrite Union_commutative.
      reflexivity.
    + simpl in *. intuition.
    + simpl. intuition.
  * intros ???????????? IH lb H1 H2; subst.
    rewrite union_go_eq. unfold union_go_f at 1.
    rewrite e2, e3.
    unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in *.
    unfold GHC.Base.op_zg__, Ord_Integer___, op_zg____ in *.
    destruct i2 as [f2 t2].
    simpl in *.
    repeat match goal with [ H :  (?x <? ?y)%Z = _ |- _ ] =>
      unfold GHC.Base.op_zl__, Ord_Integer___, op_zl____ in H;
      destruct (Z.ltb_spec x y); try congruence
    end.
    rewrite IH with (lb:=lb).
    + simpl.
      rewrite union_reorder.
      rewrite Union_associative.
      f_equal.
      (* range and min *)
      apply Extensionality_Ensembles. split.
      ** intros z' H3.
         unfold range, In in *.
         rewrite Z.min_le_iff in *.
         intuition.
         left. unfold In. intuition.
         destruct (Z.ltb_spec z' t2).
         right. unfold In. intuition.
         left. unfold In. intuition.
      ** intros z' H3.
         apply Union_inv in H3.
         unfold range, In in *.
         rewrite Z.min_le_iff in *.
         intuition.
    + simpl. intuition.
      rewrite Z.min_glb_iff in *. intuition.
      rewrite  Z.min_lt_iff in *. intuition.
    + simpl. intuition.
      refine (goodLIs_mono _ _ _ _ H7). intuition.
Qed.


(**
「リストは自分自身のfoldr関数として定義される」につついて
=========

2014_05_11 @suharahiromichi
 *)

(**
# はじめに

TAPL（参考文献1.)には、p.47とp.275の2箇所に渡って、
「リストは自分自身のfoldr関数として定義される」
と書かれている。
しかし、前後の説明を読んでもこの一文の意味することはよくわからなかった。

また、別なところ（同 p.277）で、
「(System Fは)fixに頼ることなく純粋な言語でソート関数のようなものが書ける…」
と極めて重要なことが書いてある。
これは、チャーチ数やリストのチャーチ表現がそのような性質を
持つのであって、System Fはそれらを扱える（型付けをすることができる）
と理解するべきなのだろう。

以上のことを納得するために、数やリストについて、

1. Inductiveな定義
2. チャーチ表現
3. fold関数

の関係を調べてみる。証明はCoq SSRefelctで行う。
*)
(**
この文章のソースコードは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_church_number.v
*)

Require Import ssreflect ssrbool ssrnat.

(**
# チャーチ数
  *)

(**
## チャーチ数(CNat)
*)
Definition CNat := forall X, (X -> X) -> X -> X.

Definition C0 : CNat := fun X => fun s : X -> X =>
                                   fun z : X => z.
Definition C1 : CNat := fun X => fun s : X -> X =>
                                   fun z : X => s z.
Definition C2 : CNat := fun X => fun s : X -> X =>
                                   fun z : X => s (s z).
Definition CSucc : CNat -> CNat :=
  fun n : CNat => fun X =>
                    fun s : X -> X =>
                      fun z : X => s (n X s z).
Eval compute in CSucc C0.

(**
## InductiveなNatの定義
*)
Inductive Nat : Type :=
| O
| S of Nat.

(**
## CNatとNatの間の変換

### CNatをNatに変換する関数
*)
Definition CNat2Nat (c : CNat) : Nat :=
  c Nat S O.

Eval compute in CNat2Nat C2.
(**
= S (S O) : Nat

これはチャーチ数cに、Sをfoldしているとみることもできる。
 *)

(**
### Fold関数

Inductiveに定義したNatに対しては、Foldを定義しなければならない。
*)
Fixpoint foldNat (X : Type) (s : X -> X) (z : X) (n : Nat) : X :=
  match n with
    | O => z
    | S n' => s (foldNat X s z n')
  end.

Check foldNat.
(**
 : forall X : Type, (X -> X) -> X -> Nat -> X
 *)

(**
### NatをCNatに変換する関数
*)
Definition Nat2CNat (n : Nat) : CNat :=
  fun X =>
    fun s : X -> X =>
      fun z : X => foldNat X s z n.

Eval compute in Nat2CNat (S (S O)).
(**
 = fun (X : Type) (s : X -> X) (z : X) => s (s z) : CNat

Inductiveに定義された整数nに、sをFoldし、そのsをλ抽象すると、チャーチ数が得られる。
 *)

(**
## 証明

### C0とOが同じ、CSuccとSの結果が同じになることの証明
*)
Theorem CNat_Nat_zero :
  CNat2Nat C0 = O.
Proof.
    by [].
Qed.

Theorem CNat_Nat_succ :
  forall c n,
    CNat2Nat c = n -> CNat2Nat (CSucc c) = S n.
Proof.
  rewrite /CNat2Nat /CSucc.
    by move=> c n ->.
Qed.

(**
### CNat2NatとNat2CNatで元に戻ることの証明
*)
Theorem CNat2Nat_Nat2CNat :
  forall n : Nat, CNat2Nat(Nat2CNat n) = n.
Proof.
  rewrite /CNat2Nat /Nat2CNat.
  elim.
    by [].
  by move=> /= n0 ->.
Qed.

(**
# 自然数のリスト

要素の自然数は、SSReflectのnatの定義を使う。
*)
(**
## チャーチ表現
*)
Definition CListNat := forall R, (nat -> R -> R) -> R -> R.

Definition CNil : CListNat :=
  fun R => fun c : nat -> R -> R =>
             fun n : R => n.                (* [] *)
Definition CL1 : CListNat :=
  fun R => fun c : nat -> R -> R =>
             fun n : R => c 1 n.            (* [1] *)
Definition CL2 : CListNat :=
  fun R => fun c : nat -> R -> R =>
             fun n : R => c 1 (c 2 n).      (* [1,2] *)
Definition CL3 : CListNat :=
  fun R => fun c : nat -> R -> R =>
             fun n : R => c 1 (c 2 (c 3 n)). (* [1,2,3] *)
Definition CCons : nat -> CListNat -> CListNat :=
  fun hd : nat =>
    fun tl : CListNat =>
      fun R =>
        fun c : nat -> R -> R =>
          fun n : R => c hd (tl R c n).
Eval compute in CCons 1 CNil.

(**
## Inductiveな定義
*)
Inductive ListNat : Type :=
| Nil
| Cons of nat & ListNat.

(**
## clistとlistの間の変換

### clistをlistに変換する関数
*)
Definition clist2list (c : CListNat) : ListNat :=
  c ListNat Cons Nil.

Eval compute in clist2list CL2.
(**
= Cons 1 (Cons 2 Nil) : ListNat

clist2listは、チャーチ表現のリストcに、Consをfoldrしているとみることもできる。
 *)

(**
### Foldr関数

Inductiveに定義したlistに対しては、Foldを定義しなければならない。
*)
Fixpoint foldr (R : Type) (c : nat -> R -> R) (n : R) (l : ListNat) : R :=
  match l with
    | Nil => n
    | Cons x l' => c x (foldr R c n l')
  end.

Check foldr.
(**
 : forall R : Type, (nat -> R -> R) -> R -> ListNat -> R
 *)

(**
### listをclistに変換する関数
*)
Definition list2clist (l : ListNat) : CListNat :=
  fun R =>
    fun c : nat -> R -> R =>
      fun n : R => foldr R c n l.

Eval compute in list2clist (Cons 1 (Cons 2 Nil)).
(**
 = fun (R : Type) (c : nat -> R -> R) (n : R) => c 1 (c 2 n) : CListNat

Inductiveに定義されたリストlに、cをFoldrし、そのcをλ抽象すると、
チャーチ表現で表したリストが得られる。
 *)

(**
## 証明

### CNilとnilが同じ、CConsとConsの結果が同じになることの証明
*)
Theorem clist_list_nil :
  clist2list CNil = Nil.
Proof.
    by [].
Qed.

Theorem clist_list_cons :
  forall c l n,
    clist2list c = l ->
    clist2list (CCons n c) = Cons n l.
Proof.
  rewrite /clist2list /CCons.
    by move=> c l n ->.
Qed.

(**
## clist2listとlist2clistで元に戻ることの証明
*)

Theorem clist2list_list2clist :
  forall l : ListNat, clist2list(list2clist l) = l.
Proof.
  rewrite /clist2list /list2clist.
  elim.
    by [].
  by move=> /= n l ->.
Qed.

(**
# まとめ

わかったこと。
チャーチ数やリストのチャーチ表現は、それ自身にFoldの機能を持っていること。
また、Inductiveに定義したnatやlistは、Fold関数によってチャーチ表現に変換できること。

参考文献2.は、無限大のチャーチ数と不動点演算子の関係をHaskellで
論じたもので、FoldNatの定義などを参考にさせていただいた。
*)

(**
# 参考文献

1. Pierce、住井 監訳「型システム入門 プログラミング言語と型の理論」オーム社
2. 酒井 「不動点演算子はチャーチ数での無限大?」 http://msakai.jp/d/?date=20100628
*)

(* END *)


(* Exercise 65 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

(* On a finite domain, existence implies a disjunction
   over different elements; this is less trivial *)

Hypothesis Domain : exists x1 : D, exists x2 : D, exists x3 : D,
  (forall x : D, (x = x1 \/ x = x2 \/ x = x3)) /\
  ~(x1 = x2) /\ ~(x1 = x3) /\ ~(x2 = x3).

Hypothesis P_holds : exists x : D, P x.

Theorem exercise_065 : exists x1 : D, exists x2 : D, exists x3 : D, (P x1 \/ P x2 \/ P x3) /\ ~(x1 = x2)
  /\ ~(x1 = x3) /\ ~(x2 = x3).
Proof.
exi_e (exists x1 : D, exists x2 : D, exists x3 : D,
  (forall x : D, (x = x1 \/ x = x2 \/ x = x3)) /\
  ~(x1 = x2) /\ ~(x1 = x3) /\ ~(x2 = x3)) a a1.
hyp Domain.
exi_e (exists x2 : D, exists x3 : D,
  (forall x : D, (x = a \/ x = x2 \/ x = x3)) /\
  ~(a = x2) /\ ~(a = x3) /\ ~(x2 = x3)) b a2.
hyp a1.
exi_e (exists x3 : D,
  (forall x : D, (x = a \/ x = b \/ x = x3)) /\
  ~(a = b) /\ ~(a = x3) /\ ~(b = x3)) c a3.
hyp a2.
exi_i a.
exi_i b.
exi_i c.
con_i.
exi_e (exists x:D, P x) d a4.
hyp P_holds.
dis_e (d = a \/ d = b \/ d = c) a5 a5.
all_e (forall x:D, x = a \/ x = b \/ x = c) d.
con_e1 (a <> b /\ a <> c /\ b <> c).
hyp a3.
dis_i1.
replace a with d.
hyp a4.
dis_e (d = b \/ d = c) a6 a6.
hyp a5.
dis_i2.
dis_i1.
replace b with d.
hyp a4.
dis_i2.
dis_i2.
replace c with d.
hyp a4.
con_e2 (forall x:D, x = a \/ x = b \/ x = c).
hyp a3.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
intros.
induction x.
- rewrite plus_zero. reflexivity.
- simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x). rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
intros.
induction x.
- rewrite mult_zero. reflexivity.
- simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut (mult y z) z). rewrite <- plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural), eq (mult (fac x) y) (qfac x y).
Proof.
induction x.
- reflexivity.
- intros. simpl. rewrite <- IHx. lfind. Admitted.


Require Import QArith.
Require Import Arith.
Require Import Reals.
Require Import Psatz.
Require Import QArith.Qminmax.
Require Lra.

Require Import List.

Structure box :=
{
p1 :Q*Q;
p2 :Q*Q;p3 :Q*Q;p4 :Q*Q;
p1p4 : fst p1 = fst p4;
p1p2 : snd p1 = snd p2;
p2p3 : fst p2 = fst p3;
p3p4 : snd p3 = snd p4;
cwp1p2 : fst p1 < fst p2;
cwp3p4 : fst p4 < fst p3;
cwp1p4 : snd p4 < snd p1;
cwp2p3 : snd p3 < snd p2;
}.

Definition point_in_box (p: Q*Q )( b :box) :=
fst p < fst (p3 b) /\ fst p > fst (p1 b)
/\ snd p < snd (p1 b) /\ snd p > snd (p3 b).

(* waybelow relation based on set inclusion*)
Definition box_waybelow (A  B : box) :=
(point_in_box (p1 B) A) /\ (point_in_box (p3 B) A).

Lemma waybelow_point_inclusion: forall A B:box , forall p:Q*Q ,
(box_waybelow A B ) -> (point_in_box p B ) -> (point_in_box p A).
Proof.
intros.
unfold box_waybelow in *.
unfold point_in_box in *.
destruct H. destruct H. destruct H2. destruct H3.
destruct H1. destruct H5. destruct H6. destruct H0. destruct H8. destruct H9.
split. lra.
split. lra.
split.  lra.  lra.
Qed.

Lemma waybelow_trans : forall A B C : box,
box_waybelow A B -> box_waybelow B C -> box_waybelow A C.
Proof.
intros.
unfold box_waybelow .
destruct H0.
split. apply (waybelow_point_inclusion   A B (p1 C)).
-exact H.
-exact H0.
-apply (waybelow_point_inclusion   A B (p3 C)).
  ++exact H.
  ++exact H1.
Qed.


From Coq Require Import Relations RelationClasses Setoid.
Require Export MoreOrders STDPP_compat.

(* begin snippet ComparableDef *)
Class Compare (A:Type) := compare : A -> A -> comparison.

Class Comparable {A:Type} (lt: relation A) (cmp : Compare A) :=
{
  comparable_sto :> StrictOrder lt;
  comparable_comp_spec : forall (a b : A), CompSpec eq lt a b (compare a b)
}.
(* end snippet ComparableDef *)

#[export] Hint Mode Compare ! : typeclass_instances.
#[export] Hint Mode Comparable ! - - : typeclass_instances.

Section Comparable.

  Context {A: Type}
          {lt: relation A}
          {cmp: Compare A} `{!Comparable lt cmp}.
  #[local] Notation le := (leq lt).

  #[deprecated(note="use StrictOrder_Transitive")]
   Notation lt_trans := StrictOrder_Transitive (only parsing).

  #[deprecated(note="use StrictOrder_Irreflexive")]
   Notation lt_irrefl := StrictOrder_Irreflexive (only parsing).

  (* Relation Lt *)
  Lemma lt_not_gt (a b: A): lt a b -> ~lt b a.
  Proof.
    intros Hlt Hgt.
    apply StrictOrder_Irreflexive with a; now transitivity b.
  Qed.

  Lemma lt_not_ge (a b: A): lt a b -> ~ le b a.
  Proof.
    intros Hlt Hle.
    apply le_lt_eq in Hle as [Hgt | Heq].
    - now apply lt_not_gt in Hlt.
    - subst; now apply StrictOrder_Irreflexive in Hlt.
  Qed.

  Lemma compare_lt_iff (a b: A):
    compare a b = Lt <-> lt a b.
  Proof.
    pose proof (comparable_comp_spec a b) as [Heq | H | H];
    split; intro; subst; try easy.
    - now apply StrictOrder_Irreflexive  in H.
    - now apply lt_not_gt in H.
  Qed.

  Lemma compare_lt_trans (a b c: A):
    compare a b = Lt -> compare b c = Lt -> compare a c = Lt.
  Proof.
    intros Hab Hbc.
    apply compare_lt_iff in Hab, Hbc; apply compare_lt_iff.
    now transitivity b.
  Qed.

  Lemma compare_lt_irrefl (a: A): ~compare a a = Lt.
  Proof.
    intro H.
    now apply compare_lt_iff, StrictOrder_Irreflexive in H.
  Qed.

  Lemma compare_eq_iff (a b: A): compare a b = Eq <-> a = b.
  Proof.
    pose proof (comparable_comp_spec a b) as [Heq | H | H];
    split; intro; subst; try easy;
    now apply StrictOrder_Irreflexive in H.
  Qed.

  Lemma compare_refl (a: A):
    compare a a = Eq.
  Proof.
    pose proof (comparable_comp_spec a a) as [H | H | H].
    1: reflexivity.
    all: now apply StrictOrder_Irreflexive in H.
  Qed.

  Lemma compare_eq_trans (a b c: A):
    compare a b = Eq -> compare b c = Eq -> compare a c = Eq.
  Proof.
    intros Hab Hbc.
    apply compare_eq_iff in Hab, Hbc; apply compare_eq_iff.
    now subst.
  Qed.

  (* Relation Gt *)
  Lemma compare_gt_iff (a b: A):
    compare a b = Gt <-> lt b a.
  Proof.
    pose proof (comparable_comp_spec a b) as [Heq | Hlt | Hgt];
    split; intro; subst; try easy.
    - now apply StrictOrder_Irreflexive in H.
    - now apply lt_not_gt in H.
  Qed.

  Lemma compare_gt_irrefl (a: A):
    ~compare a a = Gt.
  Proof.
    intros H.
    now apply compare_gt_iff, StrictOrder_Irreflexive in H.
  Qed.

  Lemma compare_gt_trans (a b c: A):
    compare a b = Gt -> compare b c = Gt -> compare a c = Gt.
  Proof.
    intros Hab Hbc.
    apply compare_gt_iff in Hab, Hbc; apply compare_gt_iff.
    now transitivity b.
  Qed.

  Lemma compare_lt_not_gt (a b: A):
    compare a b = Lt -> ~ compare a b = Gt.
  Proof.
    intros Hlt Hgt.
    apply compare_lt_iff in Hlt.
    apply compare_gt_iff in Hgt.
    now apply lt_not_gt in Hgt.
  Qed.

  Lemma compare_gt_not_lt (a b: A):
    compare a b = Gt -> ~ compare a b = Lt.
  Proof.
    intros Hgt Hlt.
    apply compare_lt_iff in Hlt.
    apply compare_gt_iff in Hgt.
    now apply lt_not_gt in Hgt.
  Qed.

  Lemma le_refl (a: A): le a a.
  Proof.
    apply le_lt_eq; now right.
  Qed.

  Lemma compare_le_iff_refl (a: A):
    le a a <-> compare a a = Eq.
  Proof.
    split; intros H.
    - apply compare_refl.
    - apply le_refl.
  Qed.

  Lemma compare_le_iff (a b: A):
    le a b <-> compare a b = Lt \/ compare a b = Eq.
  Proof.
    split; intro H.
    - apply le_lt_eq in H as [Hlt | Heq].
      * left; now apply compare_lt_iff.
      * right; now apply compare_eq_iff.
    - apply le_lt_eq; destruct H as [Hlt | Heq].
      * left; now apply compare_lt_iff.
      * right; now apply compare_eq_iff in Heq.
  Qed.

  Lemma compare_ge_iff (a b: A):
    le b a <-> compare a b = Gt \/ compare a b = Eq.
  Proof.
    rewrite compare_le_iff, compare_lt_iff, compare_gt_iff, !compare_eq_iff;
      intuition.
  Qed.

  Lemma le_trans (a b c: A):
    le a b -> le b c -> le a c.
  Proof.
    rewrite !le_lt_eq.
    intros [Hlt_ab | Heq_ab] [Hlt_bc | Heq_bc].
    - left; now transitivity b.
    - left; now subst.
    - left; now subst.
    - right; now subst.
  Qed.

  Lemma le_lt_trans (a b c: A):
    le a b -> lt b c -> lt a c.
  Proof.
    intros Hle_ab Hlt_bc.
    apply le_lt_eq in Hle_ab as [Heq_ab | Hlt_ab].
    - now transitivity b.
    - now subst.
  Qed.

  Lemma lt_le_trans (a b c: A):
    lt a b -> le b c -> lt a c.
  Proof.
    rewrite le_lt_eq.
    intros Hlt_ab [Heq_bc | Hlt_bc].
    - now transitivity b.
    - now subst.
  Qed.

  Lemma lt_incl_le (a b: A):
    lt a b -> le a b.
  Proof.
    intro H.
    apply le_lt_eq; now left.
  Qed.

  Lemma le_not_gt (a b: A):
    le a b -> ~ lt b a.
  Proof.
    intros Hlt Hle.
    now apply lt_not_ge in Hlt.
  Qed.

  (* Max lemmas *)
  #[using="All"]
  Definition max (a b : A): A :=
  match compare a b with
  | Gt => a
  | _ => b
  end.

  Lemma max_dec (a b: A):
    max a b = a \/ max a b = b.
  Proof.
    unfold max.
    pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab]; tauto.
  Qed.

  Lemma max_comm (a b: A):
    max a b = max b a.
  Proof.
    unfold max.
    pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab];
    pose proof (comparable_comp_spec b a) as [Hba | Hba | Hba].
    5,9: now apply lt_not_gt in Hab.
    all: easy.
  Qed.

  Lemma max_ge_a (a b: A):
    le b a <-> max a b = a.
  Proof.
    unfold max.
    split; intro H.
    - apply compare_ge_iff in H as [Hlt | Heq].
      + now rewrite Hlt.
      + rewrite Heq. now apply compare_eq_iff in Heq.
    - pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab].
      + subst. apply le_refl.
      + exfalso.
        apply compare_lt_iff in Hab.
        rewrite Hab in H; subst; rewrite compare_refl in Hab; discriminate.
      + now apply lt_incl_le.
  Qed.

  Lemma max_ge_b (a b: A):
    le a b <-> max a b = b.
  Proof.
    unfold max;
      rewrite le_lt_eq, <- compare_lt_iff, <- compare_eq_iff.
    split; intro H.
    - now destruct H as [-> | ->].
    - pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab].
      + now right.
      + now left.
      + exfalso.
        apply compare_gt_iff in Hab.
        rewrite Hab in H.
        subst.
        now apply compare_gt_irrefl in Hab.
  Qed.

  Lemma max_refl (a: A):  max a a = a.
  Proof.
    apply max_ge_a, le_refl.
  Qed.

  Lemma le_max_a (a b: A): le a (max a b).
  Proof.
    unfold max.
    pose proof (comparable_comp_spec a b) as [Heq | Hlt | Hgt].
    1,3: subst; now apply le_refl.
    now apply lt_incl_le.
  Qed.

  Lemma le_max_b (a b: A): le b (max a b).
  Proof.
    rewrite max_comm; apply le_max_a.
  Qed.

  #[global] Instance max_assoc : Assoc eq max.
  Proof.
    intros a b c; unfold max.
    pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab];
    pose proof (comparable_comp_spec b c) as [Hbc | Hbc | Hbc];
    pose proof (comparable_comp_spec a c) as [Hac | Hac | Hac];
    subst; try rewrite compare_refl; try easy.
    - now apply lt_not_gt in Hbc.
    - now apply lt_not_gt in Hab.
    - exfalso.
      assert (Hca: lt a c) by (now transitivity b).
      now apply (lt_not_gt _ _  Hac Hca).
    - now apply compare_lt_iff in Hab as ->.
    - now apply compare_lt_iff in Hab as ->.
    - now apply compare_lt_iff in Hab as ->.
    - now apply lt_not_gt in Hbc.
    - exfalso.
      assert (Hca : lt c a) by (now transitivity b).
      apply lt_not_gt in Hac; now apply Hac.
    - now apply compare_gt_iff in Hab as ->.
  Qed.

  (* Min lemmas*)
  #[using="All"]
  Definition min (a b :A): A :=
  match compare a b with
  | Lt => a
  | _ => b
  end.

  Lemma min_max_iff (a b: A):
    min a b = a <-> max a b = b.
  Proof.
    unfold min, max.
    pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab]; subst; easy.
  Qed.

  Lemma min_comm (a b: A):
    min a b = min b a.
  Proof.
    unfold min.
    pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab];
        pose proof (comparable_comp_spec b a) as [Hba | Hba | Hba].
        5,9: now apply lt_not_gt in Hab.
        all: easy.
  Qed.

  Lemma min_dec (a b: A):
    min a b = a \/ min a b = b.
  Proof.
    rewrite min_max_iff, min_comm, min_max_iff, max_comm.
    now apply max_dec.
  Qed.

  Lemma min_le_ad (a b: A):
    le a b <-> min a b = a.
  Proof.
    rewrite min_max_iff.
    now apply max_ge_b.
  Qed.

  Lemma min_le_b (a b: A):
    le b a <-> min a b = b.
  Proof.
    rewrite min_comm, min_max_iff.
    now apply max_ge_b.
  Qed.

  Lemma min_refl (a:A):
    min a a = a.
  Proof.
    rewrite min_max_iff.
    apply max_refl.
  Qed.

  Lemma le_min_a (a b: A):
    le (min a b) a.
  Proof.
    unfold min.
    pose proof (comparable_comp_spec a b) as [Heq | Hlt | Hgt]; subst.
    1,2: now apply le_refl.
    now apply lt_incl_le.
  Qed.

  Lemma le_min_bd (a b: A):
    le (min a b) b.
  Proof.
    rewrite min_comm.
    apply le_min_a.
  Qed.

  #[global] Instance  min_assoc: Assoc eq min.
  Proof.
    red ; intros a b c;  unfold min.
    pose proof (comparable_comp_spec a b) as [Hab | Hab | Hab];
    pose proof (comparable_comp_spec b c) as [Hbc | Hbc | Hbc];
    pose proof (comparable_comp_spec a c) as [Hac | Hac | Hac];
    subst; try rewrite compare_refl; try easy.
    - now apply lt_not_gt in Hbc.
    - now apply lt_not_gt in Hab.
    - now apply compare_lt_iff in Hab as ->.
    - exfalso.
      apply (StrictOrder_Transitive a b) in Hbc.
      2: assumption.
      now apply lt_not_gt in Hbc.
    - now apply lt_not_gt in Hab.
    - now apply compare_gt_iff in Hab as ->.
    - now apply compare_gt_iff in Hab as ->.
    - now apply compare_gt_iff in Hab as ->.
    - exfalso.
      apply (StrictOrder_Transitive  c b) in Hab.
      2: assumption.
      now apply lt_not_gt in Hab.
  Qed.

  (* other important lemmas *)

  Lemma compare_trans (a b c: A) (comp_res: comparison):
    compare a b = comp_res -> compare b c = comp_res -> compare a c = comp_res.
  Proof.
    destruct comp_res.
    - apply compare_eq_trans.
    - apply compare_lt_trans.
    - apply compare_gt_trans.
  Qed.

  Lemma compare_reflect (a b: A):
    match compare a b with
    | Lt => lt a b
    | Eq => a = b
    | Gt => lt b a
    end.
  Proof.
    pose proof (comparable_comp_spec a b) as [Heq | Hlt | Hgt]; assumption.
  Qed.

  Lemma lt_eq_lt:
    forall alpha beta, lt alpha  beta \/ alpha = beta \/ lt beta alpha.
  Proof.
    intros; destruct (comparable_comp_spec alpha beta); auto.
  Qed.

  Definition lt_eq_lt_dec
             (alpha beta : A) :
    {lt alpha  beta} + {alpha = beta} + {lt beta  alpha}.
    case_eq (compare alpha beta); intro H.
    - left;right; now rewrite <- compare_eq_iff.
    - left; left; now rewrite <- compare_lt_iff.
    - right; now rewrite <- compare_gt_iff.
  Defined.

  Lemma LimitNotSucc
        (alpha: A)  :
    Limit alpha -> forall beta, ~ Successor alpha beta.
  Proof.
    intros [[w H] H0] beta [H1 H2].
    destruct (lt_eq_lt beta w) as [H3 | [H3 | H3]].
    - apply (H2 w);auto.
    - subst w;  destruct (H0 _ H1) as [z [H3 H4]]; apply (H2 z);auto.
    - destruct (H0 beta H1) as [z [H4 H5]]; eauto.
  Qed.

End Comparable.

#[local] Ltac compare_trans H1 H2 intropattern :=
  lazymatch type of (H1, H2) with
  | ((?compare ?a ?b = ?comp_res) * (?compare ?b ?c = ?comp_res))%type =>
    assert (compare a c = comp_res) as intropattern by
          (apply compare_trans with b;
           [ exact H1 | exact H2 ])
  | ((?compare ?a ?b = ?comp_res) * (?compare ?b ?c = Eq))%type =>
    assert (compare a c = comp_res) as intropattern by
          (assert (b = c) as -> by (apply compare_eq_iff; exact H2);
           exact H1)
  | ((?compare ?a ?b = Eq) * (?compare ?b ?c = ?comp_res))%type =>
    assert (compare a c = comp_res) as intropattern by
          (assert (a = b) as -> by (apply compare_eq_iff; exact H1);
           exact H2)
  | ((?compare _ _ = _) * (?compare _ _ = _))%type => fail "Not a supported case."
  | _ => fail "Did not find hypotheses talking about compare: did you declare an instance of Comparable?"
  end.

Tactic Notation "compare" "trans" constr(H1) constr(H2) "as" simple_intropattern(intropattern) :=
  compare_trans H1 H2 intropattern.

Ltac compare_destruct_eqn a b H :=
  destruct (compare a b) eqn: H;
  [ apply compare_eq_iff in H as <-
  | apply compare_lt_iff in H
  | apply compare_gt_iff in H
  ].

Tactic Notation "compare" "destruct" constr(a) constr(b) "as" ident(H) :=
  compare_destruct_eqn a b H.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    FGroup.v

    Defintion and properties of finite groups

    Definition: FGroup
  **********************************************************************)
Require Import List.
Require Import UList.
Require Import Tactic.
Require Import ZArith.

Open Scope Z_scope.

Set Implicit Arguments.

(**************************************
  A finite group is defined for an operation op
  it has a support  (s)
  op operates inside the group (internal)
  op is associative (assoc)
  it has an element (e) that is neutral (e_is_zero_l e_is_zero_r)
  it has an inverse operator (i)
  the inverse operates inside the group (i_internal)
  it gives an inverse (i_is_inverse_l is_is_inverse_r)
 **************************************)

Record FGroup (A: Type) (op: A -> A -> A): Type := mkGroup
  {s : (list A);
   unique_s: ulist s;
   internal: forall a b, In a s -> In b s -> In (op a b) s;
   assoc: forall a b c, In a s -> In b s -> In c s -> op a (op b c) = op (op a b) c;
   e: A;
   e_in_s: In e s;
   e_is_zero_l:  forall a, In a s ->  op e a = a;
   e_is_zero_r:  forall a, In a s ->  op a e = a;
   i: A -> A;
   i_internal: forall a, In a s -> In (i a) s;
   i_is_inverse_l:  forall a, (In a s) -> op (i a) a = e;
   i_is_inverse_r:  forall a, (In a s) -> op a (i a) = e
}.

(**************************************
   The order of a group is the lengh of the support
 **************************************)

Definition g_order  (A: Type) (op: A -> A -> A) (g: FGroup op)  := Z_of_nat (length g.(s)).

Unset Implicit Arguments.

Hint Resolve unique_s internal e_in_s e_is_zero_l e_is_zero_r i_internal
  i_is_inverse_l i_is_inverse_r assoc.

Section FGroup.

Variable A: Type.
Variable op: A -> A -> A.

(**************************************
   Some properties of a finite group
 **************************************)

Theorem g_cancel_l: forall (g : FGroup op), forall a b c, In a g.(s) -> In b g.(s) -> In c g.(s) -> op a b = op a c -> b = c.
intros g a b c H1 H2 H3 H4; apply trans_equal with (op g.(e) b); sauto.
replace (g.(e)) with (op (g.(i) a)  a); sauto.
apply trans_equal with (op (i g a) (op a b)); sauto.
apply sym_equal; apply assoc with g; auto.
rewrite H4.
apply trans_equal with (op (op  (i g a) a) c); sauto.
apply assoc with g; auto.
replace (op (g.(i) a)  a) with g.(e); sauto.
Qed.

Theorem g_cancel_r: forall (g : FGroup op), forall a b c, In a g.(s) -> In b g.(s) -> In c g.(s) -> op b a = op c a -> b = c.
intros g a b c H1 H2 H3 H4; apply trans_equal with (op b g.(e)); sauto.
replace (g.(e)) with (op a (g.(i) a)); sauto.
apply trans_equal with (op (op b  a) (i g a)); sauto.
apply assoc with g; auto.
rewrite H4.
apply trans_equal with (op c (op  a (i g a))); sauto.
apply sym_equal; apply assoc with g; sauto.
replace (op a (g.(i) a)) with g.(e); sauto.
Qed.

Theorem e_unique: forall (g : FGroup op), forall e1, In e1 g.(s) ->  (forall a, In a g.(s) -> op e1 a = a) -> e1 = g.(e).
intros g e1 He1 H2.
apply trans_equal with (op e1 g.(e)); sauto.
Qed.

Theorem inv_op: forall (g: FGroup op) a b, In a g.(s) -> In b g.(s) ->  g.(i) (op a b) = op (g.(i) b) (g.(i) a).
intros g a1 b1 H1 H2; apply g_cancel_l with (g := g) (a := op a1 b1); sauto.
repeat rewrite g.(assoc); sauto.
apply trans_equal with g.(e); sauto.
rewrite <- g.(assoc) with (a := a1); sauto.
rewrite g.(i_is_inverse_r); sauto.
rewrite g.(e_is_zero_r); sauto.
Qed.

Theorem i_e: forall (g: FGroup op), g.(i) g.(e) = g.(e).
intro g; apply g_cancel_l with (g:= g) (a := g.(e)); sauto.
apply trans_equal with g.(e); sauto.
Qed.

(**************************************
   A group has at least one element
 **************************************)

Theorem g_order_pos: forall g: FGroup op, 0 < g_order g.
intro g; generalize g.(e_in_s); unfold g_order; case g.(s); simpl; auto with zarith.
intros a l _; red; auto.
Qed.

End FGroup.


Require Import Arith.
Require Import List.

Inductive Ty : Set :=
| Bool : Ty
| Stream : Ty
| Nat : Ty
| Arr : Ty -> Ty -> Ty.

Notation "T ==> S" := (Arr T S) (at level 30, right associativity).

Inductive Term : Set :=
| v : nat -> Term
| f : nat -> Term
| succ : Term -> Term
| zero : Term
| natcase : Term -> Term -> Term -> Term
| snil : Term
| scons : Term -> Term -> Term
| streamcase : Term -> Term -> Term -> Term
| true : Term
| false : Term
| boolcase : Term -> Term  -> Term -> Term
| lam : Ty -> Term -> Term
| app : Term -> Term -> Term.

Fixpoint shiftn (n : nat) (d : nat) (x : Term) {struct x} : Term :=
  match x with
    | v m => if le_lt_dec d m then v (n+m) else v m
    | f m => f m
    | succ t => succ (shiftn n d t)
    | zero => zero
    | natcase r s t => natcase (shiftn n d r) (shiftn n d r) (shiftn n (S d) t)
    | snil => snil
    | scons h t => scons (shiftn n d h) (shiftn n d t)
    | streamcase r s t => streamcase (shiftn n d r) (shiftn n d s) (shiftn n (S (S d)) t)
    | true => true
    | false => false
    | boolcase r s t => boolcase (shiftn n d r) (shiftn n d s) (shiftn n d t)
    | lam ty t => lam ty (shiftn n (S d) t)
    | app r s => app (shiftn n d r) (shiftn n d s)
  end.

Definition shift := shiftn 1 0.

Definition sub : forall (t : Term) (n : nat) (u : Term), Term.
Proof.
  refine
    (fix sub (t : Term) (n : nat) (u : Term) :=
      match t with
        | v m => match le_lt_dec n m with
                   | left p => match eq_nat_dec n m with
                                 | left _ => u
                                 | right p' =>
                                   (match m as m' return (m = m' -> Term) with
                                      | 0 => (fun p'' => False_rec _ _)
                                      | S m' => (fun _ => v m')
                                    end) (refl_equal m)
                               end
                   | right _ => v m
                 end
        | f m => f m
        | succ t => succ (sub t n u)
        | zero => zero
        | natcase r s t => natcase (sub r n u) (sub s n u) (sub t (S n) (shift u))
        | snil => snil
        | scons h t => scons (sub h n u) (sub t n u)
        | streamcase r s t => streamcase (sub r n u) (sub s n u) (sub t (S (S n)) (shiftn 2 0 u))
        | true => true
        | false => false
        | boolcase r s t => boolcase (sub r n u) (sub s n u) (sub t n u)
        | lam ty t => lam ty (sub t n (shift u))
        | app r s => app (sub r n u) (sub s n u)
      end).
  destruct m. apply le_n_O_eq in p. apply p'. auto. inversion p''.
Defined.

Definition Ctx := list Ty.

Inductive Holds (G : Ctx) (t : Term) (ty : Ty) : Set :=
| holds : Holds G t ty.

Notation "G |= t @ ty" := (Holds G t ty) (at level 40, no associativity).

Check forall G t ty P, P (G |= t @ ty).

Notation "[]" := nil.
Notation "[ x ]" := (cons x nil).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).

Open Scope list_scope.

(*  Inductive Chain : (S )  *)

Variable Delta : nat -> Term.

Fixpoint idx (n : nat) (G : Ctx) : option Ty :=
  match G with
    | [] => None
    | (x::t) => match n with
                  | O => Some x
                  | S n' => idx n' t
                end
  end.

CoInductive Preproof : list Set -> Set -> Set :=
| VarIntro : forall G n ty,
  idx n G = Some ty -> Preproof [] (G |= v n @ ty)
| ImpElim : forall G A B r s,
  Preproof [(G |= r @ A ==> B) ; (G |= s @ A) ] ( G |= app r s @ B )
| ImpIntro : forall G A B r,
  Preproof [ (A::G) |= r @ B ] (G |= lam A r @ A ==> B)
| BoolIntroTrue : forall G, Preproof [] (G |= true @ Bool)
| BoolIntroFalse : forall G, Preproof [] (G |= false @ Bool)
| BoolElim : forall G C r s t,
  Preproof [( G |= r @ Bool ) ; ( G |= s @ C ) ; ( G |= t @ C ) ] (G |= boolcase r s t @ C)
| NatIntroZero : forall G, Preproof [] (G |= zero @ Nat)
| NatIntroSucc : forall G r, Preproof [G |= r @ Nat] (G |= succ r @ Nat)
| NatElim : forall G C r s t,
  Preproof [( G |= r @ Nat ) ; (G |= s @ C) ; (G |= t @ C ) ] (G |= natcase r s t @ C)
| StreamIntroNil : forall G,  Preproof [] ( G |= snil @ Stream )
| StreamIntroCons : forall G n s, Preproof [ ( G |= n @ Nat ) ; (G |= s @ Stream) ] (G |= scons n s @ Stream)
| StreamElim : forall G C r s t,
  Preproof [( G |= r @ Stream ) ; ( G |= s @ C ) ; ( (Nat::G) |= t @ C )] ( G |= natcase r s t @ C)
| Unfold : forall G C n,
  Preproof [G |= f n @ C] (G |= Delta n @ C).

Inductive Child : Set -> Set -> Type :=
| ChildStep : forall F G c d, Preproof (F++c::G) d -> Child c d
| ChildJump : forall F G c d e, Preproof (F++c::G) d -> Child d e ->  Child c e.

Inductive FinitePreproof : list Set -> Set -> Type :=
| FPCopy : forall h c, Preproof h c -> FinitePreproof h c
| FPRepeat : forall c, Child c c -> FinitePreproof [] c.

Inductive HasProof : Set -> Type :=
| HasProof_witness : forall G l t A, FinitePreproof l ( G |= t @ A ) -> HasProof ( G |= t @ A ).

Fixpoint typecheck : forall G A memo (t : Term) -> option (Preproof (G |= t @ A)) :=
  match t with
    | v n => (match idx n G as mty return (idx n G = mty -> option (Preproof (G |= t @ A))) with
                | None => (fun _ => None)
                | Some ty => (fun mty => VarIntro G n ty mty)
              end) (refl (idx n G))
    | f m => match idx n memo with

| succ : Term -> Term
| zero : Term
| natcase : Term -> Term -> Term -> Term
| snil : Term
| scons : Term -> Term -> Term
| streamcase : Term -> Term -> Term -> Term
| true : Term
| false : Term
| boolcase : Term -> Term  -> Term -> Term
| lam : Ty -> Term -> Term
| app : Term -> Term -> Term.

Inductive EvalHNF : Set -> Set -> Set :=
| Eval_app : forall t s, Eval (app (lam t) s) (

| v : nat -> Term
| f : nat -> Term
| succ : Term -> Term
| zero : Term
| natcase : Term -> Term -> Term -> Term
| snil : Term
| scons : Term -> Term -> Term
| streamcase : Term -> Term -> Term -> Term
| true : Term
| false : Term
| boolcase : Term -> Term  -> Term -> Term
| lam : Ty -> Term -> Term
| app : Term -> Term -> Term.


From mathcomp Require Import ssreflect.

Require Import set_notations.

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

Require Import Coq.Sets.Image.

(* R1 斎藤毅   集合と位相 ISBN 978-4-13-062958-4 *)
(* R2 島内剛一 数学の基礎 *)
(* R3 斎藤正彦 数学の基礎 ISBN 4-13-062909-3 *)

Import SetNotations.

(* R3 1.2.4 definition *)
Inductive InvIm {U V:Type} (B: Ensemble V) (f:U -> V): Ensemble U :=
  InvIm_intro: forall (x:U), (f x) ∈ B -> x ∈ (InvIm B f).

Definition Id (A:Type) : A -> A := fun (x:A) => x.

Definition Composite {A B C : Type} (g:B -> C) (f:A -> B) : A -> C := fun (x:A) => g (f x).

Definition surjective {U V:Type} (f:U -> V) := forall y:V, exists x:U, f x = y.

Definition bijective {U V:Type} (f:U -> V) := injective U V f /\ surjective f.

(* ℑ:Unicode 2111, 𝔪:Unicode 1D52A *)
Notation "ℑ𝔪( f | A )" := (@Im _ _ A f) (at level 60).
Notation "ℑ𝔪^-1( f | A )" := (InvIm A f) (at level 60).
(* ∘ : Unicode 2218 *)
Notation "g ∘ f" := (Composite g f) (left associativity, at level 50).

Section ImgExample.
  Variable U V W:Type.

  Lemma InvIm_def: forall (B: Ensemble V) (f:U -> V) (x:U),
      x ∈ (InvIm B f) -> (f x) ∈ B.
  Proof.
    move => B f x HInvIm.
    inversion HInvIm as [y HfxB].
    apply HfxB.
  Qed.

  Lemma InvIm_inv: forall (B: Ensemble V) (f:U -> V) (x:U),
      x ∈ (InvIm B f) -> (f x) ∈ B.
  Proof.
    move => B f x HInvImB.
    inversion HInvImB as [y HyB].
    exact HyB.
  Qed.

  Lemma Img_Subset: forall (A B:Ensemble U) (f: U -> V),
      A ⊂ B -> ℑ𝔪( f | A ) ⊂ ℑ𝔪( f | B ).
  Proof.
    move => A B f H x.
    case => s HsA y Hyfs.
    rewrite Hyfs.
    apply Im_def.
    apply H.
    apply HsA.
  Qed.

  (* R2 Problem 2.3.8 *)
  Lemma Img_Union: forall (A B:Ensemble U) (f: U -> V),
      ℑ𝔪( f | A ∪ B ) = ℑ𝔪( f | A ) ∪ ℑ𝔪( f | B ).
  Proof.
    move => A B f.
    apply /Extensionality_Ensembles.
    split => x.
    move => H.
    inversion H.
    inversion H0.
    left.
    rewrite H1.
    apply Im_def.
    apply H3.
    right.
    rewrite H1.
    apply Im_def.
    apply H3.
    case => y; case => s H z H0; rewrite H0; apply Im_def.
    left.
    apply H.
    right.
    apply H.
  Qed.

  (* R2 Problem 2.3.9 *)
  Lemma Img_Intersection: forall (A B:Ensemble U) (f: U -> V),
      ℑ𝔪( f | A ∩ B ) ⊂ ℑ𝔪( f | A ) ∩ ℑ𝔪( f | B ).
  Proof.
    move => A B f x.
    case => s.
    case => t HA HB y H0.
    rewrite H0.
    split; apply Im_def.
    apply HA.
    apply HB.
  Qed.

  (* f[A] \ f[B] ⊂ f[A \ B] *)
  Goal forall (A B:Ensemble U) (f:U -> V),
      (ℑ𝔪( f | A ) \ ℑ𝔪( f | B )) ⊂ ℑ𝔪( f | (A \ B) ).
  Proof.
    move => A B f x.
    case => HImA HnImB.
    inversion HImA as [a HaA y Hxfa Hxeqy].
    rewrite Hxfa.
    apply Im_def.
    split.
    apply HaA.
    unfold not.
    move => HaB.
    apply HnImB.
    rewrite Hxfa.
    apply Im_def.
    apply HaB.
  Qed.

  (* f^-1[C ∪ D] = f^-1[C] ∪ f^-1[D] *)
  Lemma InvIm_Union:
    forall (C D: Ensemble V) (f:U->V), ℑ𝔪^-1( f | C ∪ D ) = ℑ𝔪^-1( f | C ) ∪ ℑ𝔪^-1( f | D ).
  Proof.
    move => C D f.
    apply Extensionality_Ensembles.
    split => y H.
    inversion H as [x HyCD Hxeqy].
    inversion HyCD as [v H0|].
    left.
    split.
    apply H0.
    right.
    split.
    apply H0.
    split; inversion H; inversion H0.
    left.
    apply H2.
    right.
    apply H2.
  Qed.

  (* f^-1[C ∩ D] = f^-1[C] ∩ f^-1[D] *)
  Lemma InvIm_Intersection:
    forall (C D: Ensemble V) (f:U->V), ℑ𝔪^-1( f | C ∩ D ) = ℑ𝔪^-1( f | C ) ∩ ℑ𝔪^-1( f | D ).
  Proof.
    move => C D f.
    apply Extensionality_Ensembles.
    split => x H.
    inversion H; inversion H0 as [y].
    split; split.
    apply H2.
    apply H3.
    inversion H as [y HC HD].
    inversion HC as [w].
    inversion HD as [z].
    split; split.
    apply H1.
    apply H3.
  Qed.

  (* R2 Problem 2.3.10 *)
  Goal forall (A:Ensemble U) (f:U->V), A ⊂ ℑ𝔪^-1( f | (ℑ𝔪( f | A ))).
  Proof.
    move => A f x HA.
    split.
    apply Im_def.
    apply HA.
  Qed.

  (* B⊂X -> f(f^-1(B)) ⊂ B ∩ X *)
  Goal forall (B:Ensemble V) (f:U->V), ℑ𝔪( f | (ℑ𝔪^-1( f | B))) ⊂ (B ∩ (Full_set V)).
  Proof.
    move => B f b.
    case => x H0 y Hyfx.
    inversion H0.
    rewrite Hyfx.
    split.
    apply H.
    apply Full_intro.
  Qed.

  (* h ・ ( g ・ f ) = ( h ・ g ) ・ f *)
  Lemma compsite_assc: forall (A B C D:Type) (f:A->B) (g:B->C) (h:C->D), h ∘ ( g ∘ f ) = ( h ∘ g ) ∘ f.
  Proof.
    move => A B C D f g h.
    unfold Composite.
    reflexivity.
  Qed.

  Goal forall (A B: Type) (f:A->B), id ∘ f = f.
    move => A B f.
    unfold Composite.
    unfold id.
    reflexivity.
  Qed.

  (* R3 Problem 1.3.1 (g ・ f)[A] = g[f[A]] *)
  Goal forall (X Y Z: Type) (A:Ensemble X) (f:X -> Y) (g:Y -> Z),
      ℑ𝔪( g ∘ f | A ) = ℑ𝔪( g | ℑ𝔪( f | A )).
  Proof.
    move => X Y Z A f g.
    apply /Extensionality_Ensembles.
    split => z H.
    inversion H as [x HxA].
    rewrite H0.
    apply Im_def.
    apply Im_def.
    apply HxA.
    inversion H.
    inversion H0.
    rewrite H1.
    rewrite H4.
    have L1: forall a:X, g (f a) = (g ∘ f) a.
    move => a.
    unfold Composite.
    reflexivity.
    rewrite L1.
    apply Im_def.
    apply H3.
  Qed.

  (* R3 Problem 1.3.2 R ⊂ Z -> (g ・ f)^-1[R] = f^-1 [g^-1 [R]] *)
  Goal forall (X Y Z: Type) (R:Ensemble Z) (f:X -> Y) (g:Y -> Z),
      ℑ𝔪^-1( g ∘ f | R ) =  ℑ𝔪^-1( f | ℑ𝔪^-1( g | R )).
  Proof.
    move => X Y Z R f g.
    apply /Extensionality_Ensembles.
    split => x; move => H; inversion H.
    split.
    split.
    apply H0.
    inversion H0.
    split.
    apply H2.
  Qed.

  Goal forall (f:U -> V) (g:V -> W), injective U W (g ∘ f) -> injective U V f.
  Proof.
    move => f g.
    unfold injective.
    move => H.
    move => x y Hf.
    apply H.
    unfold Composite.
    rewrite Hf.
    reflexivity.
  Qed.

  Goal forall (f:U -> V) (g:V -> W), surjective (g ∘ f) -> surjective g.
  Proof.
    move => f g.
    unfold surjective.
    move => H z.
    move: (H z) => H0.
    destruct H0.
    rewrite -H0.
    exists (f x).
    unfold Composite.
    reflexivity.
  Qed.

End ImgExample.

Export SetNotations.
Export Coq.Sets.Image.


(** * Lists: Data Structures in Coq *)

(* $Date: 2012-01-18 18:28:00 -0500 (Wed, 18 Jan 2012) $ *)

(** The next line imports all of our definitions from the
    previous chapter. *)

Require Export Basics.

(** For it to work, you need to use [coqc] to compile [Basics.v]
    into [Basics.vo].  (This is like making a .class file from a .java
    file, or a .o file from a .c file.)

    Here are two ways to compile your code:

     - CoqIDE:

         Open Basics.v.
         In the "Compile" menu, click on "Compile Buffer".

     - Command line:

         Run [coqc Basics.v]

    In this file, we again use the [Module] feature to wrap all of the
    definitions for pairs and lists of numbers in a module so that,
    later, we can reuse the same names for improved (generic) versions
    of the same operations. *)

Module NatList.

(* ###################################################### *)
(** * Pairs of Numbers *)

(** In an [Inductive] type definition, each constructor can take
    any number of parameters -- none (as with [true] and [O]), one (as
    with [S]), or more than one, as in this definition: *)

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

(** This declaration can be read: "There is just one way to
    construct a pair of numbers: by applying the constructor [pair] to
    two arguments of type [nat]." *)

(** We can construct an element of [natprod] like this: *)

Eval simpl in (pair 3 5).

(** Here are two simple function definitions for extracting the
    first and second components of a pair.  (The definitions also
    illustrate how to do pattern matching on two-argument
    constructors.) *)

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.
Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Eval simpl in (fst (pair 3 5)).

(** Since pairs are used quite a bit, it is nice to be able to
    write them with the standard mathematical notation [(x,y)] instead
    of [pair x y].  We can tell Coq to allow this with a [Notation]
    declaration. *)

Notation "( x , y )" := (pair x y).

(** The new notation can be used both in expressions and in
    pattern matches (indeed, we've seen it already in the previous
    chapter -- this notation is provided as part of the standard
    library): *)

Eval simpl in (fst (3,5)).

Definition fst' (p : natprod) : nat :=
  match p with
  | (x,y) => x
  end.
Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) => y
  end.

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

(** Let's try and prove a few simple facts about pairs.  If we
    state the lemmas in a particular (and slightly peculiar) way, we
    can prove them with just reflexivity (and its built-in
    simplification): *)

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity.  Qed.

(** But reflexivity is not enough if we state the lemma in a more
    natural way: *)

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  simpl. (* Doesn't reduce anything! *)
Admitted.

(** We have to expose the structure of [p] so that [simpl] can
    perform the pattern match in [fst] and [snd].  We can do this with
    [destruct].

    Notice that, unlike for [nat]s, [destruct] doesn't generate an
    extra subgoal here.  That's because [natprod]s can only be
    constructed in one way.  *)

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p.  destruct p as (n,m).  simpl.  reflexivity.  Qed.

(** Notice that Coq allows us to use the notation we introduced
    for pairs in the "[as]..." pattern that tells it what variables to
    bind. *)

(** **** Exercise: 1 star (snd_fst_is_swap) *)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as (m,n).
  simpl.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, optional (fst_swap_is_snd) *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as (m,n).
  simpl.
  reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** * Lists of Numbers *)

(** Generalizing the definition of pairs a little, we can
    describe the type of _lists_ of numbers like this: "A list is
    either the empty list or else a pair of a number and another
    list." *)

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

(** For example, here is a three-element list: *)

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

(** As with pairs, it is more convenient to write lists in
    familiar programming notation.  The following two declarations
    allow us to use [::] as an infix [cons] operator and square
    brackets as an "outfix" notation for constructing lists. *)

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(** It is not necessary to fully understand these declarations,
    but in case you are interested, here is roughly what's going on.

    The [right associativity] annotation tells Coq how to parenthesize
    expressions involving several uses of [::] so that, for example,
    the next three declarations mean exactly the same thing: *)

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1,2,3].

(** The [at level 60] part tells Coq how to parenthesize
    expressions that involve both [::] and some other infix operator.
    For example, since we defined [+] as infix notation for the [plus]
    function at level 50,
[[
Notation "x + y" := (plus x y)
                    (at level 50, left associativity).
]]
   The [+] operator will bind tighter than [::], so [1 + 2 :: [3]]
   will be parsed, as we'd expect, as [(1 + 2) :: [3]] rather than [1
   + (2 :: [3])].

   (By the way, it's worth noting in passing that expressions like "[1
   + 2 :: [3]]" can be a little confusing when you read them in a .v
   file.  The inner brackets, around 3, indicate a list, but the outer
   brackets are there to instruct the "coqdoc" tool that the bracketed
   part should be displayed as Coq code rather than running text.
   These brackets don't appear in the generated HTML.)

   The second and third [Notation] declarations above introduce the
   standard square-bracket notation for lists; the right-hand side of
   the third one illustrates Coq's syntax for declaring n-ary
   notations and translating them to nested sequences of binary
   constructors. *)

(** A number of functions are useful for manipulating lists.
    For example, the [repeat] function takes a number [n] and a
    [count] and returns a list of length [count] where every element
    is [n]. *)

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

(** The [length] function calculates the length of a list. *)

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

(** The [app] ("append") function concatenates two lists. *)

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => l2
  | h :: t => h :: (app t l2)
  end.

(** Actually, [app] will be used a lot in some parts of what
    follows, so it is convenient to have an infix operator for it. *)

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1:             [1,2,3] ++ [4,5] = [1,2,3,4,5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4,5] = [4,5].
Proof. reflexivity.  Qed.
Example test_app3:             [1,2,3] ++ nil = [1,2,3].
Proof. reflexivity.  Qed.

(** Here are two smaller examples of programming with lists.
    The [hd] function returns the first element (the "head") of the
    list, while [tail] returns everything but the first
    element.  Of course, the empty list has no first element, so we
    must pass a default value to be returned in that case.  *)

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tail (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd1:             hd 0 [1,2,3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tail:            tail [1,2,3] = [2,3].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars, recommended (list_funs) *)
(** Complete the definitions of [nonzeros], [oddmembers] and
    [countoddmembers] below.  *)

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
    |nil => nil
    |lhd::ltl => match lhd with
                   |O => nonzeros ltl
                   |_ => lhd::(nonzeros ltl)
                 end
  end.

Example test_nonzeros:            nonzeros [0,1,0,2,3,0,0] = [1,2,3].
Proof.
  simpl.
  reflexivity.
Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
   match l with
    |nil => nil
    |lhd::ltl => if oddb lhd then lhd::(oddmembers ltl) else oddmembers ltl
  end.

Example test_oddmembers:            oddmembers [0,1,0,2,3,0,0] = [1,3].
Proof.
  simpl.
  reflexivity.
Qed.

Fixpoint countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers1:    countoddmembers [1,0,3,1,4,5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers2:    countoddmembers [0,2,4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers3:    countoddmembers nil = 0.
Proof. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars (alternate) *)
(** Complete the definition of [alternate], which "zips up" two lists
    into one, alternating between elements taken from the first list
    and elements from the second.  See the tests below for more
    specific examples.

    Note: one natural way of writing [alternate] will fail to satisfy
    Coq's requirement that all [Fixpoint] definitions be "obviously
    terminating."  If you find yourself in this rut, look for a
    slightly more verbose solution that considers elements of both
    lists at the same time. *)

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
    |nil, l2' =>l2'
    |l1', nil =>l1'
    |hd1::tl1, hd2::tl2 => hd1::(hd2::(alternate tl1 tl2))
  end.
Example test_alternate1:        alternate [1,2,3] [4,5,6] = [1,4,2,5,3,6].
Proof. reflexivity. Qed.
Example test_alternate2:        alternate [1] [4,5,6] = [1,4,5,6].
Proof. reflexivity. Qed.
Example test_alternate3:        alternate [1,2,3] [4] = [1,4,2,3].
Proof. reflexivity. Qed.
Example test_alternate4:        alternate [] [20,30] = [20,30].
Proof. reflexivity. Qed.
(** [] *)

(* ###################################################### *)
(** ** Bags via Lists *)

(** A [bag] (or [multiset]) is like a set, but each element can appear
    multiple times instead of just once.  One reasonable
    implementation of bags is to represent a bag of numbers as a
    list. *)

Definition bag := natlist.

(* Ex3 (bag_functions) *)
(** Complete the following definitions for the functions
    [count], [sum], [add], and [member] for bags. *)

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
    |nil => 0
    |shd::stl => if beq_nat shd v then 1 + (count v stl) else count v stl
  end.
(** All these proofs can be done just by [reflexivity]. *)

Example test_count1:              count 1 [1,2,3,1,4,1] = 3.
Proof. reflexivity. Qed.
Example test_count2:              count 6 [1,2,3,1,4,1] = 0.
Proof. reflexivity. Qed.

(** Multiset [sum] is similar to set [union]: [sum a b] contains
    all the elements of [a] and of [b].  (Mathematicians usually
    define [union] on multisets a little bit differently, which
    is why we don't use that name for this operation.)
    For [sum] we're giving you a header that does not give explicit
    names to the arguments.  Moreover, it uses the keyword
    [Definition] instead of [Fixpoint], so even if you had names for
    the arguments, you wouldn't be able to process them recursively.
    The point of stating the question this way is to encourage you to
    think about whether [sum] can be implemented in another way --
    perhaps by using functions that have already been defined.  *)

Definition sum : bag -> bag -> bag :=
  app.

Example test_sum1:              count 1 (sum [1,2,3] [1,4,1]) = 3.
Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag :=
  cons v s.

Example test_add1:                count 1 (add 1 [1,4,1]) = 3.
Proof. reflexivity. Qed.
Example test_add2:                count 5 (add 1 [1,4,1]) = 0.
Proof. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  if beq_nat (count v s) O then false else true.

Example test_member1:             member 1 [1,4,1] = true.
Proof. reflexivity. Qed.
Example test_member2:             member 2 [1,4,1] = false.
Proof. reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (bag_more_functions) *)
(** Here are some more bag functions for you to practice with. *)

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  (* When remove_one is applied to a bag without the number to remove,
     it should return the same bag unchanged. *)
  match s with
    |nil => nil
    |shd::stl => if beq_nat shd v then stl else shd::remove_one v stl
  end.

Example test_remove_one1:         count 5 (remove_one 5 [2,1,5,4,1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one2:         count 5 (remove_one 5 [2,1,4,1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one3:         count 4 (remove_one 5 [2,1,4,5,1,4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_one4:
  count 5 (remove_one 5 [2,1,5,4,5,1,4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
    |nil => nil
    |shd::stl => if beq_nat shd v
                 then remove_all v stl
                 else shd::remove_all v stl
  end.

Example test_remove_all1:          count 5 (remove_all 5 [2,1,5,4,1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all2:          count 5 (remove_all 5 [2,1,4,1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all3:          count 4 (remove_all 5 [2,1,4,5,1,4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_all4:          count 5 (remove_all 5 [2,1,5,4,5,1,4,5,1,4]) = 0.
Proof. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
    |nil => true
    |hd1::tl1 => if member hd1 s2
                 then subset tl1 (remove_one hd1 s2)
                 else false
  end.

Example test_subset1:              subset [1,2] [2,1,4,1] = true.
Proof. reflexivity. Qed.
Example test_subset2:              subset [1,2,2] [2,1,4,1] = false.
Proof. reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars, recommended (bag_theorem) *)
(** Write down an interesting theorem about bags involving the
    functions [count] and [add], and prove it.  Note that, since this
    problem is somewhat open-ended, it's possible that you may come up
    with a theorem which is true, but whose proof requires techniques
    you haven't learned yet.  Feel free to ask for help if you get
    stuck!

*)
Theorem count_add : forall (v:nat) (b:bag),
  count v (add v b) = 1 + count v b.
Proof.
  intros v b.
  simpl.
  rewrite <- beq_nat_refl.
  reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** * Reasoning About Lists *)

(** Just as with numbers, simple facts about list-processing
    functions can sometimes be proved entirely by simplification. For
    example, the simplification performed by [reflexivity] is enough
    for this theorem... *)

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof.
   reflexivity.  Qed.

(** ... because the [[]] is substituted into the match position
    in the definition of [app], allowing the match itself to be
    simplified. *)

(** Also, as with numbers, it is sometimes helpful to perform case
    analysis on the possible shapes (empty or non-empty) of an unknown
    list. *)

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tail l).
Proof.
  intros l. destruct l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n l'".
    reflexivity.  Qed.

(** Here, the [nil] case works because we've chosen to define
    [tail nil = nil]. Notice that the [as] annotation on the [destruct]
    tactic here introduces two names, [n] and [l'], corresponding to
    the fact that the [cons] constructor for lists takes two
    arguments (the head and tail of the list it is constructing). *)

(** Usually, though, interesting theorems about lists require
    induction for their proofs. *)

(* ###################################################### *)
(** ** Micro-Sermon *)

(** Simply reading example proofs will not get you very far!  It is
    very important to work through the details of each one, using Coq
    and thinking about what each step of the proof achieves.
    Otherwise it is more or less guaranteed that the exercises will
    make no sense. *)

(* ###################################################### *)
(** ** Induction on Lists *)

(** Proofs by induction over datatypes like [natlist] are
    perhaps a little less familiar than standard natural number
    induction, but the basic idea is equally simple.  Each [Inductive]
    declaration defines a set of data values that can be built up from
    the declared constructors: a boolean can be either [true] or
    [false]; a number can be either [O] or [S] applied to a number; a
    list can be either [nil] or [cons] applied to a number and a list.

    Moreover, applications of the declared constructors to one another
    are the _only_ possible shapes that elements of an inductively
    defined set can have, and this fact directly gives rise to a way
    of reasoning about inductively defined sets: a number is either
    [O] or else it is [S] applied to some _smaller_ number; a list is
    either [nil] or else it is [cons] applied to some number and some
    _smaller_ list; etc. So, if we have in mind some proposition [P]
    that mentions a list [l] and we want to argue that [P] holds for
    _all_ lists, we can reason as follows:

      - First, show that [P] is true of [l] when [l] is [nil].

      - Then show that [P] is true of [l] when [l] is [cons n l'] for
        some number [n] and some smaller list [l'], assuming that [P]
        is true for [l'].

    Since larger lists can only be built up from smaller ones,
    eventually reaching [nil], these two things together establish the
    truth of [P] for all lists [l].  Here's a concrete example: *)

Theorem app_ass : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = cons n l1'".
    simpl. rewrite -> IHl1'. reflexivity.  Qed.

(** Again, this Coq proof is not especially illuminating as a
    static written document -- it is easy to see what's going on if
    you are reading the proof in an interactive Coq session and you
    can see the current goal and context at each point, but this state
    is not visible in the written-down parts of the Coq proof.  So a
    natural-language proof -- one written for human readers -- will
    need to include more explicit signposts; in particular, it will
    help the reader stay oriented if we remind them exactly what the
    induction hypothesis is in the second case.  *)

(** _Theorem_: For all lists [l1], [l2], and [l3],
   [(l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3)].

   _Proof_: By induction on [l1].

   - First, suppose [l1 = []].  We must show
[[
       ([] ++ l2) ++ l3 = [] ++ (l2 ++ l3),
]]
     which follows directly from the definition of [++].

   - Next, suppose [l1 = n::l1'], with
[[
       (l1' ++ l2) ++ l3 = l1' ++ (l2 ++ l3)
]]
     (the induction hypothesis). We must show
[[
       ((n :: l1') ++ l2) ++ l3 = (n :: l1') ++ (l2 ++ l3).
]]
     By the definition of [++], this follows from
[[
       n :: ((l1' ++ l2) ++ l3) = n :: (l1' ++ (l2 ++ l3)),
]]
     which is immediate from the induction hypothesis.  []

  Here is an exercise to be worked together in class: *)

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros l1 l2. induction l1 as [| n l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> IHl1'. reflexivity.  Qed.

(** For a slightly more involved example of an inductive proof
    over lists, suppose we define a "cons on the right" function
    [snoc] like this... *)

Fixpoint snoc (l:natlist) (v:nat) : natlist :=
  match l with
  | nil    => [v]
  | h :: t => h :: (snoc t v)
  end.

(** ... and use it to define a list-reversing function [rev]
    like this: *)

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil    => nil
  | h :: t => snoc (rev t) h
  end.

Example test_rev1:            rev [1,2,3] = [3,2,1].
Proof. reflexivity.  Qed.
Example test_rev2:            rev nil = nil.
Proof. reflexivity.  Qed.

(** Now let's prove some more list theorems using our newly
    defined [snoc] and [rev].  For something a little more challenging
    than the inductive proofs we've seen so far, let's prove that
    reversing a list does not change its length.  Our first attempt at
    this proof gets stuck in the successor case... *)

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    (* This is the tricky case.  Let's begin as usual by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality involving
       [snoc], but we don't have any equations in either the
       immediate context or the global environment that have
       anything to do with [snoc]!

       We can make a little progress by using the IH to rewrite the
       goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Admitted.

(** So let's take the equation about [snoc] that would have
    enabled us to make progress and prove it as a separate lemma. *)

Theorem length_snoc : forall n : nat, forall l : natlist,
  length (snoc l n) = S (length l).
Proof.
  intros n l. induction l as [| n' l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n' l'".
    simpl. rewrite -> IHl'. reflexivity.  Qed.

(** Now we can complete the original proof. *)

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> length_snoc.
    rewrite -> IHl'. reflexivity.  Qed.

(** For comparison, here are informal proofs of these two theorems:

    _Theorem_: For all numbers [n] and lists [l],
       [length (snoc l n) = S (length l)].

    _Proof_: By induction on [l].

    - First, suppose [l = []].  We must show
[[
        length (snoc [] n) = S (length []),
]]
      which follows directly from the definitions of
      [length] and [snoc].

    - Next, suppose [l = n'::l'], with
[[
        length (snoc l' n) = S (length l').
]]
      We must show
[[
        length (snoc (n' :: l') n) = S (length (n' :: l')).
]]
      By the definitions of [length] and [snoc], this
      follows from
[[
        S (length (snoc l' n)) = S (S (length l')),
]]
      which is immediate from the induction hypothesis. [] *)

(** _Theorem_: For all lists [l], [length (rev l) = length l].

    _Proof_: By induction on [l].

      - First, suppose [l = []].  We must show
[[
          length (rev []) = length [],
]]
        which follows directly from the definitions of [length]
        and [rev].

      - Next, suppose [l = n::l'], with
[[
          length (rev l') = length l'.
]]
        We must show
[[
          length (rev (n :: l')) = length (n :: l').
]]
        By the definition of [rev], this follows from
[[
          length (snoc (rev l') n) = S (length l')
]]
        which, by the previous lemma, is the same as
[[
          S (length (rev l')) = S (length l').
]]
        This is immediate from the induction hypothesis. [] *)

(** Obviously, the style of these proofs is rather longwinded
    and pedantic.  After the first few, we might find it easier to
    follow proofs that give a little less detail overall (since we can
    easily work them out in our own minds or on scratch paper if
    necessary) and just highlight the non-obvious steps.  In this more
    compressed style, the above proof might look more like this: *)

(** _Theorem_:
     For all lists [l], [length (rev l) = length l].

    _Proof_: First, observe that
[[
       length (snoc l n) = S (length l)
]]
     for any [l].  This follows by a straightforward induction on [l].
     The main property now follows by another straightforward
     induction on [l], using the observation together with the
     induction hypothesis in the case where [l = n'::l']. [] *)

(** Which style is preferable in a given situation depends on
    the sophistication of the expected audience and on how similar the
    proof at hand is to ones that the audience will already be
    familiar with.  The more pedantic style is a good default for
    present purposes. *)

(* ###################################################### *)
(** ** [SearchAbout] *)

(** We've seen that proofs can make use of other theorems we've
    already proved, using [rewrite], and later we will see other ways
    of reusing previous theorems.  But in order to refer to a theorem,
    we need to know its name, and remembering the names of all the
    theorems we might ever want to use can become quite difficult!  It
    is often hard even to remember what theorems have been proven,
    much less what they are named.

    Coq's [SearchAbout] command is quite helpful with this.  Typing
    [SearchAbout foo] will cause Coq to display a list of all theorems
    involving [foo].  For example, try uncommenting the following to
    see a list of theorems that we have proved about [rev]: *)

(* SearchAbout rev. *)

(** Keep [SearchAbout] in mind as you do the following exercises and
    throughout the rest of the course; it can save you a lot of time! *)

(** Also, if you are using ProofGeneral, you can run [SearchAbout]
    with [C-c C-f]. Pasting its response into your buffer can be
    accomplished with [C-c C-;]. *)

(* ###################################################### *)
(** ** List Exercises, Part 1 *)

(** **** Exercise: 3 stars, recommended (list_exercises) *)
(** More practice with lists. *)

Theorem app_nil_end : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l.
  induction l as [| lhd ltl].
  Case "l = []".
      reflexivity.
  Case "l = lhd::ltl".
      simpl. rewrite -> IHltl. reflexivity.
Qed.

Theorem rev_snoc : forall (n:nat) (l:natlist),
  rev (snoc l n) = n :: rev l.
Proof.
  intros n l.
  induction l as [| lhd ltl].
  Case "l = []".
      reflexivity.
  Case "l = lhd::ltl".
      simpl. rewrite -> IHltl. simpl. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l.
  induction l as [| lhd ltl].
  Case "l = []".
      reflexivity.
  Case "l = lhd::ltl".
      simpl. rewrite -> rev_snoc. rewrite -> IHltl. reflexivity.
Qed.

Theorem app_in_snoc : forall (l1 l2:natlist) (n:nat),
  snoc (l1 ++ l2) n = l1 ++ snoc l2 n.
Proof.
  intros l1 l2 n.
  induction l1 as [| hd1 tl1].
  Case "l1 = []".
      reflexivity.
  Case "l1 = hd1::tl1".
      simpl. rewrite -> IHtl1. reflexivity.
Qed.

Theorem distr_rev : forall l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros l1 l2.
  induction l1 as [| hd1 tl1].
  Case "l1 = []".
      simpl. rewrite -> app_nil_end. reflexivity.
  Case "l1 = hd1::tl1".
      simpl. rewrite -> IHtl1. rewrite -> app_in_snoc. reflexivity.
Qed.

(** There is a short solution to the next exercise.  If you find
    yourself getting tangled up, step back and try to look for a
    simpler way. *)

Theorem app_ass4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  rewrite <- app_ass. rewrite <- app_ass. reflexivity.
Qed.

Theorem snoc_append : forall (l:natlist) (n:nat),
  snoc l n = l ++ [n].
Proof.
  intros l n.
  induction l as [| lhd ltl].
  Case "l = []".
      reflexivity.
  Case "l = lhd::ltl".
      simpl. rewrite -> IHltl. reflexivity.
Qed.

(** An exercise about your implementation of [nonzeros]: *)

Lemma nonzeros_length : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  induction l1 as [| hd1 tl1].
  Case "l1 = []".
      reflexivity.
  Case "l1 = hd1::tl1".
      destruct hd1 as [| hd1'].
      SCase "hd1 = O".
          simpl. rewrite -> IHtl1. reflexivity.
      SCase "hd1 = S hd1'".
          simpl. rewrite -> IHtl1. reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** ** List Exercises, Part 2 *)

(** **** Exercise: 2 stars, recommended (list_design) *)
(** Design exercise:
     - Write down a non-trivial theorem involving [cons]
       ([::]), [snoc], and [append] ([++]).
     - Prove it. *)

Theorem cons_snoc_ass : forall (l1 l2:natlist) (n:nat),
  l1 ++ (n::l2) = snoc l1 n ++ l2.
Proof.
  intros l1 l2 n.
  induction l1 as [| hd1 tl1].
  Case "l1 = []".
      reflexivity.
  Case "l1 = hd1::tl1".
      simpl. rewrite -> IHtl1. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (bag_proofs) *)
(** If you did the optional exercise about bags above, here are a
    couple of little theorems to prove about your definitions. *)

Theorem count_member_nonzero : forall (s : bag),
  ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  intros s.
  simpl.
  reflexivity.
Qed.

(** The following lemma about [ble_nat] might help you in the next proof. *)

Theorem ble_n_Sn : forall n,
  ble_nat n (S n) = true.
Proof.
  intros n. induction n as [| n'].
  Case "0".
    simpl.  reflexivity.
  Case "S n'".
    simpl.  rewrite IHn'.  reflexivity.  Qed.

Theorem remove_decreases_count: forall (s : bag),
  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s.
  induction s as [| shd stl].
  Case "s = []".
      reflexivity.
  Case "s = shd::stl".
      simpl.
      destruct shd as [| shd'].
      SCase "shd = O".
          simpl. rewrite -> ble_n_Sn. reflexivity.
      SCase "shd = S hd'".
          simpl. rewrite -> IHstl. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (bag_count_sum) *)
(** Write down an interesting theorem about bags involving the
    functions [count] and [sum], and prove it.
*)
Theorem count_sum : forall (l1 l2:bag) (n:nat),
  count n l1 + count n l2 = count n (sum l1 l2).
Proof.
  intros l1 l2 n.
  induction l1 as [| hd1 tl1].
  Case "l1 = []".
      simpl. reflexivity.
  Case "l1 = hd1::tl1".
      simpl. destruct (beq_nat hd1 n).
      SCase "beq_nat hd1 n = true".
          simpl. rewrite -> IHtl1. reflexivity.
      SCase "beq_nat hd1 n = false".
          rewrite -> IHtl1. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 4 stars, optional (rev_injective) *)
(** Prove that the [rev] function is injective, that is,

[[
    forall X (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.
]]

There is a hard way and an easy way to solve this exercise.
*)

Theorem rev_injective : forall (l1 l2:natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive. rewrite <- H. rewrite -> rev_involutive.
  reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** * Options *)

(** Here is another type definition that is often useful in
    day-to-day programming: *)

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

(** One use of [natoption] is as a way of returning "error
    codes" from functions.  For example, suppose we want to write a
    function that returns the [n]th element of some list.  If we give
    it type [nat -> natlist -> nat], then we'll have to return some
    number when the list is too short! *)

Fixpoint index_bad (n:nat) (l:natlist) : nat :=
  match l with
  | nil => 42  (* arbitrary! *)
  | a :: l' => match beq_nat n O with
               | true => a
               | false => index_bad (pred n) l'
               end
  end.

(** On the other hand, if we give it type [nat -> natlist ->
    natoption], then we can return [None] when the list is too short
    and [Some a] when the list has enough members and [a] appears at
    position [n]. *)

Fixpoint index (n:nat) (l:natlist) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => index (pred n) l'
               end
  end.

Example test_index1 :    index 0 [4,5,6,7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index 3 [4,5,6,7]  = Some 7.
Proof. reflexivity.  Qed.
Example test_index3 :    index 10 [4,5,6,7] = None.
Proof. reflexivity.  Qed.

(** This example is also an opportunity to introduce one more
    small feature of Coq's programming language: conditional
    expressions... *)

Fixpoint index' (n:nat) (l:natlist) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

(** Coq's conditionals are exactly like those found in any other
    language, with one small generalization.  Since the boolean type
    is not built in, Coq actually allows conditional expressions over
    _any_ inductively defined type with exactly two constructors.  The
    guard is considered true if it evaluates to the first constructor
    in the [Inductive] definition and false if it evaluates to the
    second. *)

(** The function below pulls the [nat] out of a [natoption], returning
    a supplied default in the [None] case. *)

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

(** **** Exercise: 2 stars (hd_opt) *)
(** Using the same idea, fix the [hd] function from earlier so we don't
   have to pass a default element for the [nil] case.  *)

Definition hd_opt (l : natlist) : natoption :=
  match l with
    |nil => None
    |lhd::ltl => Some lhd
  end.

Example test_hd_opt1 : hd_opt [] = None.
Proof. reflexivity. Qed.

Example test_hd_opt2 : hd_opt [1] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_opt3 : hd_opt [5,6] = Some 5.
Proof. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (option_elim_hd) *)
(** This exercise relates your new [hd_opt] to the old [hd]. *)

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_opt l).
Proof.
  intros l default.
  destruct l as [| head tail].
  Case "l = []".
      simpl. reflexivity.
  Case "l = head::tail".
      simpl. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, recommended (beq_natlist) *)
(** Fill in the definition of [beq_natlist], which compares
    lists of numbers for equality.  Prove that [beq_natlist l l]
    yields [true] for every list [l]. *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l2 with
    |nil, nil => true
    |hd1::tl1, hd2::tl2 => if beq_nat hd1 hd2
                           then beq_natlist tl1 tl2
                           else false
    |_,_ => false
  end.

Example test_beq_natlist1 :   (beq_natlist nil nil = true).
Proof. reflexivity. Qed.
Example test_beq_natlist2 :   beq_natlist [1,2,3] [1,2,3] = true.
Proof. reflexivity. Qed.
Example test_beq_natlist3 :   beq_natlist [1,2,3] [1,2,4] = false.
Proof. reflexivity. Qed.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros l.
  induction l as [| lhd ltl].
  Case "l = []".
      simpl. reflexivity.
  Case "l = lhd::ltl".
      simpl. rewrite <- IHltl. rewrite <- beq_nat_refl. reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** * Extended Exercise: Dictionaries *)

(** As a final illustration of how fundamental data structures
    can be defined in Coq, here is the declaration of a simple
    [dictionary] data type, using numbers for both the keys and the
    values stored under these keys.  (That is, a dictionary represents
    a finite map from numbers to numbers.) *)

Module Dictionary.

Inductive dictionary : Type :=
  | empty  : dictionary
  | record : nat -> nat -> dictionary -> dictionary.

(** This declaration can be read: "There are two ways to construct a
    [dictionary]: either using the constructor [empty] to represent an
    empty dictionary, or by applying the constructor [record] to
    a key, a value, and an existing [dictionary] to construct a
    [dictionary] with an additional key to value mapping." *)

Definition insert (key value : nat) (d : dictionary) : dictionary :=
  (record key value d).

(** Here is a function [find] that searches a [dictionary] for a
    given key.  It evaluates evaluates to [None] if the key was not
    found and [Some val] if the key was mapped to [val] in the
    dictionary. If the same key is mapped to multiple values, [find]
    will return the first one it finds. *)

Fixpoint find (key : nat) (d : dictionary) : natoption :=
  match d with
  | empty         => None
  | record k v d' => if (beq_nat key k) then (Some v) else (find key d')
  end.

(** **** Exercise: 1 star (dictionary_invariant1) *)
(** Complete the following proof. *)
Theorem dictionary_invariant1 : forall (d : dictionary) (k v: nat),
  (find k (insert k v d)) = Some v.
Proof.
  intros d k v.
  simpl. rewrite <- beq_nat_refl. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star (dictionary_invariant2) *)
(** Complete the following proof. *)
Theorem dictionary_invariant2 : forall (d : dictionary) (m n o: nat),
  (beq_nat m n) = false -> (find m d) = (find m (insert n o d)).
Proof.
  intros d m n o.
  intros H.
  simpl. rewrite -> H. reflexivity.
Qed.
(** [] *)

End Dictionary.

End NatList.