Require Export Basics.

Module NatList.

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

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.

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

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

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.

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

Theorem surjective_pairing_stuck :
  forall (p : natprod), p = (fst p, snd p).
Proof.
  simpl. Admitted.

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

(* 練習問題: ★ (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 (n, m). simpl. reflexivity. Qed.
(* ☐ *)

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

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

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

Definition l_123' := 1 :: (2 :: (3 :: nil)).
Definition l_123'0 := 1 :: (2 :: (3 :: [ ])).
Definition l_123'' := 1 :: 2 :: 3 :: nil.
Definition l_123''' := [1,2,3].

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

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

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

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.

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.

(*
練習問題: ★★, recommended (list_funs)

以下の nonzeros、 oddmembers、 countoddmembers の定義を完成させなさい。
 *)

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
    | O :: xs => nonzeros xs
    | x :: xs => x :: nonzeros xs
    | [ ]     => []
  end.

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

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
    | x :: xs =>
        match oddb x with
          | true  => x :: oddmembers xs
          | false => oddmembers xs
        end
    | [ ]     => [ ]
  end.

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

Fixpoint countoddmembers (l:natlist) : nat :=
  match l with
    | x :: xs =>
        match oddb x with
          | true  => S (countoddmembers xs)
          | false => countoddmembers xs
        end
    | [ ]     => O
  end.

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.

(* ☐ *)

(*
練習問題: ★★ (alternate)

alternate の定義を完成させなさい。この関数は、ふたつのリストから交互に要素を取り
出しひとつに「綴じ合わせる」関数です。具体的な例は下のテストを見てください。

注意: alternate の自然な定義のひとつは、「Fixpoint による定義は『明らかに停止する
』ものでなければならない」という Coq の要求を満たすことができません。このパターン
にはまってしまったようであれば、両方のリストの要素を同時に見ていくような少し冗長
な方法を探してみてください。
 *)

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
    | x :: xs, y :: ys => x :: y :: alternate xs ys
    | x :: xs, [ ]     => l1
    | [ ],     _       => l2
  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.

(* ☐ *)

Definition bag := natlist.

(*
練習問題: ★★★ (bag_functions)

バッグに対する count、 sum、 add、 member 関数の定義を完成させなさい。
 *)

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
    | [ ] => 0
    | x :: xs =>
        match (beq_nat x v) with
          | true  => 1 + count v xs
          | false => count v xs
        end
  end.

(* 下の証明はすべて 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.

(*
多重集合の sum （直和。または非交和）は集合の union （和）と同じようなものです。
sum a b は a と b の両方の要素を持つ多重集合です。（数学者は通常、多重集合の
union にもう少し異なる定義を与えます。それが、この関数の名前を union にしなかった
理由です。） sum のヘッダには引数の名前を与えませんでした。さらに、 Fixpoint では
なく Definition を使っています。ですから、引数に名前がついていたとしても再帰的な
処理はできません。問題をこのように設定したのは、 sum を（定義済みの関数を使うとい
った）別の方法で定義できないか考えさせるためです。
 *)

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 := 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 :=
  ble_nat 1 (count v s).

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

(*
練習問題: ★★★, optional (bag_more_functions)

練習として、さらにいくつかの関数を作成してください。
 *)

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
    | [ ] => [ ]
    | x :: xs =>
        match (beq_nat x v) with
          | true  => xs
          | false => x :: remove_one v xs
        end
  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
    | [ ] => [ ]
    | x :: xs =>
        match (beq_nat x v) with
          | true  => remove_all v xs
          | false => x :: remove_all v xs
        end
  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
    | [ ] => true
    | e :: es =>
        match member e s2 with
          | true  => subset es (remove_one e s2)
          | false => false
        end
  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.
(* ☐ *)

(*
練習問題: ★★★, recommended (bag_theorem)

count や add を使ったバッグに関する面白い定理書き、それを証明しなさい。この問題は
いわゆる自由課題で、真になることがわかっていても、証明にはまだ習っていない技を使
わなければならない定理を思いついてしまうこともあります。証明に行き詰まってしまっ
たら気軽に質問してください。
 *)

Theorem count_add_bag :
  forall (v : nat) (s : bag), count v (add v s) = 1 + count v s.
Proof.
  intros v s. simpl. rewrite <- beq_nat_refl. reflexivity. Qed.

Theorem count_sum_bag :
  forall (v : nat) (xs ys : bag), count v (sum xs ys) = count v xs + count v ys.
Proof.
  intros v xs ys. induction xs as [| x xs'].
  Case "xs = [ ]". reflexivity.
  Case "xs = x :: xs'".
    simpl. rewrite -> IHxs'. destruct (beq_nat x v).
    reflexivity. reflexivity. Qed.

(* ☐ *)

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

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.

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.

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

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

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.

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'".
    simpl. Admitted.

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.

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 n l'".
    simpl. rewrite -> length_snoc.
    rewrite -> IHl'. reflexivity. Qed.

(*
リストについての練習問題 (1)

練習問題: ★★★, recommended (list_exercises)

リストについてさらに練習しましょう。
 *)

Theorem app_nil_end :
  forall l : natlist, l ++ [] = l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil". reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHl'. reflexivity. Qed.

Lemma rev_snoc :
  forall (l : natlist) (n : nat), rev (snoc l n) = n :: rev l.
Proof.
  intros l n. induction l as [| m l'].
  Case "l = nil". reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHl'.
    simpl. reflexivity. Qed.

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

Lemma app_snoc :
  forall (l1 l2 : natlist) (n : nat), snoc (l1 ++ l2) n = l1 ++ snoc l2 n.
Proof.
  intros l1 l2 n. induction l1 as [| m l1'].
  Case "l1 = nil". reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> IHl1'. reflexivity. Qed.

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

(*
次の問題には簡単な解法があります。こんがらがってしまったようであれば、少し戻って
単純な方法を探してみましょう。
 *)

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 [| m l'].
  Case "l = nil". reflexivity.
  Case "l = cons m l'".
    simpl. rewrite -> IHl'. reflexivity. Qed.

(* 前に書いた nonzeros 関数に関する練習問題です。 *)

Lemma nonzeros_length : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2. induction l1 as [| n l1'].
  Case "l1 = nil". reflexivity.
  Case "l1 = cons n l1'".
    simpl. rewrite -> IHl1'. destruct n.
    reflexivity. reflexivity. Qed.
(* ☐ *)

(*
リストについての練習問題 (2)

練習問題: ★★, recommended (list_design)

自分で問題を考えましょう。

 ・ cons （::）、 snoc、 append （++）に関する、自明でない定理を考えて書きなさい
    。
 ・ それを証明しなさい。
 *)

Lemma snoc_cons_app :
  forall (l1 l2 : natlist) (n:nat), (snoc l1 n) ++ l2 = l1 ++ n :: l2.
Proof.
  intros l1 l2 n. rewrite -> snoc_append. rewrite -> app_ass.
  simpl. reflexivity. Qed.
(* ☐ *)

(*
練習問題: ★★, optional (bag_proofs)

前のバッグについての optional な練習問題に挑戦したのであれば、その定義について、
以下の定理を証明しなさい。
 *)

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

(* 以下の ble_nat に関する補題は、この次の証明に使えるかもしれません。 *)

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 [| n s'].
  Case "s = nil". reflexivity.
  Case "s = cons n s'".
    simpl. destruct (beq_nat n 0) as [] eqn: H.
    SCase "beq_nat n 0 = true".
      rewrite -> ble_n_Sn. reflexivity.
    SCase "beq_nat n 0 = false".
      simpl. rewrite -> H. rewrite -> IHs'. reflexivity.
Qed.

(* ☐ *)

(*
練習問題: ★★★★, optional (rev_injective)

rev 関数が単射である、すなわち
    forall X (l1 l2 : list X), rev l1 = rev l2 -> l1 = l2

であることを証明しなさい。

この練習問題には簡単な解法と難しい解法があります。
 *)

Module PlayGroundRevInjective.

Require Import List.

Lemma rev_snoc :
  forall X (l : list X) (x : X), rev (l ++ x :: nil) = x :: rev l.
Proof.
  intros X l x. induction l as [| x' l'].
  Case "l = nil". reflexivity.
  Case "l = x' :: l'".
    simpl. rewrite -> IHl'. reflexivity. Qed.

Lemma rev_involutive' :
  forall X (l : list X), rev (rev l) = l.
Proof.
  intros X l. induction l as [| x l'].
  Case "l = nil". reflexivity.
  Case "l = cons x l'".
    simpl. rewrite -> rev_snoc. rewrite -> IHl'. reflexivity. Qed.

Theorem rev_injective :
  forall X (l1 l2 : list X), rev l1 = rev l2 -> l1 = l2.
Proof.
  intros X l1 l2 H.
  rewrite <- rev_involutive'.
  rewrite <- H.
  rewrite -> rev_involutive'.
  reflexivity.
Qed.

(* ☐ *)
End PlayGroundRevInjective.

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

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

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.

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.

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

(*
練習問題: ★★ (hd_opt)

同じ考え方を使って、以前定義した hd 関数を修正し、 nil の場合に返す値を渡
さなくて済むようにしなさい。
 *)

Definition hd_opt (l : natlist) : natoption :=
  match l with
    | x :: xs => Some x
    | [ ]     => None
  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.
(* ☐ *)

(*
練習問題: ★★, optional (option_elim_hd)

新しい hd_opt と古い hd の関係についての練習問題です。
 *)

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim (hd_opt l) default.
Proof.
  intros l default. destruct l as [| x xs].
  Case "l = nil". reflexivity.
  Case "l = case x xs". reflexivity. Qed.
(* ☐ *)

(*
練習問題: ★★, recommended (beq_natlist)

数のリストふたつを比較し等価性を判定する関数 beq_natlist の定義を完成させ
なさい。そして、 beq_natlist l l が任意のリスト l で true となることを証
明しなさい。
 *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l2 with
    | x1 :: l1', x2 :: l2' =>
        match beq_nat x1 x2 with
          | true  => beq_natlist l1' l2'
          | false => false
        end
    | [ ], [ ]             => true
    | _ :: _ , [ ]         => 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 [|n l'].
  Case "l = nil". reflexivity.
  Case "l = cons n l'".
    simpl. rewrite <- beq_nat_refl. rewrite <- IHl'.
    reflexivity. Qed.
(* ☐ *)

Theorem silly1 :
  forall (n m o p : nat),
    n = m ->
    [n,o] = [n,p] ->
    [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  apply eq2. Qed.

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

(*
Theorem silly2' :
  forall (n m o p : nat),
    n = m ->
    (forall (q r : nat), q = r -> [q,o] = [r,p]) ->
    [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
Admitted.
 *)

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

(*
練習問題: ★★, optional (silly_ex)

次の証明を simpl を使わずに完成させなさい。
 *)

Theorem silly_ex :
  (forall n, evenb n = true -> oddb (S n) = true) ->
  evenb 3 = true ->
  oddb 4 = true.
Proof.
  intros H0 H1. apply H0. apply H1. Qed.
(* ☐ *)

Theorem silly3_firsttry :
  forall (n : nat),
    true = beq_nat n 5 ->
    beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  simpl.
Admitted.

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

(* 練習問題: ★★★, recommended (apply_exercise1) *)

Theorem rev_exercise1 :
  forall (l l' : natlist),
    l = rev l' ->
    l' = rev l.
Proof.
  intros l l' H. rewrite -> H. symmetry. apply rev_involutive. Qed.
(* ☐ *)

(*
練習問題: ★ (apply_rewrite)

apply と rewrite の違いを簡単に説明しなさい。どちらもうまく使えるような場
面はありますか？
 *)

(*
結果の型が一致しているときに使えるのが apply。
equalityが示せているときに使えるのが rewrite。
結果の型がequalityであるときにはどちらも使える場合がある。
 *)
(* ☐ *)

(*
練習問題: ★★, optional (app_ass')

++ の結合則をより一般的な仮定のもとで証明しなさい。（最初の行を変更せずに
）次の証明を完成させること。
 *)

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

(*
練習問題: ★★★ (apply_exercise2)

induction の前に m を intros していないことに注意してください。これによっ
て仮定が一般化され、帰納法の仮定が特定の m に縛られることがなくなり、より
使いやすくなりました。
 *)

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

(*
練習問題: ★★★, recommended (beq_nat_sym_informal)

以下の補題について上の証明と対応する非形式的な証明を書きなさい。

定理: 任意の nat n m について、 beq_nat n m = beq_nat m n。
 *)

(*
証明: n についての帰納法を適用する。
   □ まず n = 0 と置くと以下のようになる
        forall m, beq_nat 0 m = beq_nat m 0
        m = 0 のとき
          beq_nat 0 0 = beq_nat 0 0 で成り立つ
        m = S m' のとき
          beq_nat の定義から、
          beq_nat 0 (S m') = false = beq_nat (S m') 0
          で成り立つ
   □ 次に n = S n' と置き、帰納法の仮定を
        forall m, beq_nat n' m = beq_nat m n'
        とすると、

        m = 0 のとき
          beq_nat (S n') 0 = false = beq_nat 0 (S n')
          で成り立つ
        m = S m' のとき、forall m に注意すると帰納法の仮定から
          beq_nat n' m' = beq_nat m' n'
        も成り立つ。
        これを beq_nat の定義から逆変換すると
          beq_nat (S n') (S m') = beq_nat (S m') (S n')

        これは n = S n ' についても帰納法の仮定が成り立つことを示している ☐
 *)

End NatList.

(* 練習問題: 辞書 *)

Module Dictionary.

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

(*
この宣言は次のように読めます。「dictionary を構成する方法はふたつある。構
成子 empty で空の辞書を表現するか、構成子 record をキーと値と既存の
dictionary に適用してキーと値の対応を追加した dictionary を構成するかのい
ずれかである」。
 *)

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

Eval simpl in insert 0 1 empty.
Eval simpl in record 0 1 empty.

(*
下の find 関数は、 dictionary から与えられたキーに対応する値を探し出すも
のです。キーが見つからなかった場合には None に評価され、キーが val に結び
付けられていた場合には Some val に評価されます。同じキーが複数の値に結び
付けられている場合には、最初に見つかったほうの値を返します。
 *)

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

(* 練習問題: ★ (dictionary_invariant1) *)

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

(* 練習問題: ★ (dictionary_invariant2) *)

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 H. simpl. rewrite -> H. reflexivity. Qed.
(* ☐ *)

End Dictionary.

Definition beq_nat_sym := NatList.beq_nat_sym.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** * Shared libraries *)

(** ** Finitary sums and products over monoids *)

Require Import List Arith Omega Eqdep_dec ZArith.

Require Import utils_tac utils_list binomial.

Set Implicit Arguments.

Record monoid_theory (X : Type) (m : X -> X -> X) (u : X) := mk_monoid {
  monoid_unit_l : forall x, m u x = x;
  monoid_unit_r : forall x, m x u = x;
  monoid_assoc  : forall x y z, m x (m y z) = m (m x y) z;
}.

Fact Nat_plus_monoid : monoid_theory plus 0.
Proof. exists; intros; ring. Qed.

Fact Nat_mult_monoid : monoid_theory mult 1.
Proof. exists; intros; ring. Qed.

Fact Zplus_monoid : monoid_theory Zplus 0%Z.
Proof. exists; intros; ring. Qed.

Fact Zmult_monoid : monoid_theory Zmult 1%Z.
Proof. exists; intros; ring. Qed.

Hint Resolve Nat_plus_monoid Nat_mult_monoid
             Zplus_monoid Zmult_monoid.

Section msum.

  Variable (X : Type) (m : X -> X -> X) (u : X).

  Infix "⊕" := m (at level 50, left associativity).

  Fixpoint msum n f :=
    match n with
      | 0   => u
      | S n => f 0 ⊕ msum n (fun n => f (S n))
    end.

  Notation "∑" := msum.

  Fact msum_fold_map n f : ∑ n f = fold_right m u (map f (list_an 0 n)).
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; f_equal; auto.
    rewrite IHn, <-  map_S_list_an, map_map; auto.
  Qed.

  Fact msum_0 f : ∑ 0 f = u.
  Proof. auto. Qed.

  Fact msum_S n f : ∑ (S n) f = f 0 ⊕ ∑ n (fun n => f (S n)).
  Proof. auto. Qed.

  Hypothesis Hmonoid : monoid_theory m u.

  Fact msum_1 f : ∑ 1 f = f 0.
  Proof.
    destruct Hmonoid as [ H1 H2 ].
    rewrite msum_S, msum_0, H2; auto.
  Qed.

  Fact msum_plus a b f : ∑ (a+b) f = ∑ a f ⊕ ∑ b (fun i => f (a+i)).
  Proof.
    destruct Hmonoid as [ H1 _ H3 ].
    revert f; induction a as [ | a IHa ]; intros f; simpl; auto.
    rewrite <- H3; f_equal; apply IHa.
  Qed.

  Fact msum_plus1 n f : ∑ (S n) f = ∑ n f ⊕ f n.
  Proof.
    destruct Hmonoid as [ _ H2 _ ].
    replace (S n) with (n+1) by omega.
    rewrite msum_plus; simpl; f_equal.
    rewrite H2; f_equal; omega.
  Qed.

  Fact msum_ext n f g : (forall i, i < n -> f i = g i) -> ∑ n f = ∑ n g.
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g Hfg; simpl; f_equal; auto.
    + apply Hfg; omega.
    + apply IHn; intros; apply Hfg; omega.
  Qed.

  Fact msum_unit n : ∑ n (fun _ => u) = u.
  Proof.
    destruct Hmonoid as [ H1 _ _ ].
    induction n as [ | n IHn ]; simpl; auto.
    rewrite IHn; auto.
  Qed.

  Fact msum_comm a n f : (forall i, i < n -> f i ⊕ a = a ⊕ f i) -> ∑ n f ⊕ a = a ⊕ ∑ n f.
  Proof.
    destruct Hmonoid as [ H1 H2 H3 ].
    revert f; induction n as [ | n IHn ]; intros f H; simpl; auto.
    + rewrite H1, H2; auto.
    + rewrite H3, <- H; try omega.
      repeat rewrite <- H3; f_equal.
      apply IHn.
      intros; apply H; omega.
  Qed.

  Fact msum_sum n f g : (forall i j, i < j < n -> f j ⊕ g i = g i ⊕ f j) -> ∑ n (fun i => f i ⊕ g i) = ∑ n f ⊕ ∑ n g.
  Proof.
    destruct Hmonoid as [ H1 H2 H3 ].
    revert f g; induction n as [ | n IHn ]; intros f g H; simpl; auto.
    rewrite IHn.
    + repeat rewrite <- H3; f_equal.
      repeat rewrite H3; f_equal.
      symmetry; apply msum_comm.
      intros; apply H; omega.
    + intros; apply H; omega.
  Qed.

  Fact msum_of_unit n f : (forall i, i < n -> f i = u) -> ∑ n f = u.
  Proof.
    intros H.
    rewrite <- (msum_unit n).
    apply msum_ext; auto.
  Qed.

  Fact msum_only_one n f i : i < n
                          -> (forall j, j < n -> i <> j -> f j = u)
                          -> ∑ n f = f i.
  Proof.
    destruct Hmonoid as [ M1 M2 M3 ].
    intros H1 H2.
    replace n with (i + 1 + (n-i-1)) by omega.
    do 2 rewrite msum_plus.
    rewrite msum_of_unit, msum_1, msum_of_unit, M1, M2.
    + f_equal; omega.
    + intros j Hj; destruct (H2 (i+1+j)); auto; omega.
    + intros j Hj; destruct (H2 j); auto; omega.
  Qed.

  Fact msum_msum n k f :
          (forall i1 j1 i2 j2, i1 < n -> j1 < k -> i2 < n -> j2 < k -> f i1 j1 ⊕ f i2 j2 = f i2 j2 ⊕ f i1 j1)
       -> ∑ n (fun i => ∑ k (f i)) = ∑ k (fun j => ∑ n (fun i => f i j)).
  Proof.
    revert k f; induction n as [ | n IHn ]; intros k f Hf.
    + rewrite msum_0, msum_of_unit; auto.
    + rewrite msum_S, IHn.
      * rewrite <- msum_sum.
        - apply msum_ext.
          intros; rewrite msum_S; trivial.
        - intros; symmetry; apply msum_comm.
          intros; apply Hf; omega.
      * intros; apply Hf; omega.
  Qed.

  Fact msum_ends n f : (forall i, 0 < i <= n -> f i = u) -> ∑ (n+2) f = f 0 ⊕ f (S n).
  Proof.
    destruct Hmonoid as [ H1 H2 H3 ].
    intros H.
    replace (n+2) with (1 + n + 1) by omega.
    do 2 rewrite msum_plus; simpl.
    rewrite msum_of_unit.
    + rewrite H2, H2, H2; do 2 f_equal; omega.
    + intros; apply H; omega.
  Qed.

  Fact msum_first_two n f : 2 <= n -> (forall i, 2 <= i -> f i = u) -> ∑ n f = f 0 ⊕ f 1.
  Proof.
    destruct Hmonoid as [ _ M2 _ ].
    intros Hn H1.
    destruct n as [ | [ | n ] ]; try omega.
    do 2 rewrite msum_S.
    rewrite msum_of_unit.
    + rewrite M2; trivial.
    + intros; apply H1; omega.
  Qed.

  Definition mscal n x := msum n (fun _ => x).

  Fact mscal_0 x : mscal 0 x = u.
  Proof. apply msum_0. Qed.

  Fact mscal_S n x : mscal (S n) x = x ⊕ mscal n x.
  Proof. apply msum_S. Qed.

  Fact mscal_1 x : mscal 1 x = x.
  Proof.
    destruct Hmonoid as [ _ H2 _ ].
    rewrite mscal_S, mscal_0, H2; trivial.
  Qed.

  Fact mscal_of_unit n : mscal n u = u.
  Proof. apply msum_of_unit; auto. Qed.

  Fact mscal_plus a b x : mscal (a+b) x = mscal a x ⊕ mscal b x.
  Proof. apply msum_plus. Qed.

  Fact mscal_plus1 n x : mscal (S n) x = mscal n x ⊕ x.
  Proof. apply msum_plus1. Qed.

  Fact mscal_comm n x y : x ⊕ y = y ⊕ x -> mscal n x ⊕ y = y ⊕ mscal n x.
  Proof. intros H; apply msum_comm; auto. Qed.

  Fact mscal_sum n x y : x ⊕ y = y ⊕ x -> mscal n (x ⊕ y) = mscal n x ⊕ mscal n y.
  Proof. intro; apply msum_sum; auto. Qed.

  Fact mscal_mult a b x : mscal (a*b) x = mscal a (mscal b x).
  Proof.
    induction a as [ | a IHa ]; simpl.
    + do 2 rewrite mscal_0; auto.
    + rewrite mscal_plus, IHa, mscal_S; auto.
  Qed.

  Fact msum_mscal n k f : (forall i j, i < n -> j < n -> f i ⊕ f j = f j ⊕ f i)
                       -> ∑ n (fun i => mscal k (f i)) = mscal k (∑ n f).
  Proof. intros H; apply msum_msum; auto. Qed.

End msum.

Section msum_morphism.

  Variable (X Y : Type) (m1 : X -> X -> X) (u1 : X)
                        (m2 : Y -> Y -> Y) (u2 : Y)
           (H1 : monoid_theory m1 u1)
           (H2 : monoid_theory m2 u2)
           (phi : X -> Y)
           (Hphi1 : phi u1 = u2)
           (Hphi2 : forall x y, phi (m1 x y) = m2 (phi x) (phi y)).

  Fact msum_morph n f : phi (msum m1 u1 n f) = msum m2 u2 n (fun x => phi (f x)).
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; auto.
    rewrite Hphi2, IHn; trivial.
  Qed.

  Fact mscal_morph n x : phi (mscal m1 u1 n x) = mscal m2 u2 n (phi x).
  Proof. apply msum_morph. Qed.

End msum_morphism.

Section binomial_Newton.

  Variable (X : Type) (sum times : X -> X -> X) (zero one : X).

  Infix "⊕" := sum (at level 50, left associativity).
  Infix "⊗" := times (at level 40, left associativity).

  Notation z := zero.
  Notation o := one.

  Notation scal := (mscal sum zero).
  Notation expo := (mscal times one).

  Hypothesis (M_sum : monoid_theory sum zero)
             (sum_comm : forall x y, x ⊕ y = y ⊕ x)
             (sum_cancel : forall x u v, x ⊕ u = x ⊕ v -> u = v)
             (M_times : monoid_theory times one)
             (distr_l : forall x y z, x ⊗ (y⊕z) = x⊗y ⊕ x⊗z)
             (distr_r : forall x y z, (y⊕z) ⊗ x = y⊗x ⊕ z⊗x).

  Fact times_zero_l x : z ⊗ x = z.
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    apply sum_cancel with (z⊗x).
    rewrite S2, <- distr_r, S1; trivial.
  Qed.

  Fact times_zero_r x : x ⊗ z = z.
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    apply sum_cancel with (x⊗z).
    rewrite S2, <- distr_l, S1; trivial.
  Qed.

  Notation "∑" := (msum sum zero).

  Fact sum_0n_scal n k f : ∑ n (fun i => scal k (f i)) = scal k (∑ n f).
  Proof. apply msum_mscal; auto. Qed.

  Fact scal_times k x y : scal k (x⊗y) = x⊗scal k y.
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    induction k as [ | k IHk ].
    + rewrite mscal_0, mscal_0, times_zero_r; auto.
    + rewrite mscal_S, mscal_S, IHk, distr_l; auto.
  Qed.

  Fact scal_one_comm k x : scal k o ⊗ x = x ⊗ scal k o.
  Proof.
    destruct M_times as [ T1 T2 T3 ].
    induction k as [ | k IHk ].
    + rewrite mscal_0, times_zero_l, times_zero_r; auto.
    + rewrite mscal_S, distr_l, distr_r; f_equal; auto.
      rewrite T1, T2; auto.
  Qed.

  Corollary scal_one k x : scal k x = scal k o ⊗ x.
  Proof.
    destruct M_times as [ T1 T2 T3 ].
    rewrite <- (T2 x) at 1.
    rewrite scal_times.
    symmetry; apply scal_one_comm.
  Qed.

  Fact sum_0n_distr_l b n f : ∑ n (fun i => b⊗f i) = b⊗∑ n f.
  Proof.
    revert f; induction n as [ | n IHn ]; intros f.
    + do 2 rewrite msum_0; rewrite times_zero_r; auto.
    + do 2 rewrite msum_S; rewrite IHn, distr_l; auto.
  Qed.

  Fact sum_0n_distr_r b n f : ∑ n (fun i => f i⊗b) = ∑ n f ⊗ b.
  Proof.
    revert f; induction n as [ | n IHn ]; intros f.
    + do 2 rewrite msum_0; rewrite times_zero_l; auto.
    + do 2 rewrite msum_S; rewrite IHn, distr_r; auto.
  Qed.

  (**   Newton Binomial theorem for (X,⊕,z,⊗,o) where
          1) (X,⊕,z) is a cancellative commutative monoid
          2) (X,⊗,o) is a monoid
          3) ⊗ distributes over ⊕ on the left and one the right

        cancellative could be weakened into z is left and right
        absorbing for ⊗, ie a⊗z = z⊗a = z

   *)

  Theorem binomial_Newton n a b :
        a ⊗ b = b ⊗ a
     -> expo n (a ⊕ b) = ∑ (S n) (fun i => scal (binomial n i) (expo (n - i) a ⊗ expo i b)).
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    intros Hab; induction n as [ | n IHn ].
    + rewrite mscal_0, msum_S, msum_0; simpl.
      rewrite mscal_0, mscal_0, mscal_1; auto.
      rewrite S2, T1; auto.
    + rewrite msum_S with (n := S n), binomial_n0, mscal_1; auto.
      rewrite mscal_0, Nat.sub_0_r; auto.
      rewrite T2.
      rewrite msum_ext with (g := fun i => b ⊗ scal (binomial n i) (expo (n-i) a ⊗ expo i b)
                                         ⊕ a ⊗ scal (binomial n (S i)) (expo (n-S i) a ⊗ expo (S i) b)).
      2: { intros; rewrite binomial_SS, mscal_plus; auto.
           replace (S n - S i) with (n-i) by omega; f_equal.
           * rewrite mscal_S.
             do 3 rewrite scal_times.
             do 2 rewrite T3; f_equal.
             apply mscal_comm; auto.
           * destruct (le_lt_dec n i).
             + rewrite binomial_gt; try omega.
               do 2 rewrite mscal_0.
               rewrite times_zero_r; auto.
             + replace (n - i) with (S (n - S i)) by omega.
               rewrite mscal_S.
               repeat rewrite scal_times.
               repeat rewrite T3; auto. }
      rewrite msum_sum; auto.
      do 2 rewrite sum_0n_distr_l.
      rewrite <- IHn.
      rewrite msum_plus1, binomial_gt; auto.
      rewrite mscal_0, S2.
      generalize (msum_S sum z n (fun i => scal (binomial n i) (expo (n-i) a ⊗ expo i b))); intros H.
      rewrite Nat.sub_0_r, binomial_n0, mscal_1, mscal_0, T2 in H; auto.
      rewrite S3, (sum_comm (expo _ _)), <- S3.
      rewrite mscal_S with (x :=a), <- distr_l, <- H, <- IHn.
      rewrite mscal_S, distr_r.
      apply sum_comm.
  Qed.

End binomial_Newton.

Section Newton_nat.

  Notation power := (mscal mult 1).
  Notation "∑" := (msum plus 0).

  Fact sum_fold_map n f : ∑ n f = fold_right plus 0 (map f (list_an 0 n)).
  Proof. apply msum_fold_map. Qed.

  Fact power_0 x : power 0 x = 1.
  Proof. apply mscal_0. Qed.

  Fact power_S n x : power (S n) x = x * power n x.
  Proof. apply mscal_S. Qed.

  Fact power_1 x : power 1 x = x.
  Proof. apply mscal_1, Nat_mult_monoid. Qed.

  Fact power_of_0 n : 0 < n -> power n 0 = 0.
  Proof. destruct n; try omega; rewrite power_S; auto. Qed.

  Fact power_of_1 n : power n 1 = 1.
  Proof. rewrite mscal_of_unit; auto. Qed.

  Fact power_plus p a b : power (a+b) p = power a p * power b p.
  Proof. apply mscal_plus, Nat_mult_monoid. Qed.

  Fact power_mult p a b : power (a*b) p = power a (power b p).
  Proof. apply mscal_mult; auto. Qed.

  Fact power_ge_1 k p : p <> 0 -> 1 <= power k p.
  Proof.
    intros Hp.
    induction k as [ | k IHk ].
    + rewrite power_0; auto.
    + rewrite power_S.
      apply (mult_le_compat 1 _ 1); omega.
  Qed.

  Fact power2_gt_0 n : 0 < power n 2.
  Proof. apply power_ge_1; discriminate. Qed.

  Fact power_sinc k p : 2 <= p -> power k p < power (S k) p.
  Proof.
    intros Hp; rewrite power_S.
    rewrite <- (Nat.mul_1_l (power k p)) at 1.
    apply mult_lt_compat_r; try omega.
    apply power_ge_1; omega.
  Qed.

  Fact power_ge_n k p : 2 <= p -> k <= power k p.
  Proof.
    intros Hp.
    induction k as [ | k IHk ].
    + rewrite power_0; auto.
    + apply le_lt_trans with (2 := power_sinc _ Hp); auto.
  Qed.

  Fact power_mono_l p q x : 1 <= x -> p <= q -> power p x <= power q x.
  Proof.
    intros Hx.
    induction 1 as [ | q H IH ]; auto.
    apply le_trans with (1 := IH).
    rewrite power_S.
    rewrite <- (Nat.mul_1_l (power _ _)) at 1.
    apply mult_le_compat; auto.
  Qed.

  Definition power_mono := power_mono_l.

  Fact power_smono_l p q x : 2 <= x -> p < q -> power p x < power q x.
  Proof.
    intros H1 H2.
    apply lt_le_trans with (1 := power_sinc _ H1).
    apply power_mono_l; omega.
  Qed.

  Fact power_mono_r n p q : p <= q -> power n p <= power n q.
  Proof.
    intros H.
    induction n as [ | n IHn ].
    + do 2 rewrite power_0; auto.
    + do 2 rewrite power_S; apply mult_le_compat; auto.
  Qed.

  Fact power_0_inv p n : power p n = 0 <-> n = 0 /\ 0 < p.
  Proof.
    induction p as [ | p IHp ].
    + rewrite power_0; omega.
    + rewrite power_S; split.
      * intros H.
        apply mult_is_O in H.
        rewrite IHp in H; omega.
      * intros (?&?); subst; simpl; auto.
  Qed.

  Fact plus_cancel_l : forall a b c, a + b = a + c -> b = c.
  Proof. intros; omega. Qed.

  Let plus_cancel_l':= plus_cancel_l.

  Fact sum_0n_scal_l n k f : ∑ n (fun i => k*f i) = k*∑ n f.
  Proof.
    apply sum_0n_distr_l with (3 := Nat_mult_monoid); auto.
    intros; ring.
  Qed.

  Fact sum_0n_scal_r n k f : ∑ n (fun i => (f i)*k) = (∑ n f)*k.
  Proof.
    apply sum_0n_distr_r with (3 := Nat_mult_monoid); auto.
    intros; ring.
  Qed.

  Fact sum_0n_mono n f g : (forall i, i < n -> f i <= g i) -> ∑ n f <= ∑ n g.
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g H.
    + do 2 rewrite msum_0; auto.
    + do 2 rewrite msum_S; apply plus_le_compat.
      * apply H; omega.
      * apply IHn; intros; apply H; omega.
  Qed.

  Fact sum_0n_le_one n f i : i < n -> f i <= ∑ n f.
  Proof.
    revert f i; induction n as [ | n IHn ]; intros f i H.
    + omega.
    + rewrite msum_S.
      destruct i as [ | i ]; try omega.
      apply lt_S_n, IHn with (f := fun i => f (S i)) in H.
      omega.
  Qed.

  Fact sum_power_lt k n f : k <> 0 -> (forall i, i < n -> f i < k) -> ∑ n (fun i => f i * power i k) < power n k.
  Proof.
    intros Hk.
    revert f; induction n as [ | n IHn ]; intros f Hf.
    + rewrite msum_0, power_0; omega.
    + rewrite msum_S, power_S, power_0, Nat.mul_1_r.
      apply le_trans with (k+ k * (power n k-1)).
      * apply (@plus_le_compat (S (f 0))).
        - apply Hf; omega.
        - rewrite msum_ext with (g := fun i => k*(f (S i)*power i k)).
          ++ rewrite sum_0n_distr_l with (one := 1); auto; try (intros; ring).
             apply mult_le_compat_l.
             apply le_S_n, le_trans with (power n k); try omega.
             apply IHn; intros; apply Hf; omega.
          ++ intros; rewrite power_S; ring.
      * generalize (power_ge_1 n Hk); intros ?.
        replace (power n k) with (1+(power n k - 1)) at 2 by omega.
        rewrite Nat.mul_add_distr_l.
        apply plus_le_compat; omega.
  Qed.

  Theorem Newton_nat a b n :
       power n (a + b) = ∑ (S n) (fun i => binomial n i * power (n - i) a * power i b).
  Proof.
    rewrite binomial_Newton with (1 := Nat_plus_monoid) (4 := Nat_mult_monoid); try (intros; ring); auto.
    apply msum_ext; intros i Hi.
    rewrite scal_one with (1 := Nat_plus_monoid) (3 := Nat_mult_monoid); auto; try (intros; ring).
    rewrite <-mult_assoc; f_equal; auto.
    generalize (binomial n i); intros k.
    induction k as [ | k IHk ].
    + rewrite mscal_0; auto.
    + rewrite mscal_S, IHk; auto; apply plus_cancel_l.
  Qed.

  Theorem Newton_nat_S a n :
       power n (1 + a) = ∑ (S n) (fun i => binomial n i * power i a).
  Proof.
    rewrite Newton_nat.
    apply msum_ext.
    intros; rewrite power_of_1; ring.
  Qed.

  Lemma binomial_le_power n i : binomial n i <= power n 2.
  Proof.
    destruct (le_lt_dec i n) as [ Hi | Hi ].
    + change 2 with (1+1).
      rewrite Newton_nat_S.
      eapply le_trans.
      2:{ apply sum_0n_le_one with (f := fun i => binomial n i * power i 1).
          apply le_n_S, Hi. }
      rewrite power_of_1; omega.
    + rewrite binomial_gt; auto; omega.
  Qed.

  Corollary binomial_lt_power n i : binomial n i < power (S n) 2.
  Proof.
    apply le_lt_trans with (1 := binomial_le_power _ _), power_sinc; auto.
  Qed.

End Newton_nat.


(* Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday saturday).

Example test_next:
  (next_weekday(next_weekday(saturday))) = tuesday.

Proof. simpl. reflexivity. Qed. *)

(*
Inductive bool : Type :=
  | true
  | false.

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

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

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

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

(*Level 1 -- nandb*)

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

(*Level 1 -- nandb3*)

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
(andb b1 (andb b2 b3)).

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

(* Check negb.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p: rgb).

Definition monochrome (c: color) :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

Inductive bit : Type :=
  | B0
  | B1.
Inductive nybble : Type :=
  | bits (b0 b1 b2 b3 : bit).
Check (bits B1 B0 B1 B0).

Definition all_zero (nb : nybble) : bool :=
  match nb with
    | (bits B0 B0 B0 B0) => true
    | (bits _ _ _ _) => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).
Compute (all_zero (bits B1 B1 B1 B1)).
Compute (all_zero (bits B0 B0 B0 B0)).

Module NatPlayground.

Inductive nat : Type :=
  | O
  | S (n : nat) .

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

End NatPlayground.

Check (S (S (S 2))). *)

(*Level 1 -- factorial*)

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

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

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

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.


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

Check nat_ind.

Theorem mult_0_r' : forall n:nat,
  n * 0 = 0.
Proof.
  apply nat_ind.
  - reflexivity.
  - simpl. intros n' IHn'. apply IHn'.
Qed.

(* Exercise: 2 stars, optional (plus_one_r') *)
Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  apply nat_ind.
  - reflexivity.
  - simpl. intros n' IHn'. rewrite IHn'. reflexivity.
Qed.

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

Check yesno_ind.

(* Exercise: 1 star, optional (rgb) *)
Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.

(* rgb_ind : forall P : rgb -> Prop,
  P red -> P green -> P blue -> forall r : rgb, P r.*)

Check rgb_ind.

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.

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

Inductive natlist1 : Type :=
  | nnil1 : natlist1
  | nsnoc1 : natlist1 -> nat -> natlist1.

(* natlist1_ind : forall P : natlist1 -> Prop,
  P nnil1 ->
  (forall (ns : natlist1),
  P ns -> forall n:nat, P (nsnoc1 ns n) ->
  forall ns : natlist1, P ns *)
Check natlist1_ind.

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

Inductive byntree : Type :=
  | bempty : byntree
  | bleaf : yesno -> byntree
  | nbranch : yesno -> byntree -> byntree -> byntree.

(* byntree_ind : forall P : byntree -> Prop.
  P bempty ->
  (forall (y:yesno), P (bleaf y)) ->
  (forall (y:yesno) (b : byntree),
  P b ->
  forall (b0 : byntree) P b0 -> P (nbranch y b b0)) ->
  forall b : byntree, P b *)

Check byntree_ind.

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

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

Inductive ExSet : Type :=
  | con1 : bool -> ExSet
  | con2 : nat -> ExSet -> ExSet.

Check ExSet_ind.

(* Polymorphism *)

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

Check list_ind.

(* Exercise: 1 star, optional (tree) *)
Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.

(* tree_ind :
  forall (X : Type) (P : tree X -> Prop),
  (forall (x : X), P (leaf X x)) ->
  (forall (x : X) (t : tree X),
  P t ->
  (forall (t0: tree X), P t0 -> P (node X t t0))) ->
  forall t : tree X, P t. *)

Check tree_ind.

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

Inductive mytype (X : Type) : Type :=
  | constr1 : X -> mytype X
  | constr2 : nat -> mytype X
  | constr3 : mytype X -> nat -> mytype X.

Check mytype_ind.

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

Inductive foo (X Y : Type) : Type :=
  | bar : X -> foo X Y
  | baz : Y -> foo X Y
  | quux : (nat -> foo X Y) -> foo X Y.

Check foo_ind.

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

Inductive foo' (X:Type) : Type :=
  | C1 : list X -> foo' X -> foo' X
  | C2 : foo' X.

(*  foo'_ind :
  forall (X : Type) (P : foo' X -> Prop),
    (forall (l : list X) (f : foo' X),
        P f ->
        P (C1 X l f)) ->
    P (C2 X) ->
    forall f : foo' X, P f *)
Check foo'_ind.

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

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

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  - reflexivity.
  - intros n IHn.
    unfold P_m0r in IHn. unfold P_m0r. simpl. apply IHn.
Qed.

(* More on the 'induction' tactic *)

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

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

Theorem plus_comm'' : forall n m : nat,
  n + m = m + n.
Proof.
  induction m as [| m'].
  - simpl. rewrite <- plus_n_O. reflexivity.
  - simpl. rewrite <- IHm'. rewrite <- plus_n_Sm. reflexivity.
Qed.

(* Exercise: 1 star, optional (plus_explicit_prop) *)
Definition P_plus_assoc (n m p: nat) : Prop :=
  n + (m + p) = (n + m) + p.

Definition plus_assoc''' : forall n m p : nat,
  P_plus_assoc n m p.
Proof.
  intros.
  apply nat_ind.
  - unfold P_plus_assoc. rewrite <- plus_n_O. rewrite <- plus_n_O. reflexivity.
  - intros. unfold P_plus_assoc in *. rewrite <- plus_n_Sm. rewrite <- plus_n_Sm. rewrite H. rewrite plus_n_Sm. reflexivity.
Qed.

Definition P_plus_comm (n m : nat) : Prop :=
  n + m = m + n.

Definition plus_comm''' : forall n m : nat,
  P_plus_comm n m.
Proof.
  intros.
  apply nat_ind.
  - unfold P_plus_comm. simpl. rewrite <- plus_n_O. reflexivity.
  - intros. unfold P_plus_comm in *. simpl. rewrite <- H. rewrite plus_n_Sm. reflexivity.
Qed.

(* Induction Principles in Prop *)

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

Check ev_ind.

Theorem ev_ev' : forall n, ev n -> ev' n.
Proof.
  apply ev_ind.
  - apply ev'_0.
  - intros m Hm IH. apply (ev'_sum 2 m).
    + apply ev'_2.
    + apply IH.
Qed.

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

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

Check le_ind.


Require Import List.
Require Import String.
Open Scope string_scope.

Definition var := string.

(** Lambda calculus syntax.

 We have variables, application, and abstraction. These are all we
 need in order to write programs to compute every computable function.
 *)
Inductive Expr : Set :=
| EConst                        (* The one and only constant     *)
| EVar (v : var)                (* Variables                     *)
| EApp (e1 : Expr) (e2 : Expr)  (* Application, e1 applied to e2 *)
| EAbs (x : var) (body : Expr). (* Abstraction, \x -> body       *)

(**

In this homework you will implement call by value semantics of
lambda calculus. This means that when evaluating a function
application, (e1 e2) you will:

  1. evaluate e1 down as far as possible (it had better end up an abstraction)

  2. next, evaluate e2 down to a VALUE.
      NOTE: in our simple lambda calculus, abstractions and constants are values

  3. next, substitute the value we got for e2 into the simplified form of e1
      NOTE: we define a relation for what it means to be a well formed substitution below

*)

(* Here we formally define what it means to be a value (not able to be evaluated any more) *)
Definition isValue (e : Expr) : Prop :=
  match e with
    | EVar _ => False
    | EAbs _ _ => True
    | EConst => True
    | EApp _ _ => False
  end.

(**

Here we introduce what is called a decidability lemma.
Essentially we are saying that for any expression you have, it's either a value or not.
We need this because we can write down undecidable things as Props.

*)
Lemma isValueDec :
  forall e,
    { isValue e } + {~ isValue e}.
Proof.
  intros. destruct e; simpl; auto.
Defined.

(* Here we define what it means for a particular substitution to be valid *)
(* e1[e2/x] = e3 *)
Inductive Subst : Expr -> Expr -> var -> Expr -> Prop :=
| SubstConst : forall e x, (* substituting into a const is just that const *)
  Subst EConst e x EConst
| SubstVar_same : forall e x, (* substitute an expression in for a variable *)
  Subst (EVar x) e x e
| SubstVar_diff : forall e x1 x2,
  x1 <> x2 ->
  Subst (EVar x1) e x2 (EVar x1)
| SubstApp : forall eA eB e x eA' eB',
  Subst eA e x eA' ->
  Subst eB e x eB' ->
  Subst (EApp eA eB) e x (EApp eA' eB')
| SubstAbs_same : forall eA e x,
  Subst (EAbs x eA) e x (EAbs x eA)
| SubstAbs_diff : forall eA e x1 x2 eA',
  x1 <> x2 ->
  Subst eA e x2 eA' ->
  Subst (EAbs x1 eA) e x2 (EAbs x1 eA').

(* Here we give semantics to our simple language *)
Inductive Step : Expr -> Expr -> Prop :=
| ScrunchLeft :
    forall e1 e1' e2,
      Step e1 e1' ->
      Step (EApp e1 e2) (EApp e1' e2)
| ScrunchRight :
    forall e1 e2 e2',
      isValue e1 ->
      Step e2 e2' ->
      Step (EApp e1 e2) (EApp e1 e2')
| Ssubst :
    forall x e1 e2 e1',
      isValue e2 ->
      Subst e1 e2 x e1' ->
      Step (EApp (EAbs x e1) e2) e1'.

(* Here we define the transitive closure of a step relation. Note that
we are able to define this once for any step relation, which is just
kinda cool *)
Inductive star (step : Expr -> Expr -> Prop) : Expr -> Expr -> Prop :=
 | star_refl :
     forall e,
       star step e e
 | star_right :
     forall e1 e2 e3,
       star step e1 e2 ->
       step e2 e3 ->
       star step e1 e3.

(* [Problem 1] *)
(* Implement a function to perform substitution *)
(* e1[e2/x] = e3 *)
(* Given e1, e2, and x, produce e3 *)
(* Your function should be a total function (no option in the return type *)
(* Hint: for equality of vars, use "string_dec" *)

(* [Problem 2] *)
(* Prove that, given a valid term of the Subst relation, your function *)
(* from problem 1 will produce the same substitution. *)

(* [Problem 3] *)
(* Prove that if your function from problem 1 produces a substitution, *)
(* it's modeled by the Subst relation *)
(* This should look like problem 2 with the hypothesis and conclusion flipped *)

(* [Problem 4] *)
(* Define a step function *)
(* The skeleton of one has been provided *)
Fixpoint step (e : Expr) : option Expr := None.

(* In lambda calculus, we like to reason about what values can take
steps, and can't. We would love to know that if we have a value,
i.e. something that we have decided is the end result of a
computation, then it can't take a step *)

(* [Problem 5] *)
(* Prove that any value cannot take a step *)

(* We have step function, and a Step relation *)
(* That means we can prove them equivalent *)
(* Let's make sure the step function is implemented correctly *)

(* In proving the next two lemmas, you may find bugs in your step *)
(* function. Change it all you need. Don't modify the Step relation. *)

(* When you've proven the next two lemmas, you will know that you got *)
(* your step function right *)

(* [Problem 6] *)
(* Prove that if the Step relation says e1 can step to e2, then your *)
(* step function will take e1 and produce "Some e2" *)

(* [Problem 7] *)
(* Prove that if your step function produces "Some", that the Step *)
(* relation models that step *)

(* That's awesome, we defined relations and functions for evaluation *)
(* Now, we were able to prove that if something is a value, it can't take a step *)
(* What if we were to try to prove the other way, that if something
   can't take a step, then it's not a value? *)

Lemma no_step_value :
  forall v,
    step v = None ->
    isValue v.
Proof.

Abort.

(* Turns out we can have malformed expressions, which can't step, but aren't values. *)

(* [Problem 8] *)
(* Explain in English how we can have expressions that both can't step and aren't values *)

(* [Problem 9] *)
(* Prove the following lemma in Coq to show you have a counterexample *)
Lemma no_step_and_not_value :
  exists e,
    step e = None /\ ~ isValue e.
Proof.
  admit.
Qed.

(* How do we solve this? With types! *)

(* Here we define the types for the simply typed lambda calculus *)
Inductive SimpleType :=
  | TUnit
  | TFun (arg : SimpleType) (res : SimpleType).

(* Here we define what a type environment is *)
(* Simply a mapping from variables to types *)
Definition Env := var -> option SimpleType.

(* Here is how we extend a typing environment with another variable binding *)
Definition extend (env : Env) x t :=
  fun y => if string_dec x y then Some t else env y.

(* What it means for a lambda expression to be well typed *)
(* These are the type rules for STLC *)
(* You will frequently see them in the literature with horizontal lines *)
Inductive WellTyped : Env -> Expr -> SimpleType -> Prop :=
  | WtConst :
      forall env,
        WellTyped env EConst TUnit
  | WtVar :
      forall env x t,
        env x = Some t ->
        WellTyped env (EVar x) t
  | WtAbs :
      forall env x t exp t',
        WellTyped (extend env x t) exp t' ->
        WellTyped env (EAbs x exp) (TFun t t')
  | WtApp :
      forall env f arg t t',
        WellTyped env arg t ->
        WellTyped env f (TFun t t') ->
        WellTyped env (EApp f arg) t'.

(* [Problem 10] *)

(* Explain in English why we will run into trouble if we try to write *)
(* a typechecker as a function. For everything else, we write a relation *)
(* and a function, and prove the two equivalent. Why, in this particular *)
(* case, can we not simply write the "well_typed" function, of type *)
(* Env -> Expr -> SimpleType -> Bool? *)

(* Here's another decidability lemma for types *)
Lemma st_eq_dec :
  forall (t1 t2 : SimpleType),
    {t1 = t2} + {t1 <> t2}.
Proof.
  decide equality.
Qed.

(* The empty environment *)
Definition Empty : Env := fun x => None.

(* [Problem 11] *)
(* Here's what we call a "canonical forms" lemma *)
(* We want to say that if something has a type of a value in an empty *)
(* context, it is in its "canonical form" *)
Lemma canonical_const :
  forall e,
    isValue e ->
    WellTyped Empty e TUnit ->
    e = EConst.
Proof.
  admit.
Qed.

(* [Problem 12] *)
(* Here's something more interesting. Canonical forms for functions *)
Lemma canonical_abs :
  forall e t t',
    isValue e ->
    WellTyped Empty e (TFun t t') ->
    exists x body,
      e = EAbs x body.
Proof.
  admit.
Qed.

(* [Problem 13] *)
(* In order to prove type soundness, we destructure the proof into two lemmas *)
(* The first one is called progress *)
(* If I have a well typed term, it can either take a step, or is a value *)
(* Prove the progress lemma *)
(* Hint: before inducting, use "remember Empty as env" to preserve the *)
(* knowledge that the environment is Empty *)
(* Hint: you will need one of your canonical forms lemmas from above *)
Lemma type_progress :
  forall e t,
    WellTyped Empty e t ->
    ((exists e', Step e e') \/ isValue e).
Proof.
  admit.
Qed.

(* The second lemma is called type preservation *)
(* In order to prove that, we're going to need a lot of auxiliary machinery *)
(* Don't worry, I'll walk you through it. *)

(* FROM THIS POINT ON *)
(* I may not tell you to use a lemma that you've previously proved *)
(* but you absolutely should *)

(* I give you the lemmas I think you need to succeed. If you need more *)
(* lemmas that's completely fine. If you try to do some of these proofs *)
(* without using the lemmas you've already proven, you will not have a *)
(* good time. *)

(* Here we define what it means for two environments to be extensionally equivalent *)
(* Extensional Equality for functions means they return the same result for every argument *)
(* for example, \x -> 1 + x and \x -> x + 1 are extensionally equivalent, but not the same function *)
Definition ext_equiv (env1 env2 : Env) : Prop :=
  forall x,
    env1 x = env2 x.

(* [Problem 14] *)
(* Prove a lemma about extending extensionally equivalent environments *)
Lemma extend_pres_ext_equiv :
  forall env env2,
    ext_equiv env env2 ->
    forall x t,
      ext_equiv (extend env x t) (extend env2 x t).
Proof.
  admit.
Qed.

(* [Problem 15] *)
(* Prove that if a term is well typed in an environment, it is also *)
(* well typed in any extensionally equivalent environment *)
(* Hint: Be careful with your induction *)
Lemma well_typed_ext_equiv :
  forall env1 e t,
    WellTyped env1 e t ->
    forall env2,
      ext_equiv env1 env2 ->
      WellTyped env2 e t.
Proof.
  admit.
Qed.

(* [Problem 16] *)
(* Prove that extending an environment with the same variable twice is *)
(* the same as extending it once *)
(* Hint: use well_typed_ext_equiv *)
Lemma extend_same:
  forall env x t t' e t'',
    WellTyped (extend (extend env x t) x t') e t'' <->
    WellTyped (extend env x t') e t''.
Proof.
  admit.
Qed.

(* [Problem 17] *)
(* Prove that extending an environment with two different variables is *)
(* ok to do in either order *)
Lemma extend_different:
  forall e t env x1 x2 t1 t2,
    x1 <> x2 ->
    (WellTyped (extend (extend env x2 t2) x1 t1) e t <->
    WellTyped (extend (extend env x1 t1) x2 t2) e t).
Proof.
  admit.
Qed.

(* Here we define what free variables exist in an expression *)
(* Intuitively, these are all the variables which exist, but are not *)
(* bound by an abstraction *)
Fixpoint free_variables (e : Expr) : list var :=
  match e with
    | EConst => nil
    | EVar x => x :: nil
    | EAbs x body => remove string_dec x (free_variables body)
    | EApp e1 e2 => app (free_variables e1) (free_variables e2)
  end.

(* [Problem 18] *)
(* This may seem to be an obvious lemma about remove and lists *)
(* It does not happen to be in the standard library *)
(* Let's go prove it *)
Lemma remove_different :
  forall {A} (eq_dec : forall (a b : A), {a = b} + {a <> b}) l x y,
    x <> y ->
    (In x l <->
    In x (remove eq_dec y l)).
Proof.
  admit.
Qed.

(* [Problem 19] *)
(* Here we prove what's called weakening *)
(* If a variable isn't in the free variables of an expression, *)
(* we can extend the context with that variable, and produce the same *)
(* typing derivation *)
Lemma weakening :
  forall e env t x t',
    ~ (In x (free_variables e)) ->
    (WellTyped (extend env x t') e t <->
    WellTyped env e t).
Proof.
  admit.
Qed.

(* [Problem 20] *)
(* Here we prove that a correct substitution preserves typing *)
(* This one's a bit tricky, but remember to use inversion where *)
(* necessary, and to use previously proven lemmas *)
Lemma subst_type_pres :
  forall e e' e'' x,
    Subst e' e x e'' ->
    forall env t t',
      WellTyped env e t ->
      free_variables e = nil ->
      WellTyped (extend env x t) e' t' ->
      WellTyped env e'' t'.
Proof.
  admit.
Qed.

(* [Problem 21] *)
(* Here we prove that if we have free variables in an expression, we *)
(* need them in the type environment if that is well typed *)
Lemma env_vars_required :
  forall env e t,
    WellTyped env e t ->
    (forall x, In x (free_variables e) -> env x <> None).
Proof.
  admit.
Qed.

(* [Problem 22] *)
(* Here we prove that something that's well typed in the empty *)
(* environment has no free variables *)
(* Hint: Use a previously proven lemma *)
Lemma no_free_vars_empty :
  forall e t,
    WellTyped Empty e t ->
    free_variables e = nil.
Proof.
  admit.
Qed.

(* [Problem 23] *)
(* We finally have enough lemmas to prove type preservation, the other *)
(* lemma necessary for type soundness. It says that if we have a well *)
(* typed term, and take a step, then the result is still well typed with *)
(* the same type. *)
Lemma type_preservation :
  forall e t,
    WellTyped Empty e t ->
    forall e',
      Step e e' ->
      WellTyped Empty e' t.
Proof.
  admit.
Qed.

(* [Problem 24] *)
(* Prove type preservation over any sequence of steps *)
(* The lemma should look almost identical to the previous problem *)

(* [Problem 25] *)
(* Prove that our simple type system for lambda calculus is sound *)
(* Prove that any term reachable from any well typed term can either *)
(* take a step, or is a value *)
Theorem type_soundness :
  forall e t,
    WellTyped Empty e t ->
    forall e',
      star Step e e' ->
      (exists e'', Step e' e'') \/ isValue e'.
Proof.
  admit.
Qed.

(* Crowning Achievement *)
(* [Problem 26] *)
(* Prove the lemma we originally set out to prove, but with the *)
(* additional hypothesis of the term being well typed *)
Lemma no_step_value_typed :
  forall e t,
    WellTyped Empty e t ->
    step e = None ->
    isValue e.
Proof.
  admit.
Qed.

(* Bonus Problem 1 *)
(* Hint: you will need strong induction on the size of the type *)
(* which means you will need to define what the size of the type means *)
(* Theorem strong_normalization : *)
(*   forall t e, *)
(*     WellTyped Empty e t -> *)
(*     exists v, *)
(*       star Step e v /\ isValue v. *)
(* Proof. *)
(* Note: the implication of this is interesting. This says that every *)
(* well typed term will halt. *)

(* Bonus Problem 2 *)
(* Construct your own definitions of the simply typed lambda calculus *)
(* that allow you to write a typechecker as a function (i.e. to get *)
(* around the problem you describe above) *)


(*
https://softwarefoundations.cis.upenn.edu/lf-current/Basics.html
*)

(* ************************************************************************** *)
(* Exercise: 1 star, standard (nandb) *)
Definition nandb (b c : bool) : bool :=
  match b, c with
  | false, _ | _, false => true
  | _, _ => false
  end.
Example test_nandb1 : (nandb true false = true). Proof. reflexivity. Qed.
Example test_nandb2 : (nandb false false = true). Proof. reflexivity. Qed.
Example test_nandb3 : (nandb false true = true). Proof. reflexivity. Qed.
Example test_nandb4 : (nandb true true = false). Proof. reflexivity. Qed.

(* Exercise: 1 star, standard (nandb) - experiments *)
Definition notb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.
Definition andb (b c : bool) : bool :=
  match b, c with
  | true, true => true
  | _, _ => false
  end.
Definition nandb_bis (b c : bool) : bool := notb (andb b c).
Theorem nandbs_equivalents : forall b c : bool,
    (nandb b c) = (nandb_bis b c).
Proof.
  intros b c.
  destruct b, c.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (andb3) *)
Definition andb3 (b c d : bool) : bool :=
  match b, c, d with
  | true, true, true => true
  | _, _, _ => false
  end.
Example test_andb31: (andb3 true true true) = true. Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false. Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false. Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false. Proof. reflexivity. Qed.

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

(* ************************************************************************** *)
(* Exercise: 1 star, standard (ltb) *)
Fixpoint eqb (n m : nat) : bool :=
  match n, m with
  | O, O => true
  | O, S _ | S _, O => false
  | S n', S m' => eqb n' m'
 end.
Fixpoint leb (n m : nat) : bool :=
  match n, m with
  | O, O | O, S _ => true
  | S _, O => false
  | S n', S m' => leb n' m'
  end.
Definition ltb (n m : nat) : bool :=
  match eqb n m, leb n m with
  | false, true => true
  | _, _ => false
  end.
Example test_ltb1: (ltb 2 2) = false. Proof. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true. Proof. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false. Proof. reflexivity. Qed.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (plus_id_exercise) *)
Theorem plus_id_exercise : forall n m o : nat,
    n = m ->
    m = o ->
    n + m = m + o.
Proof.
  intros n m o H1 H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (mult_n_1) *)
Check mult_n_Sm.
Check mult_n_O.
Theorem mult_n_1 : forall p : nat, p * 1 = p.
Proof.
  intro a.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 2 stars, standard (andb_true_elim2) *)
Theorem andb_true_elim2 : forall b c : bool,
    andb b c = true -> c = true.
Proof.
  intros b c.
  destruct b, c.
  - reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
  - reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (zero_nbeq_plus_1) *)
Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Theorem zero_nbeq_plus_1 : forall n : nat, 0 =? (n + 1) = false.
Proof.
  intros [].
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 2 stars, standard, optional (decreasing) *)
Fail Fixpoint forever (n m: nat) : nat :=
  match n, m with
  | S n, S m => forever m n
  | _, _ => O
  end.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (identity_fn_applied_twice) *)
Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  (forall (b : bool), f (f b) = b).
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (negation_fn_applied_twice) *)
Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
Qed.
Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  (forall (b : bool), f (f b) = b).
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  rewrite -> negb_involutive.
  reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 3 stars, standard, optional (andb_eq_orb)

false & false = false | false  ||| false = false
 true &  true =  true | true   ||| true = true

 true & false =  true | false  ||| false = true
false &  true = false | true   ||| false = true *)
Theorem andb_eq_orb_cheat : forall b c, andb b c = orb b c -> b = c.
Proof.
  intros b c.
  destruct b, c.
  - reflexivity.
  - simpl. intros H. rewrite -> H.  reflexivity.
  - simpl. intros H. rewrite -> H.  reflexivity.
  - reflexivity.
Qed.
Theorem andb_eq_orb_cheat2 : forall b c, andb b c = orb b c -> b = c.
Proof.
intros [|] [|] H.
- reflexivity.
- simpl in H. rewrite H. reflexivity.
- simpl in H. exact H.
- reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 3 stars, standard (binary) *)

(* bin *)
Inductive bin : Type :=
| Z
| B0 (n : bin)
| B1 (n : bin).
Definition zero_bin : bin := Z.
Definition one_bin : bin := B1 Z.
Definition two_bin : bin := B0 one_bin.
Definition three_bin : bin := B1 one_bin.
Definition four_bin : bin := B0 two_bin.
Definition five_bin : bin := B1 two_bin.
Definition six_bin : bin := B0 three_bin.
Definition seven_bin : bin := B1 three_bin.
Fixpoint incr (m : bin) : bin :=
  match m with
  | Z => B1 Z
  | B0 n => B1 n
  | B1 n => B0 (incr n)
  end.
Example test_bin_incr0 : incr zero_bin = one_bin. Proof. reflexivity. Qed.
Example test_bin_incr1 : incr one_bin = two_bin. Proof. reflexivity. Qed.
Example test_bin_incr2 : incr two_bin = three_bin. Proof. reflexivity. Qed.
Example test_bin_incr3 : incr three_bin = four_bin. Proof. reflexivity. Qed.
Example test_bin_incr4 : incr four_bin = five_bin. Proof. reflexivity. Qed.
Example test_bin_incr5 : incr five_bin = six_bin. Proof. reflexivity. Qed.
Example test_bin_incr6 : incr six_bin = seven_bin. Proof. reflexivity. Qed.

(* conversions *)
Fixpoint bin_to_nat' (m : bin) (weight : nat) : nat :=
  match m with
  | Z => O
  | B1 m' => weight + bin_to_nat' m' (weight * 2)
  | B0 m' => bin_to_nat' m' (weight * 2)
  end.
Definition bin_to_nat (m : bin) : nat := bin_to_nat' m 1.
Definition zero_nat : nat := O.
Definition one_nat : nat := S zero_nat.
Definition two_nat : nat := S one_nat.
Definition three_nat : nat := S two_nat.
Definition four_nat : nat := S three_nat.
Definition five_nat : nat := S four_nat.
Definition six_nat : nat := S five_nat.
Definition seven_nat : nat := S six_nat.
Example test_bin_to_nat_0 : bin_to_nat zero_bin = zero_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_1 : bin_to_nat one_bin = one_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_2 : bin_to_nat two_bin = two_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_3 : bin_to_nat three_bin = three_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_4 : bin_to_nat four_bin = four_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_5 : bin_to_nat five_bin = five_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_6 : bin_to_nat six_bin = six_nat. Proof. reflexivity. Qed.
Example test_bin_to_nat_7 : bin_to_nat seven_bin = seven_nat. Proof. reflexivity. Qed.

(* experiments *)
Fixpoint decr (m : bin) : bin :=
  match m with
  | Z => Z
  | B1 Z => Z
  | B0 (B1 Z) => B1 Z
  | B1 x => B0 x
  | B0 x => B1 (decr x)
  end.
Example test_bin_decr0 : decr zero_bin = zero_bin. Proof. reflexivity. Qed.
Example test_bin_decr1 : decr one_bin = zero_bin. Proof. reflexivity. Qed.
Example test_bin_decr2 : decr two_bin = one_bin. Proof. reflexivity. Qed.
Example test_bin_decr3 : decr three_bin = two_bin. Proof. reflexivity. Qed.
Example test_bin_decr4 : decr four_bin = three_bin. Proof. reflexivity. Qed.
Example test_bin_decr5 : decr five_bin = four_bin. Proof. reflexivity. Qed.
Example test_bin_decr6 : decr six_bin = five_bin. Proof. reflexivity. Qed.
Example test_bin_decr7 : decr seven_bin = six_bin. Proof. reflexivity. Qed.
Theorem incr_decr_inverse : forall x, decr (incr x) = x.
Proof.
Admitted.

(* experiments *)
Fixpoint nat_to_bin (x : nat) : bin :=
  match x with
  | O => Z
  | S x => incr (nat_to_bin x)
  end.
Theorem bin_to_nat_to_bin : forall x : bin, nat_to_bin (bin_to_nat x) = x.
Proof.
Admitted.


Fixpoint elsonfvsum (n:nat)(f:nat->nat):nat:=
  match n with
  | 0 => 0
  | S(n0) => elsonfvsum(n0)(f) +f (S(n0))
  end.

Definition fv1(k:nat):=
  k+k.

Definition alap (k:nat):=
  k.

Eval compute in elsonfvsum 3 fv1.

Theorem lemma (n:nat): n * (n + 1) + 2 * S n = S n * (S n + 1).
Proof.
  induction n.
  compute;auto.

  simpl (S(n) + 1).
  simpl (2 * S(S n)).
  simpl.
  Require Import Omega.
  Require Import Lia.
  lia.
Qed.
Theorem gauss: forall n:nat, 2*(elsonfvsum n alap) = n*(n+1).
  intros.
  induction n.
  compute.
  auto.
  simpl (elsonfvsum (S n) alap).
  enough (2 * (elsonfvsum n alap + alap (S n)) = 2 * (elsonfvsum n alap) + 2*alap (S n)).
  rewrite H.
  rewrite IHn.
  unfold alap.
  induction n.
  compute.
  auto.
  Require Import Lia.
  lia.
  lia.
Qed.


Definition peirce := forall P Q:Prop, ((P->Q)->P)->P.
Definition classic := forall P:Prop, ~~P -> P.
Definition excluded_middle := forall P:Prop, P\/~P.
Definition de_morgan_not_and_not := forall P Q:Prop, ~(~P/\~Q)->P\/Q.
Definition implies_to_or := forall P Q:Prop, (P->Q)->(~P\/Q).

Lemma excluded_middle_peirce : excluded_middle -> peirce.
Proof.
 unfold peirce; intros H P Q H0.
 destruct (H P) as [p | np].
 -  assumption.
 -  apply H0; intro H1; now absurd P.
Qed.

Lemma peirce_classic : peirce -> classic.
Proof.
 intros HPeirce P H0; apply (HPeirce P False).
 intro H1; now destruct H0.
Qed.

Lemma classic_excluded_middle: classic -> excluded_middle.
Proof.
 unfold excluded_middle; intros H P.
 apply H; intro H0; absurd P.
 -  intro H1; apply H0 ; now left.
 -  apply H; intro H1; apply H0; now right.
Qed.

Lemma excluded_middle_implies_to_or :  excluded_middle -> implies_to_or.
Proof.
 intros H P Q H0;
  destruct (H P) as [p | np].
  -  right; auto.
  - now  left.
Qed.

Lemma implies_to_or_excluded_middle : implies_to_or -> excluded_middle.
Proof.
 unfold excluded_middle; intros H P; destruct (H P P);auto.
Qed.

Lemma classic_de_morgan_not_and_not : classic ->
                                      de_morgan_not_and_not.
Proof.
 unfold de_morgan_not_and_not; intros H P Q H0.
 apply H.
 intro H1; apply H0; split;intro;apply H1; auto.
Qed.

Lemma de_morgan_not_and_not_excluded_middle : de_morgan_not_and_not ->
                                              excluded_middle.
Proof.
 unfold excluded_middle; intros H P.
 apply H; intros [H1 H2]; contradiction.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List.

Require Import list_utils.

Set Implicit Arguments.

Definition finite_t X (P : X -> Prop) := { l | forall x, In x l <-> P x }.

Section finite_t.

  Fact finite_t_pair X Y (P : X -> Prop) (Q : Y -> Prop) :
    finite_t P -> finite_t Q -> finite_t (fun c => P (fst c) /\ Q (snd c)).
  Proof.
    intros (l & Hl) (m & Hm).
    exists (list_prod (@pair _ _) l m).
    intro c; rewrite list_prod_spec, <- Hl, <- Hm.
    split.
    intros (x & y & ? & ? & ?); subst; simpl; auto.
    destruct c as (x,y); exists x, y; simpl; auto.
  Qed.

  Fact finite_t_Forall X Y (R : X -> Y -> Prop) l :
    (forall x, In x l -> finite_t (R x)) -> finite_t (Forall2 R l).
  Proof.
    intros Hl; induction l as [ | x l IHl ].
    exists (nil::nil).
    intros x; split.
    intros [ ? | [] ]; subst; constructor.
    inversion_clear 1; left; auto.
    destruct (Hl _ (or_introl eq_refl)) as (l1 & Hl1).
    destruct IHl as (mm1 & Hmm1).
    intros; apply Hl; right; auto.
    exists (list_prod (@cons _) l1 mm1); intros c.
    rewrite list_prod_spec.
    split.
    intros (y & m & ? & ? & ?); subst; constructor.
    apply Hl1; auto.
    apply Hmm1; auto.
    intros H.
    destruct c as [ | y m ].
    inversion H.
    rewrite Forall2_cons_inv in H.
    destruct H as (H1 & H2).
    exists y, m; split; auto; split.
    apply Hl1; auto.
    apply Hmm1; auto.
  Qed.

  (* Filtering out a finite set with a decidable functions gives a finite set
     A VERY handy result *)

  Fact finite_t_dec X (P Q : X -> Prop) : (forall x, { P x } + { ~ P x }) -> finite_t Q -> finite_t (fun x => P x /\ Q x).
  Proof.
    intros HP (l & Hl).
    exists (filter (fun x => if HP x then true else false) l).
    intros x.
    rewrite filter_In, <- Hl.
    destruct (HP x); split; try tauto.
    intros (_ & C); discriminate C.
  Qed.

  (* Mapping a finite set by a finitetary relation gives a finite set *)

  Fact finite_t_map X Y (P : X -> Prop) (Q : X -> Y -> Prop) :
      finite_t P
   -> (forall x, P x -> finite_t (Q x))
   -> finite_t (fun y => exists x, P x /\ Q x y).
  Proof.
    intros (l & Hll) H.
    assert (forall x, In x l -> finite_t (Q x)) as H1.
      intros x Hx; rewrite Hll in Hx; auto.
    assert (finite_t (fun y => exists x, In x l /\ Q x y)) as H2.
      clear P Hll H.
      induction l as [ | x l IHl ].
      exists nil.
      intros x; split.
      intros [].
      intros (? & [] & _).
      destruct (H1 _ (or_introl eq_refl)) as (l1 & Hl1).
      destruct IHl as (l2 & Hl2).
      intros; apply H1; right; auto.
      exists (l1++l2).
      intros y; split.
      intros Hy; apply in_app_or in Hy.
      destruct Hy as [ Hy | Hy ].
      exists x; split; simpl; auto; apply Hl1; auto.
      apply Hl2 in Hy.
      destruct Hy as (v & ? & ?); exists v; split; auto.
      right; auto.
      intros (u & [ ? | ? ] & H2); subst; apply in_or_app.
      left; apply Hl1; auto.
      right; apply Hl2; exists u; auto.
    destruct H2 as (m & Hm).
    exists m; intro; rewrite Hm.
    split; intros (u & ? & ?); exists u; split; auto; apply Hll; auto.
  Qed.

  Fact finite_t_plus n : finite_t (fun c => fst c + snd c = n).
  Proof.
    exists (map (fun x => (x,n-x)) (list_n (S n))).
    intros c; rewrite in_map_iff; split.
    intros (a & ? & H); subst; simpl.
    apply list_n_spec in H; omega.
    destruct c as (x,y); exists x.
    rewrite list_n_spec; simpl in H.
    split; [ f_equal | ]; omega.
  Qed.

  Fact finite_t_plus_lt n : finite_t (fun c => 0 < fst c /\ 0 < snd c /\ fst c + snd c = n).
  Proof.
    do 2 (apply finite_t_dec; [ intro; apply lt_dec | ]).
    apply finite_t_plus.
  Qed.

  (* There are only finitely many bounded lists of nat (bound on elements + bound on length *)

  Definition finite_t_list_bounded n m : finite_t (fun l => Forall (ge n) l /\ length l < m).
  Proof.
    induction m as [ | m (l & Hl) ].
    exists nil; simpl; intros; split; omega.
    exists (nil::list_prod (@cons _) (list_n (S n)) l).
    intros [ | a k ].
    simpl; split; auto; split; auto; omega.
    split.
    intros [ H | H ].
    discriminate H.
    apply list_prod_spec in H.
    destruct H as (x & y & E & H1 & H2).
    injection E; clear E; intros; subst x y.
    apply list_n_spec in H1.
    apply Hl in H2.
    split; simpl; try omega; constructor; try tauto; omega.
    intros (H1 & H2).
    apply Forall_cons_inv in H1.
    simpl in H2.
    right; apply list_prod_spec.
    exists a, k; split; auto.
    split.
    apply list_n_spec; omega.
    apply Hl; split; try tauto; omega.
  Qed.

  (* By filtering, lists of bounded length with a given total sum are in finite number *)

  Definition finite_t_part_lsum n m : finite_t (fun l => lsum l = n /\ length l < m).
  Proof.
    generalize (finite_t_list_bounded n m).
    intros H.
    apply finite_t_dec with (P := fun l => lsum l = n) in H.
    2: intro; apply eq_nat_dec.
    destruct H as (l & Hl); exists l.
    intros x; rewrite Hl.
    split; try tauto.
    intros (H1 & H2); repeat split; auto.
    rewrite Forall_forall.
    intros y Hy.
    generalize (lsum_le y x Hy); omega.
  Qed.

  (* By filterging again, lists of strictly positive numbers of a given total sum
     are in finite number as well *)

  Definition finite_t_partition n : finite_t (fun l => Forall (lt 0) l /\ lsum l = n).
  Proof.
    generalize (finite_t_part_lsum n (S n)); intros H.
    apply finite_t_dec with (P := Forall (lt 0)) in H.
    2: intro; apply Forall_dec; intros; apply lt_dec.
    destruct H as (l & Hl); exists l; intros x; rewrite Hl.
    split; try tauto.
    intros (H1 & H2); repeat split; auto.
    clear Hl l; apply le_n_S.
    revert H1 n H2.
    induction 1 as [ | x l Hx Hl IH ]; intros n ?; simpl.
    omega.
    simpl in H2.
    specialize (IH (n - x)).
    apply le_trans with (S (n-x)).
    apply le_n_S, IH; omega.
    omega.
  Qed.

  Fact finite_t_part n : finite_t (fun ln => match ln with
                                               | nil   => False
                                               | x::ln => Forall (lt 0) ln
                                                       /\ x + lsum ln = n
                                             end).
  Proof.
    set (P c := fst c + snd c = n).
    set (Q c l := match l with
                    | nil  => False
                    | x::l => x = fst c /\ Forall (lt 0) l /\ lsum l = snd c
                  end).
    destruct (@finite_t_map _ _ P Q (finite_t_plus n)) as (l & Hl).
    unfold P, Q; intros (a,b); simpl; intros Hab.
    destruct (finite_t_partition b) as (m & Hm).
    exists (map (cons a) m).
    intros l; rewrite in_map_iff.
    split.
    intros (x & ? & Hx); subst; split; auto; apply Hm; auto.
    destruct l as [ | x l ].
    intros [].
    intros (? & H1 & H2); subst; exists l; split; auto.
    apply Hm; auto.

    exists l; intros x.
    rewrite Hl; unfold P, Q.
    split; destruct x as [ | u m ].
    intros (? & ? & []).
    intros ( (a,b) & ? & ? & ? & ?); simpl in *; split; auto; omega.
    intros [].
    intros (? & ?); exists (u,lsum m); simpl; auto.
  Qed.

End finite_t.


(**
Exercises from http://adam.chlipala.net/cpdt/html/Subset.html
*)

Require Import Arith.
Require Import MoreSpecif.
Require Import CpdtTactics.
Set Implicit Arguments.

Local Open Scope specif_scope.

(**
Write a function of type [forall n m : nat, {][n <= m} + {][n > m}].  That is, this function decides whether one natural is less than another, and its dependent type guarantees that its results are accurate.
*)
Definition leq_nat_dec : forall n m : nat, {n <= m} + {n > m}.
  refine (fix f (n m : nat) : {n <= m} + {n > m} :=
    match n, m with
      | O, _ => Yes
      | _, O => No
      | S n', S m' => Reduce (f n' m')
    end); crush.
Defined.

(** Ex 2 *)

(** Define [var], a type of propositional variables, as a synonym for [nat]. *)
Definition var := nat.

(** Define an inductive type [prop] of propositional logic formulas, consisting of variables, negation, and binary conjunction and disjunction. *)
Inductive prop : Set :=
| Var : var -> prop
| Not : prop -> prop
| And : prop -> prop -> prop
| Or  : prop -> prop -> prop.

(** Define a function [propDenote] from variable truth assignments and [prop]s to [Prop], based on the usual meanings of the connectives.  Represent truth assignments as functions from [var] to [bool]. *)
Fixpoint propDenote (truth : var -> bool) (p : prop) : Prop :=
  match p with
    | Var v     =>  is_true (truth v)
    | Not p'    => ~(propDenote truth p')
    | And p1 p2 =>  (propDenote truth p1) /\ (propDenote truth p2)
    | Or  p1 p2 =>  (propDenote truth p1) \/ (propDenote truth p2)
  end.

(** Define a function [bool_true_dec] that checks whether a boolean is true, with a maximally expressive dependent type.  That is, the function should have type [forall b, {b = true} + {b = true -> False}]. *)
Definition bool_true_dec : forall b, {b = true} + {b = true -> False}.
  refine (fun b =>
    match b with
      | true => Yes
      | false => No
    end); crush.
Defined.

(** Define a function [decide] that determines whether a particular [prop] is true under a particular truth assignment.  That is, the function should have type [forall (truth : var -> bool) (p : prop), {propDenote truth p} + {~ propDenote truth p}].  This function is probably easiest to write in the usual tactical style, instead of programming with [refine].  The function [bool_true_dec] may come in handy as a hint. *)
Definition decide : forall (truth : var -> bool) (p : prop), {propDenote truth p} + {~ propDenote truth p}.
  induction p; crush. apply bool_true_dec.
Defined.

(** Define a function [negate] that returns a simplified version of the negation of a [prop].  That is, the function should have type [forall p : prop, {p' : prop | forall truth, propDenote truth p <-> ~ propDenote truth p'}].  To simplify a variable, just negate it.  Simplify a negation by returning its argument.  Simplify conjunctions and disjunctions using De Morgan's laws, negating the arguments recursively and switching the kind of connective.  Your [decide] function may be useful in some of the proof obligations, even if you do not use it in the computational part of [negate]'s definition.  Lemmas like [decide] allow us to compensate for the lack of a general Law of the Excluded Middle in CIC. *)
Fixpoint negateProp (p : prop) : prop :=
  match p with
    | Var v     => Not p
    | Not p'    => p'
    | And p1 p2 => Or (negateProp p1) (negateProp p2)
    | Or  p1 p2 => And (negateProp p1) (negateProp p2)
  end.
Definition negate : forall p : prop, {p' : prop | forall truth, propDenote truth p <-> ~ propDenote truth p'}.
  refine (fun p => [ negateProp p ]).
    intro truth. destruct (decide truth p); induction p; crush.
Defined.

(** Ex 3 in dpll.v *)


(*
Theorem plus_id_example : forall n m :nat,
                            n = m -> n+n = m + m.

Proof.
intros.
rewrite -> H.
reflexivity.
Qed.

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

Theorem mult_0_plus : forall n m : nat,
(0 + n) * m = n *m.
intros n m.
rewrite -> plus_0_n.
reflexivity. Qed.

*)


Require Import List.
Require Import Setoid.
Require Import PeanoNat.
Require Import Coq.omega.Omega.
Require Import Matrix.
Require Import Coq.setoid_ring.Ring.
Require Import Coq.setoid_ring.Ring_theory.
Require Import MyHelpers.

Definition DenseMatrix_t A := list A.

Section A.
 Context {ME : MatrixElem}.
 Add Field Afield : MEfield.

 Definition DenseMatrix_get (m n: nat) (M: DenseMatrix_t MEt) (i j : nat) :=
   nth_default MEzero M (i * n + j).

 Fixpoint Generate (m n k: nat) (f: nat -> MEt) :=
   match k with
   | 0 => @nil(MEt)
   | S k' => (f (m * n - k)) :: Generate m n k' f
   end.

 Definition DenseMatrix_mul (m n p: nat) (M1 M2: DenseMatrix_t MEt):=
   Generate m p (m * p) (fun k => (sum n (fun i => DenseMatrix_get m n M1 (Nat.div k  p) i *e DenseMatrix_get n p M2 i (Nat.modulo k p)))).

 Definition Matrix_elem_op (op: MEt -> MEt -> MEt) (m n: nat) (M1 M2: DenseMatrix_t MEt):=
   Generate m n (m * n) (fun k => op (DenseMatrix_get m n M1 (Nat.div k n) (Nat.modulo k n)) (DenseMatrix_get m n M2 (Nat.div k n) (Nat.modulo k n))).

 Lemma Generate_index: forall (m n l i: nat) (f: nat -> MEt),
     i < l ->
     nth_default MEzero (Generate m n l f) i = f(m * n + i - l).
 Proof.
   intros.
   generalize dependent i. induction l; intros.
   - inversion H.
   - cbn.
     destruct i.
     + rewrite nth_default_0.  auto.
     + rewrite nth_default_S.
       rewrite IHl; try omega.
       replace (m * n + i - l) with (m * n + (S i) - (S l)) by omega.
       reflexivity.
 Qed.

 Corollary Generate_get: forall (m n i j: nat) (f: nat -> MEt),
     i < m -> j < n ->
     DenseMatrix_get m n (Generate m n (m * n) f) i j = f(i * n + j).
 Proof.
   intros.
   unfold DenseMatrix_get.
   rewrite Generate_index.
   - rewrite minus_plus. reflexivity.
   - destruct m; try omega.
     destruct n; try omega.

     assert (i <= m) by omega.
     assert (j <= n) by omega.
     assert (i * S n <= m * S n) by (apply mult_le_compat_r; assumption).
     assert (i * S n + j <= m * S n + j) by (apply plus_le_compat_r; assumption).
     assert (m * S n + j <= m * S n + n) by (apply plus_le_compat_l; assumption).
     assert (m * S n + n < S m * S n).
     {
       simpl.
       rewrite <- mult_n_Sm.
       omega.
     }
     omega.
 Qed.
End A.

Definition DenseMatrix_fill {ME: MatrixElem} m n f := Generate m n (m * n) (fun x => f (x / n) (x mod n)).
Definition DenseMatrix_elementwise_op {ME: MatrixElem} m n op m1 m2 := Matrix_elem_op op m n m1 m2.

Definition DenseMatrix {ME: MatrixElem} : Matrix.
 unshelve eapply {| Mt m n := DenseMatrix_t MEt;
                    Mget := DenseMatrix_get;
                    Mtimes := DenseMatrix_mul;
                    Mfill := DenseMatrix_fill;
                    Melementwise_op := DenseMatrix_elementwise_op |};
   unfold DenseMatrix_fill, DenseMatrix_elementwise_op.
 - intros.
   unfold DenseMatrix_mul.
   rewrite Generate_get; try assumption.
   replace ((i * p + j) / p) with (i).
   replace ((i * p + j) mod p) with (j).
   reflexivity.
   + rewrite plus_comm. rewrite Nat.mod_add; try omega.
     rewrite Nat.mod_small; auto.
   + apply Nat.div_unique with (a := (i * p + j)) (b := p) (r := j); auto.
     rewrite mult_comm. reflexivity.
 - intros.
   simpl.
   rewrite Generate_get; auto.
   Print Nat.div_unique.
   rewrite <- Nat.div_unique with (b := n) (q := i) (r := j) (a := i * n + j); auto; try omega.
   Focus 2.
   rewrite Nat.mul_comm. reflexivity.

   rewrite Nat.add_comm.
   rewrite Nat.mod_add; try omega.
   rewrite Nat.mod_small; try omega.
   reflexivity.

 - intros.
   unfold Matrix_elem_op.
   rewrite Generate_get; try assumption.
   replace ((i * n + j) / n) with (i).
   replace ((i * n + j) mod n) with (j).
   reflexivity.
   + rewrite plus_comm. rewrite Nat.mod_add; try omega.
     rewrite Nat.mod_small; auto.
   + apply Nat.div_unique with (a := (i * n + j)) (b := n) (r := j); auto.
     rewrite mult_comm. reflexivity.
Defined.


(**
<<
  1. Introduction
>>
*)

  Fixpoint fact_aux (acc: nat) (n:nat):=
    match n with
      | O => acc
      | S n' => (fact_aux (acc*n) n')
    end.
  Functional Scheme fact_aux_ind := Induction for fact_aux Sort Prop.

  Definition fact_tr (n: nat) := fact_aux 1 n.

  Require Import Arith Ring.

  Lemma fact_aux_assoc: forall n acc m,
      m * (fact_aux acc n) = fact_aux (m*acc) n.
  Proof.
    intro n.
    induction n as [| n']; intros.
    - simpl.
      rewrite mult_comm.
      reflexivity.
    - simpl (fact_aux acc (S n')).
      rewrite IHn'.
      simpl.
      rewrite <- mult_assoc.
      reflexivity.
  Qed.

  Fixpoint fact_seed (seed n:nat):=
    match n with
      | O => seed
      | S n' => n * (fact_seed seed n')
    end.
  Functional Scheme fact_seed_ind := Induction for fact_seed Sort Prop.

  Theorem fact_seed__fact_aux: forall n acc,
      fact_seed acc n = fact_aux acc n.
  Proof.
    intros.
    functional induction (fact_seed acc n).
    - simpl. reflexivity.
    - simpl (fact_aux acc (S n')).
      symmetry.
      rewrite mult_comm.
      rewrite <- fact_aux_assoc.
      rewrite IHn0.
      reflexivity.
  Qed.

  Theorem fact_tr_div: forall n acc,
      n > 0 -> Nat.divide n (fact_aux acc n).
  Proof.
    intros * Ngt0.
    destruct n as [| n'].
    - inversion Ngt0.
    - simpl.

  Restart.
    intros * Ngt0.
    rewrite <- fact_seed__fact_aux.
    destruct n as [| n'].
    - inversion Ngt0.
    - unfold fact_seed; fold fact_seed.
      apply Nat.divide_factor_l.
  Qed.