Require Import Arith.

(** [sum_cubes_to n] is [0*0*0 + 1*1*1 + ... + n*n*n]. **)
Fixpoint sum_cubes_to (n: nat) : nat :=
  match n with
  | 0 => 0
  | S n' => n * n * n + sum_cubes_to (n')
  end.

(** [sum_to n] is [0 + 1 + ... + n]. **)
Fixpoint sum_to (n: nat): nat :=
  match n with
  | 0 => 0
  | S n' => n + sum_to (n')
  end.

(* Other lemmas and theorems. *)
Lemma add_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n. induction n as [ | n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite -> IHn'. reflexivity.  Qed.

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

Lemma add_comm : forall n p : nat,
  n + p = p + n.
Proof.
  intros n m.
  induction n as [| n' IHn'].
  - simpl. rewrite -> add_0_r. reflexivity.
  - simpl. rewrite <- plus_n_Sm. rewrite -> IHn'. reflexivity.
Qed.

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

Lemma add_0_l: forall n: nat, 0 + n = n.
Proof.
  intro n.
  rewrite add_comm. rewrite add_0_r. reflexivity.
Qed.

Lemma add_assoc2: forall n m p: nat,
    n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  induction n as [| n' IHn'].
  - rewrite -> add_comm. rewrite -> add_0_r. rewrite -> add_0_l. reflexivity.
  - simpl. rewrite <- plus_n_Sm. rewrite IHn'. reflexivity.
Qed.

Lemma add_assoc3: forall n m p q: nat,
    n + m + (p + q) = n + p + (m + q).
Proof.
  intros n m p q.
  induction n as [| n' IHn'].
  - rewrite add_0_l. rewrite add_0_l. rewrite add_assoc2. reflexivity.
  - simpl. inversion IHn'. reflexivity.
Qed.

Lemma mul_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Lemma break_bracket_r: forall n m p: nat,
    n * (m + p) = n * m + n * p.
Proof.
  intros n m p.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. rewrite add_assoc3. reflexivity.
Qed.

Lemma nat_construct: forall n m: nat,
    n + n * m = n * S m.
Proof.
  intros n m.
  induction n as [| n' IHn' ].
  - rewrite add_0_l. reflexivity.
  - simpl. rewrite add_assoc2. rewrite IHn'. reflexivity.
Qed.

Lemma break_bracket_l: forall n m p: nat,
    n * (m + p) = m * n + p * n.
Proof.
  intros n m p.
  induction n as [| n' IHn'].
  - rewrite mul_0_r. rewrite mul_0_r. reflexivity.
  - simpl. rewrite -> IHn'. rewrite add_assoc3.
    rewrite nat_construct. rewrite nat_construct.
    reflexivity.
Qed.

Lemma plus_n_Sn'': forall n: nat,
    n + 1 = S n.
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl. inversion IHn'. reflexivity.
Qed.

Lemma foil: forall n m p q: nat,
    (n + m) * (p + q) = n * p + n * q + m * p + m * q.
Proof.
  intros. ring. (* Better take an Abstract Algebra class after this. *)
Qed.
(* I need to finish second_equality to finish this thing. *)

Lemma assocForFour: forall n m p q: nat,
    n + m + p + q = n + p + m + q.
Proof.
  intros n m p q.
  ring.
Qed.

(** The most important parts. **)

Lemma gauss_sum_integers: forall n: nat,
    2 * sum_to n = n * (n + 1).
Proof.
  (* IHn': Induction hypothesis n = k. *)
  induction n as [| n' IHn'].
  - (* Base case: n = 0 *) simpl. reflexivity.
  - (* Recursive case: n = k + 1 *)
    unfold sum_to. fold sum_to.
    rewrite break_bracket_r.
    assert (H: S n' = n' + 1).
    {rewrite plus_n_Sn''. reflexivity.}
    rewrite H.
    assert(H': n' + 1 + 1 = n' + 2).
    {ring.}
    rewrite H'.
    rewrite foil.
    rewrite assocForFour.
    rewrite <- break_bracket_l.
    assert(H'': 2 * (n' + 1) = n' * 2 + 1 * 2).
    {rewrite <- break_bracket_l. reflexivity.}
    rewrite H''.
    rewrite IHn'.
    rewrite add_comm.
    ring.
Qed.

Theorem sum_cubes: forall n: nat,
    sum_cubes_to n = sum_to n * sum_to n.
Proof.
    (* IHn': Induction hypothesis n = k. *)
    induction n as [|n' IHn'].
    - (* Base case: n = 0 *) simpl. reflexivity.
    - (* Recursive case: n = k + 1 *)
    unfold sum_cubes_to. unfold sum_to.
    fold sum_cubes_to. fold sum_to.
    rewrite IHn'. rewrite foil.
    assert(H: S n' * S n' +  S n' * sum_to n' + sum_to n' * S n'
              = S n' * S n' + S n' * (sum_to n' + sum_to n')).
    {ring.}
    rewrite H.
    assert(H': sum_to n' + sum_to n' = 2 * sum_to n').
    {simpl. rewrite add_0_r. reflexivity.}
    rewrite H'.
    rewrite gauss_sum_integers.
    rewrite plus_n_Sn''.
    assert (mult_comm: S n' * (n' * S n') = S n' * S n' * n').
    {ring.}
    rewrite mult_comm.
    assert (mult_iden: S n' * S n' + S n' * S n' * n' = S n' * S n' * (n' + 1)).
    {simpl. ring.}
    rewrite mult_iden.
    rewrite plus_n_Sn''.
    reflexivity.
Qed.


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

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

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

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

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

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

End imp_sample.
(** 課題４：命題論理の証明 *)
(* 証明せよ *)
Section Ex4.
Variable A B C D:Prop.
Theorem ex4_1 : (A -> C) /\ (B -> D) /\ A /\ B -> C /\ D.
Proof.
  intro H.
  destruct H as [ac [bd [a b]]].
  split.
    apply ac. assumption.
    apply bd. assumption.
Qed.

Theorem ex4_2 : ~~~A -> ~A.
Proof.
  intro nnna.
  intro a.
  elim nnna.
  intro na.
  elim na.
  assumption.
Qed.

Theorem ex4_3 : (A -> B) -> ~B -> ~A.
Proof.
  intros ab nb.
  intro a.
  elim nb.
  apply ab.
  assumption.
Qed.

Theorem ex4_4 : ((((A -> B) -> A) -> A) -> B) -> B.
Proof.
  intro H.
  apply H.
  intro H1.
  apply H1.
  intro a.
  apply H.
  intro H2.
  assumption.
Qed.

Theorem ex4_5 : ~~(A\/~A).
Proof.
  intro H.
  elim H.
  right.
  intro a.
  elim H.
  left.
  assumption.
Qed.

End Ex4.
End Section4.


Require Import Arith.

Fixpoint div3 (n:nat): nat :=
  match n with 0 => 0 | 1 => 0 | 2 => 0 |
               (S (S (S p))) => (S (div3 p))
          end.

Section div3_proof.
 Let P (n:nat) := div3 n <= n.

 Remark P_ok : forall n : nat, P n /\ P (S n) /\ P (S (S n)).
 Proof.
  simple induction n.
  unfold P; simpl ; auto.
  intros n0 [H1 [H2 H3]].
  repeat split; auto.
  unfold P; simpl; auto with arith.
Qed.

 Lemma div3_le : forall n : nat, div3 n <= n.
 Proof.
  intro n; case (P_ok n); auto.
 Qed.

End div3_proof.


Theorem mul_0_r :
  forall (n : nat), n * 0 = 0.
intros.
induction n as [| n' IHn'].
- reflexivity.
- simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_n_Sm :
  forall (n m : nat), S (n + m) = n + S m.
intros.
induction n as [|n' IHn'].
- simpl.
  reflexivity.
- simpl.  (* TODO: what happened here?! *)
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem plus_n_0 :
  forall (n : nat), n + 0 = n.
intros.
induction n as [|n' IHn'].
- unfold "+".
  reflexivity.
- simpl.
  rewrite IHn'.
  reflexivity.
Qed.

Lemma plus_S :
  forall (m n : nat), S (m + n) = m + S n.
intros.
induction m as [|n' IHn'].
- simpl.
  reflexivity.
- simpl.
  rewrite IHn'.
  reflexivity.
Qed.

Theorem add_comm :
  forall (n m : nat), n + m = m + n.
intros.
induction n as [|n' IHn'].
- simpl.
  rewrite -> plus_n_0.
  reflexivity.
- simpl.
  rewrite IHn'.
  rewrite <- plus_S.
  reflexivity.
Qed.

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

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

Lemma double_plus : forall (n : nat), double n = n + n.
intros.
induction n as [|n' IHn'].
- (* n = 0 *)
  reflexivity.
- (* n = S n' *)
  simpl.
  rewrite IHn'.
  rewrite -> plus_S.
  reflexivity.
Qed.

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

Theorem even_S :
  forall (n : nat), even (S n) = negb (even n).
intros.
induction n as [|n' IHn'].
- simpl.
  reflexivity.
Admitted.

(*
Theorem: For any natural n and m,
  n + m = m + n.
Proof: By unduction on n.
* First suppose n = 0. We must show that
    0 + m = m + 0.
This follows directly from definition of + (?!).
* Next, suppose n = S n' and
  n' + m = m + n'.
We must show that
  S n' + m = m + S n'.
Following definition of +, we can rewrite LHS as
  S (n' + m)
which, according to inductive hypothesis, is the same as
  S (m + n')
which, as prooved in preceeding lemma, can be rewritten as
  m + S n'.
We thus have a trivial equality.
Qed.
*)

Theorem add_shuffle3 :
  forall (n m p : nat), n + (m + p) = m + (n + p).
Proof.
intros.
assert (n + (m + p) = (m + p) + n) as H.
- rewrite add_comm.
  reflexivity.
- rewrite H.
  rewrite add_assoc.
  assert (H1: n + p = p + n).
  + rewrite add_comm. reflexivity.
  + rewrite H1. reflexivity.
Qed.

Lemma mult_0:
  forall (n : nat), n * 0 = 0.
Proof.
intros.
induction n as [|n' IHn'].
- reflexivity.
- simpl.
  rewrite IHn'.
  reflexivity.
Qed.

Lemma add_0:
  forall (n : nat), n + 0 = n.
Proof.
intros.
induction n as [|n' IHn'].
- simpl.
  reflexivity.
- simpl.
  rewrite IHn'.
  reflexivity.
Qed.

Lemma mult_S_lhs:
  forall (n m : nat), S n * m = n * m + m.
Proof.
intros.
destruct n.
- simpl.
  rewrite -> add_0.
  reflexivity.
- simpl.
  rewrite add_assoc.
  assert (H: m + n * m = n * m + m).
  + rewrite add_comm.
    reflexivity.
  + rewrite H.
    reflexivity.
Qed.

Lemma mult_S_rhs:
  forall (n m : nat), n * S m = n + n * m.
Proof.
intros.
induction n as [|n' IHn'].
- simpl.
  reflexivity.
- simpl.
  rewrite IHn'.
  rewrite add_shuffle3.
  reflexivity.
Qed.

Theorem mul_comm:
  forall (n m : nat), n * m = m * n.
Proof.
intros.
induction n as [|n' IHn'].
- simpl.
  rewrite -> mult_0.
  reflexivity.
- simpl.
  rewrite IHn'.
  rewrite mult_S_rhs.
  reflexivity.
Qed.

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

Check leb.

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

Theorem leb_refl :
  forall (n : nat), n <=? n = true.
Proof.
intros.
induction n as [|n' IHn'].
- simpl.
  reflexivity.
- simpl.
  rewrite IHn'.
  reflexivity.
Qed.

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

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

Theorem zero_negb_S :
  forall (n : nat),
  0 =? (S n) = false.
Proof.
intros.
unfold "=?".
reflexivity.
Qed.

Definition andb (a b : bool) : bool :=
  match a, b with
  | false, _ => false
  | _, false => false
  | _, _     => true
  end.

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

Theorem plus_leb_compat_l :
  forall (n m p : nat), n <=? m = true -> (p + n) <=? (p + m) = true.
Proof.
intros.
induction p as [|p' IHp']; simpl; assumption.
Qed.

Theorem S_neqb_0 :
  forall (n : nat), S n =? 0 = false.
Proof.
intros.
unfold "=?".
reflexivity.
Qed.

Theorem mult_1_1 :
  forall (n : nat), 1 * n = n.
Proof.
intros.
unfold "*".
rewrite plus_n_0.
reflexivity.
Qed.

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

Theorem mult_plus_distr_r :
  forall (n m p : nat),
  (n + m) * p = n * p + m * p.
Proof.
intros.
induction p as [|p' IHp'].
Admitted. (* Too boring ... *)

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

Theorem eqb_refl :
  forall (n : nat), n =? n = true.
Proof.
intros.
induction n as [|n' IHn'].
- unfold "=?".
  reflexivity.
- simpl. (* TODO: what happens here ?! *)
  assumption.
Qed.

Theorem add_shuffle3' :
  forall (n m p : nat), n + (m + p) = m + (n + p).
Proof.
intros.
replace (n + (m + p)) with ((m + p) + n).
- rewrite add_assoc.
  replace (p + n) with (n + p); rewrite add_comm; reflexivity.
- rewrite add_comm.
  reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B_0 (n : bin)
  | B_1 (n : bin).

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z      => B_1 Z
  | B_0 m' => B_1 m'
  | B_1 m' => B_0 (incr m')
  end.

Fixpoint bin2nat (m : bin) : nat :=
  match m with
  | Z      => O
  | B_0 m' => 2 * bin2nat m'
  | B_1 m' => 2 * bin2nat m' + 1
  end.

Lemma plus_1_is_S :
  forall (n : nat),
  n + 1 = S n.
Proof.
intros.
rewrite add_comm.
unfold "+".
reflexivity.
Qed.

Theorem binary_commute :
  forall (b : bin), bin2nat (incr b) = S (bin2nat b).
Proof.
intros.
induction b.
- simpl.
  reflexivity.
- unfold incr.
  simpl.
  rewrite plus_1_is_S.
  reflexivity.
- simpl.
  rewrite IHb.
  simpl.
  rewrite add_0.
  replace (S (bin2nat b)) with (bin2nat b + 1).
  + rewrite add_assoc.
    reflexivity.
  + rewrite plus_1_is_S.
    reflexivity.
Qed.

(* TODO: binary inverse *)


Require Import Arith fib_ind.

(* A generalisation of the fibonacci sequence, parameterized by
   its two first items *)

Fixpoint general_fib (a0 a1 n:nat) {struct n} : nat :=
  match n with
  | O => a0
  | S p => general_fib a1 (a0 + a1) p
  end.

Definition fib_tail (n:nat) := general_fib 1 1 n.

(** Test : should return 89

Compute fib_tail 10.

*)

Lemma general_fib_1 : forall a b:nat, general_fib a b 1 = b.
Proof. reflexivity. Qed.

Lemma general_fib_S :
 forall a b n:nat, general_fib a b (S n) = general_fib b (a + b) n.
Proof. reflexivity. Qed.

Lemma general_fib_2 :
 forall a b n:nat,
   general_fib a b (S (S n)) = general_fib a b n + general_fib a b (S n).
Proof.
 intros a b n; generalize a b; induction n as [ | n IHn].
 - reflexivity.
 - clear a b; intros a b.
   rewrite (general_fib_S _ _ (S (S n))), IHn.
   now rewrite (general_fib_S _ _  (S n)).
Qed.

Lemma linear_fibo_equiv : forall n:nat, fib_tail n = fib n.
Proof.
 intro n; induction n as [| | n IHn IHSn] using fib_ind.
 - reflexivity.
 - reflexivity.
 -  unfold fib_tail in *; rewrite general_fib_2.
    rewrite IHn, IHSn; reflexivity.
Qed.


Require Import Recdef PeanoNat Lia.

(* [Z] to 0, [L n] to 2n + 1, a [R n] to 2n + 2. *)
Inductive Nat : Type :=
| Z : Nat
| L : Nat -> Nat
| R : Nat -> Nat.

Function succ (n : Nat) : Nat :=
match n with
| Z => L Z
| L n' => R n'
| R n' => L (succ n')
end.

Function pred (n : Nat) : Nat :=
match n with
| Z => Z
| L Z => Z
| L n' => R (pred n')
| R n' => L n'
end.

Function add (n m : Nat) : Nat :=
match n, m with
| Z   , _    => m
| _   , Z    => n
| L n', L m' => R (add n' m')
| L n', R m' => succ (R (add n' m'))
| R n', L m' => succ (R (add n' m'))
| R n', R m' => R (succ (add n' m'))
end.

Function div2 (n : Nat) : Nat :=
match n with
| Z => Z
| L n' => n'
| R n' => succ n'
end.

Function mul2 (n : Nat) : Nat :=
  pred (L n).

Function mul (n m : Nat) : Nat :=
match n with
| Z    => Z
| L n' => add (mul2 (mul n' m)) m
| R n' => mul2 (add (mul n' m) m)
end.

Function sub (n m : Nat) : Nat :=
match n, m with
| Z   , _    => Z
| _   , Z    => n
| L n', L m' => mul2 (sub n' m')
| L n', R m' => pred (mul2 (sub n' m'))
| R n', L m' => succ (mul2 (sub n' m'))
| R n', R m' => mul2 (sub n' m')
end.

Function le (n m : Nat) : bool :=
match n, m with
| Z   , _    => true
| _   , Z    => false
| L n', L m' => le n' m'
| L n', R m' => le n' m'
| R n', L m' => false (* 2n <= 2m -1 *)
| R n', R m' => le n' m'
end.

Definition L' (n : nat) : nat :=
  1 + 2 * n.

Definition R' (n : nat) : nat :=
  2 + 2 * n.

Function fromNat (n : Nat) : nat :=
match n with
| Z => 0
| L n' => L' (fromNat n')
| R n' => R' (fromNat n')
end.

Function toNat (n : nat) : Nat :=
match n with
| 0 => Z
| S n' => succ (toNat n')
end.

Compute fromNat (L (L (L (L Z)))).
Compute fromNat (R (R (R (R Z)))).
Compute fromNat (R (R (L (R Z)))).

Compute fromNat (succ (L (L (L (L Z))))).
Compute fromNat (succ (R (R (R (R Z))))).
Compute fromNat (succ (R (R (L (R Z))))).

Compute fromNat (pred (L (L (L (L Z))))).
Compute fromNat (pred (R (R (R (R Z))))).
Compute fromNat (pred (R (R (L (R Z))))).

Compute fromNat (div2 (L (L (L (L Z))))).
Compute fromNat (div2 (R (R (R (R Z))))).
Compute fromNat (div2 (R (R (L (R Z))))).

Compute fromNat (mul2 (L (L (L (L Z))))).
Compute fromNat (mul2 (R (R (R (R Z))))).
Compute fromNat (mul2 (R (R (L (R Z))))).

Lemma pred_succ :
  forall n : Nat,
    pred (succ n) = n.
Proof.
  intros n; functional induction (succ n); cbn.
  1-2: reflexivity.
  rewrite IHn0; clear IHn0.
  destruct n'; cbn; reflexivity.
Qed.

Lemma div2_mul2 :
  forall n : Nat,
    div2 (mul2 n) = n.
Proof.
  intros n; functional induction (mul2 n); cbn.
  induction n as [| n' | n']; cbn.
  1, 3: reflexivity.
  rewrite <- IHn' at 2.
  destruct n'; cbn in *; reflexivity.
Qed.

Lemma fromNat_succ :
  forall n : Nat,
    fromNat (succ n) = S (fromNat n).
Proof.
  intros n; functional induction (fromNat n); cbn; lia.
Qed.

Lemma fromNat_toNat :
  forall n : nat,
    fromNat (toNat n) = n.
Proof.
  intros n; functional induction (toNat n); cbn.
  - reflexivity.
  - rewrite fromNat_succ, IHn0. reflexivity.
Qed.

Lemma L'_S :
  forall n : nat,
    L' (S n) = 2 + L' n.
Proof.
  intros; cbn; lia.
Qed.

Lemma R'_S :
  forall n : nat,
    R' (S n) = 3 + L' n.
Proof.
  intros; cbn; lia.
Qed.

Lemma toNat_L' :
  forall n : nat,
    toNat (L' n) = L (toNat n).
Proof.
  induction n as [| n'].
  - reflexivity.
  - rewrite L'_S.
    change (toNat (2 + _)) with (succ (succ (toNat (L' n')))).
    rewrite IHn'; cbn. reflexivity.
Qed.

Lemma toNat_R' :
  forall n : nat,
    toNat (R' n) = R (toNat n).
Proof.
  induction n as [| n'].
  - reflexivity.
  - rewrite R'_S.
    change (toNat (3 + _)) with (succ (succ (toNat (R' n')))).
    rewrite IHn'; cbn. reflexivity.
Qed.

Lemma toNat_fromNat :
  forall n : Nat,
    toNat (fromNat n) = n.
Proof.
  intros n; functional induction (fromNat n).
  - reflexivity.
  - rewrite toNat_L', IHn0. reflexivity.
  - rewrite toNat_R', IHn0. reflexivity.
Qed.

Lemma add_Z_l :
  forall n : Nat,
    add Z n = n.
Proof. reflexivity. Qed.

Lemma add_Z_r :
  forall n : Nat,
    add n Z = n.
Proof.
  intros []; reflexivity.
Qed.

Lemma add_succ_l :
  forall n m : Nat,
    add (succ n) m = succ (add n m).
Proof.
  intros n m; functional induction (add n m)
  ; cbn; rewrite ?IHn0.
  3-6: reflexivity.
  - destruct m; reflexivity.
  - destruct n; reflexivity.
Qed.

Lemma add_succ_r :
  forall n m : Nat,
    add n (succ m) = succ (add n m).
Proof.
  intros n m; functional induction (add n m)
  ; cbn; rewrite ?IHn0.
  3-6: reflexivity.
  - destruct m; reflexivity.
  - destruct n; cbn; rewrite ?add_Z_r; reflexivity.
Qed.

Lemma add_comm :
  forall n m : Nat,
    add n m = add m n.
Proof.
  intros n m; functional induction (add n m)
  ; cbn; rewrite ?add_Z_r, ?IHn0; reflexivity.
Qed.

Lemma add_assoc :
  forall a b c : Nat,
    add (add a b) c = add a (add b c).
Proof.
  intros a b.
  functional induction (add a b); cbn; intros.
  1-2: reflexivity.
  all: destruct c; cbn; rewrite ?add_succ_l, ?add_succ_r, ?IHn; reflexivity.
Qed.

Lemma mul_Z_l :
  forall n : Nat,
    mul Z n = Z.
Proof. reflexivity. Qed.

Lemma mul_Z_r :
  forall n : Nat,
    mul n Z = Z.
Proof.
  induction n as [| n' IH | n' IH]; cbn.
  - reflexivity.
  - rewrite IH; cbn. reflexivity.
  - rewrite IH; cbn. reflexivity.
Qed.

Lemma fromNat_add :
  forall n m : Nat,
    fromNat (add n m) = fromNat n + fromNat m.
Proof.
  intros n m; functional induction (add n m)
  ; cbn; rewrite ?fromNat_succ; lia.
Qed.

Lemma fromNat_pred :
  forall n : Nat,
    fromNat (pred n) = fromNat n - 1.
Proof.
  intros n; functional induction (pred n); simpl.
  1-2: reflexivity.
  - rewrite IHn0. destruct n'; cbn; lia.
  - unfold L'. lia.
Qed.

Lemma fromNat_mul2 :
  forall n : Nat,
    fromNat (mul2 n) = 2 * fromNat n.
Proof.
  intros n; unfold mul2.
  rewrite fromNat_pred.
  cbn; lia.
Qed.

Lemma fromNat_mul :
  forall n m : Nat,
    fromNat (mul n m) = fromNat n * fromNat m.
Proof.
  intros n m; functional induction (mul n m); simpl.
  - reflexivity.
  - rewrite fromNat_add, fromNat_mul2, IHn0. lia.
  - rewrite fromNat_mul2, fromNat_add, IHn0. lia.
Qed.

Lemma mul_L_r :
  forall n m : Nat,
    mul n (L m) = add (mul2 (mul m n)) n.
Proof.
  induction n as [| n' IH | n' IH]; simpl; intros m.
  - rewrite mul_Z_r; cbn; reflexivity.
Admitted.

Lemma mul_R_r :
  forall n m : Nat,
    mul n (R m) = mul2 (add (mul m n) n).
Proof.
  induction n as [| n' IH | n' IH]; simpl; intros m.
  - rewrite mul_Z_r; cbn; reflexivity.
Admitted.

Lemma mul_comm :
  forall n m : Nat,
    mul n m = mul m n.
Proof.
  intros n m.
  rewrite <- toNat_fromNat, fromNat_mul, Nat.mul_comm, <- fromNat_mul, toNat_fromNat.
  reflexivity.
Qed.

Lemma fromNat_L :
  forall n : Nat,
    fromNat (L n) = L' (fromNat n).
Proof. reflexivity. Qed.

Lemma fromNat_R :
  forall n : Nat,
    fromNat (R n) = R' (fromNat n).
Proof. reflexivity. Qed.

Lemma fromNat_sub :
  forall n m : Nat,
    fromNat (sub n m) = fromNat n - fromNat m.
Proof.
  intros n m; functional induction (sub n m)
  ; rewrite ?fromNat_L, ?fromNat_R, ?fromNat_succ, ?fromNat_pred, ?fromNat_mul2, ?IHn0
  ; unfold L', R'.
  1-4, 6: cbn; lia.
Admitted.


Require Import Arith.
Require Import ZArith.

Parameters (prime_divisor : nat -> nat)
           (prime : nat -> Prop)
           (divides : nat -> nat -> Prop).

Open Scope nat_scope.

Check (prime (prime_divisor 220)).

Check (divides (prime_divisor 220) 220).

Check (divides 3).

(* Parameterized Data Types *)

Parameter binary_word : nat -> Set.

Definition short : Set := binary_word 32.

Definition long : Set := binary_word 64.

(* Exercise 4.1 *)
Check ((nat -> nat) -> Prop). (* Compare if two naturals are equal *)
Check ((nat -> nat) -> (nat -> nat) -> Prop). (* Compare if two functions are
equal *)
Check (nat -> nat -> Set). (* Given two naturals m and n, return the type of
an m x n matrix *)

Print not.

Require Import List.

Parameters (decomp : nat -> list nat) (decomp2 : nat -> nat * nat).

Check (decomp 220).
Check (decomp2 284).

Check @cons.
Check @pair.
Check @fst.

Check le_n.
Check le_S.

Check (le_n 36).

(* Definition of Polymorphic Functions *)

Definition twice : forall A : Set, (A -> A) -> A -> A :=
  fun A f a => f (f a).

Check (twice Z).

Check (twice Z (fun z => (z*z)%Z)).

Check (twice _ S 56).

Check (twice (nat -> nat) (fun f x => f (f x)) (mult 3)).

Eval compute in
  (twice (nat -> nat) (fun f x => f (f x)) (mult 3) 1).

(* Proofs - Curry-Howard isomorphism *)
Theorem le_i_SSi : forall i : nat, i <= S (S i).
Proof (fun i : nat => le_S _ _ (le_S _ _ (le_n i))).

(* Expressive power of the Dependent Product *)

(* Exercise 4.3 *)
Section A_declared.
  Variables (A : Set) (P Q : A -> Prop) (R : A -> A -> Prop).

  Theorem all_perm : (forall a b : A, R a b) -> forall a b : A, R b a.
  Proof (fun (H : forall a b : A, R a b) (a b : A) => H b a).

  Theorem all_imp_dist :
    (forall a : A, P a -> Q a) -> (forall a : A, P a) -> forall a : A, Q a.
  Proof (fun (H : forall a : A, P a -> Q a)
             (H' : forall a : A, P a)
             (a : A) => H a (H' a)).

  Theorem all_delta : (forall a b : A, R a b) -> forall a : A, R a a.
  Proof (fun (H : forall a b : A, R a b)
             (a : A) => H a a).

End A_declared.

(* Exercise 4.4 *)
Theorem id : forall A : Set, A -> A.
Proof (fun (A : Set) (a : A) => a).
Print id.

Theorem diag : forall A B : Set, (A -> A -> B) -> A -> B.
Proof (fun (A B : Set) (f : A -> A -> B) (a : A) => (f a) a).
Print diag.

Theorem permute : forall A B C : Set, (A -> B -> C) -> B -> A -> C.
Proof (fun (A B C : Set) (f : A -> B -> C) (b : B) (a : A) => f a b).
Print permute.

Theorem f_nat_Z : forall A : Set, (nat -> A) -> Z -> A.
Proof (fun (A : Set) (f : nat -> A) (z : Z) => f (Zabs_nat z)).
Print f_nat_Z.

(* Exercise 4.5 *)
Theorem all_perm' :
  forall (A : Type) (P : A -> A -> Prop),
  (forall x y : A, P x y) -> forall x y : A, P y x.
Proof (fun (A : Type)
      (P : A -> A -> Prop)
      (H : forall x y : A, P x y) (x y : A) => H y x).
Print all_perm'.

Theorem resolution :
  forall (A : Type) (P Q R S : A -> Prop),
  (forall a : A, Q a -> R a -> S a) ->
  (forall b : A, P b -> Q b) ->
  (forall c : A, P c -> R c -> S c).
Proof.
  intros A P Q R S H H' c HPc HRc.
  apply H; [apply H'; assumption | assumption].
Qed.
Print resolution.

(* Equality in the Coq System *)

Check @eq.
Check @refl_equal.

Theorem ThirtySix : 9*4 = 6*6.
Proof (refl_equal 36).

Check eq_sym.
Print eq_sym.

Theorem eq_sym' : forall (A : Type) (x y : A), x = y -> y = x.
Proof.
  intros A x y H.
  rewrite H. reflexivity.
Qed.

Print eq_sym'.

Print and.
Print or.


(*
   再帰関数と CPS との等価性の証明。単純版
   （ひとつ前の値だけを使う再帰には、同じフレームワークで
   対応できるが、fibは不完全である）
   2010_10_30
   *)

Inductive tree : Set :=
| leaf : tree
| node : tree->tree->tree.
Eval cbv in node (node leaf leaf) (node leaf leaf).

(* 再帰版 *)
Fixpoint leaf_count (t : tree) : nat :=
  match t with
    | leaf => 1
    | node r l => (leaf_count r) + (leaf_count l)
  end.
Eval cbv in leaf_count (node (node leaf leaf) (node leaf leaf)). (* 4 *)

(* CPS版 *)
Fixpoint leaf_count_cps (t : tree) (cont : nat -> nat) : nat :=
  match t with
    | node r l =>
      leaf_count_cps r
      (fun n => leaf_count_cps l
        (fun m => cont (n + m)))
    | leaf =>
      cont 1
  end.
Eval cbv in leaf_count_cps (node (node leaf leaf) (node leaf leaf)) (fun n => n). (* 4 *)
Eval cbv in leaf_count_cps (node (node (node leaf leaf) (node leaf leaf))
  (node leaf (node leaf leaf))) (fun n => n). (* 7 *)

Eval cbv in leaf_count_cps (node leaf leaf) (fun (r:nat) => r).   (* 2 *)
Eval cbv in leaf_count_cps leaf
  (fun (n1:nat) => leaf_count_cps leaf
    (fun (n2:nat) => n1 + n2)).             (* 2 *)

Lemma leaf_count_cps_plus :
  forall l r f,
    leaf_count_cps (node l r) f =
    leaf_count_cps l (fun n1:nat => leaf_count_cps r (fun n2:nat => f (n1 + n2))).
Proof.
  intros.
  simpl.
  (* このGoalの左辺が右辺とおなじになるように、定理を用意するのだ。*)
  reflexivity.
Qed.

Theorem eq_leaf_count_leaf_count_cps :
  forall (t : tree),
    (forall f, f (leaf_count t) = (leaf_count_cps t f)).
Proof.
    induction t.
    intros.
    simpl.
    reflexivity.

    intro f.
    rewrite leaf_count_cps_plus.
    rewrite <- IHt1.
    rewrite <- IHt2.
    simpl.
    reflexivity.
Qed.

(***************)
(* List Length *)
(***************)
Require Export List.

(* 再帰版 *)
Fixpoint len (lst : list nat) :=
   match lst with
     | nil => 0
     | hd :: tl => S (len tl)
   end.
Eval cbv in len (1::2::3::4::nil).

(* CPS版 *)
Fixpoint len_cps (lst : list nat) (cont : nat -> nat) :=
   match lst with
     | nil => cont 0
     | hd :: tl => len_cps tl (fun x => cont (S x))
   end.
Eval cbv in len_cps (1::2::3::4::nil) (fun n:nat => n).

Lemma len_cps_Sn :
  forall n l f,
    len_cps (n::l) f =
    len_cps l (fun (r:nat) => f (S r)).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Theorem eq_len_len_cps :
  forall (t : list nat),
    (forall f, f (len t) = (len_cps t f)).
Proof.
    induction t.
    intros.
    simpl.
    reflexivity.

    intro f.
    rewrite len_cps_Sn.
    rewrite <- IHt.
    simpl.
    reflexivity.
Qed.

(************)
(* 階乗     *)
(************)

(* 階乗の再帰版 *)
Fixpoint fact (n : nat) : nat :=
  match n with
    | 0 => 1
    | (S n') => n * fact n'
  end.
Eval cbv in fact 6.                         (* 720 *)

(* CPS 版 *)
Fixpoint fact_cps (n : nat) (cont : nat -> nat) : nat :=
  match n with
    | 0 => cont 1
    | (S n') => fact_cps n' (fun (a : nat) => cont (n * a))
  end.
Eval cbv in fact_cps 6 (fun a => a).        (* 720 *)

Lemma fact_cps_Sn :
  forall n f,
    fact_cps (S n) f =
    fact_cps n (fun (r:nat) => (f (S n * r))).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

(* fact_cps_Sn の実験 *)
Eval cbv in fact_cps 6 (fun (r:nat) => r).  (* 720 *)
Eval cbv in fact_cps 5 (fun (r:nat) => (6 * r)). (* 720 *)

Theorem eq_fact_fact_cps :
  forall (n:nat),
    (forall f, f (fact n) = fact_cps n f).
Proof.
  induction n.
  intros.
  simpl.
  reflexivity.

  intro f.
  rewrite fact_cps_Sn.
  rewrite <- IHn.
  simpl.
  reflexivity.
Qed.

(******************)
(* フィボナッチ数 *)
(******************)

(** 普通のフィボナッチ関数の定義 *)
Fixpoint fib (n: nat) : nat :=
  match n with
    | 0 => 1
    | 1 => 1
    | S (S m as sm) => fib sm + fib m
  end.

(** CPS変換されたフィボナッチ関数の定義 *)
Fixpoint fib_cps (n:nat) (cont:nat -> nat) : nat :=
  match n with
    | 0 =>  cont 1
    | 1 =>  cont 1
    | S (S m as sm) =>
      fib_cps sm (fun r1 =>
        fib_cps m (fun r2 => cont (r1 + r2)))
  end.

Lemma fib_SSn : forall n, fib (S (S n)) = fib (S n) + fib n.
  reflexivity.
Qed.

Lemma fib_cps_SSn :
  forall n f,
    fib_cps (S (S n)) f = fib_cps (S n) (fun r1 => fib_cps n (fun r2 => f (r1+r2))).
Proof.
  reflexivity.
Qed.

Hypothesis eq_fib_fib_cps_SSn :             (* XXXX *)
  forall n f,
    f (fib (S (S n))) = fib_cps n (fun r2 : nat => f (fib (S n) + r2)).

Theorem eq_fib_fib_cps :
  forall n f, f (fib (S n)) = fib_cps (S n) f.
Proof.
  induction n.
  intros.
  simpl.
  reflexivity.

  intro f.
  rewrite fib_cps_SSn.
  rewrite <- IHn.
  apply eq_fib_fib_cps_SSn.                 (* XXXX *)
Qed.

(* END *)


Section Nat.

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

Fixpoint plus (n : nat) (m : nat) :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.
Compute plus (S (S (S O))) (S (S O)).
Compute plus (S (S (S O))) O.
Notation "x + y" := (plus x y)
  (at level 50, left associativity): nat_scope.
Check ((0 + 1) + 1).

Fixpoint mult (n : nat) (m : nat) :=
  match n with
    | O => O
    | S n' => m + (mult n' m)
  end.
Compute mult 4 2.

Fixpoint eqb (n m : nat) :=
  match n with
  | O =>
    match m with
      | O => true
      | S m' => false
      end
  | S n' =>
    match m with
      | O => false
      | S m' => eqb n' m'
      end
  end.
Notation "x =? y" := (eqb x y)
  (at level 50, left associativity): nat_scope.

Fixpoint leb (n m : nat) :=
  match n with
  | O => true
  | S n' =>
    match m with
      | O => false
      | S m' => leb n' m'
      end
  end.
Notation "x <=? y" := (leb x y)
  (at level 50, left associativity): nat_scope.

Theorem plus_O_n : forall n:nat, 0 + n = n.
Proof. intros n. simpl. reflexivity. Qed.

Theorem plus_n_0 : forall n:nat, n + 0 = n.
Proof.
  induction n as [| n' IH].
  - reflexivity.
  - simpl.
    rewrite IH.
    reflexivity.
Qed.

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

Theorem plus_transitive: forall n m: nat, n + m = m + n.
Proof.
  induction m as [|m' ihm].
  - apply plus_n_0.
  - give_up.
Admitted.

Theorem mult_0_n : forall n : nat, 0 * n = 0.
Proof. intros n. simpl. reflexivity. Qed.

Theorem mult_n_0 : forall n : nat, n * 0 = 0.
Proof.
  induction n as  [| n' IH].
  - reflexivity.
  - simpl.
    apply IH.
Qed.

Theorem mult_n_0_m_0 : forall n m : nat,
  (n * 0) + (m * 0) = 0.
Proof.
    intros n m.
    rewrite (mult_n_0 n).
    rewrite (mult_n_0 m).
    reflexivity.
Qed.

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

End Nat.


(********************)

(* The final goal of the exercise is to implement a dictionary (aka map).
   We'll do this incrementally by defining auxiliary functions and testing them. *)

Require Import List.
Import ListNotations.

(* The mechanism of sections allows to modularize the proof in multiple ways.
   We'll see its applications along the way. *)
Section NatEq.

  (* Implement a function that checks the equality of two natural numbers.
     Use pattern matching and recursion. *)
  Fixpoint nat_eq (x y: nat): bool :=
    match (x,y) with
    | (S x', S y') => nat_eq x' y'
    | (O, O) => true
    | (_, _) => false
    end.
  (*Admitted.*)
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* We're not _proving_ that our implementations are correct yet,
     but we can still test them on some inputs. *)
  (* Do not modify these test suits. *)
  (* Try to understand the meaning of the 'nat_eq_tests' definition. *)
  (* To do that, you may want to investigate the 'forallb': *)
  Print forallb.
  Let nat_eq_tests := forallb id
                       [ nat_eq 0 0;
                         negb (nat_eq 0 1);
                         negb (nat_eq 10 0);
                         nat_eq 10 10;
                         negb (nat_eq 10 13) ].

  (* Do not modify these '*_pass' definitions and proofs.  *)
  (* If your implementations are correct, the execution of them should proceed, *)
  (* otherwise an error should occur.  *)
  Let nat_eq_tests_pass: nat_eq_tests = true.
  Proof. tauto. Qed.

  (* Now try to remove one of 'negb' in 'nat_eq_tests' definitions *)
  (* and execute nat_eq_tests_pass. *)
  (* Don't forget to restore the initial state of 'nat_eq_tests'. *)

End NatEq.

(* The section hides 'Let' definitions. *)
Fail Print nat_eq_tests_pass.
Print nat_eq.

Section Option.

  (* A value of 'option' type instantiated with an arbitrary type A
     contains either a value of the type A or a special value None. *)
  Print option.

  (* Implement a function that checks if an optional actually contains a value. *)
  (* Use 'if-then-else' syntax: *)
  (* For a value 't' of an inductive type T with exactly two constructors T1 and T2,
     an expression 'if t then X1 else X2' is equivalent to
     'match t with
      | T1 => X1
      | T2 => X2
      end' *)
  Definition has_some {A: Type} (o: option A) : bool :=
    match o with
    | (Some _) => true
    | (Nona) => false
    end.
 (* Replace the previous line with ':= (your implementation) . ' *)

  Let has_some_tests := forallb id
                       [
                         (* here A = nat is inferred because of (1: nat) *)
                         has_some (Some 1);
                       (* note that without an argument we can't automatically infer the type *)
                         negb (has_some (@None nat));
                         has_some (Some (@None bool))
                       ].

  Let has_some_tests_pass: has_some_tests = true.
  Proof. tauto. Qed.

  (* Implement a function that compares two optional natural numbers. *)
  (* Reuse the nat_eq you've defined before *)
  Definition option_nat_eq (o1 o2: option nat) : bool :=
    match (o1,o2) with
    | (Some n1, Some n2) => nat_eq n1 n2
    | (None, None) => true
    | (_, _) => false
    end.

 (* Replace the previous line with ':= (your implementation) . ' *)

  Let option_nat_eq_tests := forallb id
                                     [option_nat_eq None None;
                                     negb (option_nat_eq (Some 5) None);
                                     option_nat_eq (Some 5) (Some 5)
                                     ].

  Let option_nat_eq_tests_pass: option_nat_eq_tests = true.
  Proof. tauto. Qed.

End Option.

Section FunUpd.

  (* A handy primitive we'll use below is the function update. *)
  (* Essentially, we'd like to take a function and override its value on a single input. *)
  (* Here we'll only concentrate on functions whose input type is nat,
     but which are still polymorphic on the output type. *)
  (* Implement the function update using if-then-else expression and nat_eq. *)
  Definition upd {V: Type} (f: nat -> V) (x: nat) (y: V): nat -> V :=
      fun n : nat => if (nat_eq x n) then y else (f n).

 (* Replace the previous line with ':= (your implementation) . ' *)

  Let upd_tests := forallb id
                           [
                             nat_eq ((upd id 5 3) 5) 3;
                             nat_eq ((upd (upd id 5 3) 5 7) 5) 7;
                             nat_eq ((upd id 5 3) 123) 123;
                             nat_eq ((upd (upd id 5 3) 7 10) 5) 3
                           ].

  Let upd_tests_pass: upd_tests = true.
  Proof. tauto. Qed.

End FunUpd.

Section NatDict.
  (* Now we're ready to provide the first implementation of a dictionary. *)
  (* We'll work with dictionaries whose keys are natural numbers
     and values have an arbitrary (but uniform) type. *)

  (* Remember that in previous sections we had to specify arguments like '{A: Type}' to keep the definitions polymorphic. *)
  (* Instead of repeating them, we can specify that a particular type is a common argument for all functions in this section. *)
  Context {V: Type}.

  (* The first implementation of dictionary is based on partial functions. *)
  (* Remember that in Coq all functions are total,
     that is, the function should return a value for all inputs. *)
  (* If we're to implement a dictionary with a total function, it wont' be clear
     how to represent a missing value. *)
  (* But the absence of a value is naturally represented with None,
     while a value 'v' contained in a dictionary can be wrapped in 'Some v' *)
  Definition nat_dict_fun := nat -> option V.
  Print nat_dict_fun. (* Note that here V is fixed *)

  (* Implement a function that creates an empty dictionary *)
  Definition new_dict' : nat_dict_fun
  := fun n : nat => None.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement an insertion using the 'upd' construct. *)
  Definition insert' (d: nat_dict_fun) (k: nat) (v: V) : nat_dict_fun :=
    upd d k (Some v).
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement a deletion similarly. *)
  Definition remove' (d: nat_dict_fun) (k: nat) : nat_dict_fun
    := upd d k None.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement a function that retrieves a value by key. *)
  (* Note that here the usage of option as a return type
     is not due to the partial function implementation,
     but rather due to a common sense:
     if a dictionary (with an arbitrary implementation) doesn't contain a value,
     a retrieval method should somehow reflect it. *)
  Definition get' (d: nat_dict_fun) (k: nat) : option V := d k.
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement a function that checks the presence of a given key. *)
  (* You can either reuse existing dict methods or write an independent implementation. *)
  Definition contains' (d: nat_dict_fun) (k: nat): bool :=
   match (get' d k) with
   | None => false
   | Some _ => true
   end.
 (* Replace the previous line with ':= (your implementation) . ' *)

End NatDict.

Section NatDictTests.

  Print nat_dict_fun. (* note that now nat_dict_fun is polymorphic on value type *)

  (* To save some space we'll define common terms and reuse them
     with 'let .. in ..' syntax. *)
  Let tests :=
    (* Note that we must specify the value type for an empty dictionary,
       since there are no arguments which can be used to infer it *)
    let new := @new_dict' nat in
    let ins5 := insert' new 5 10 in
    let ins5ins5 := insert' ins5 5 15 in
    let ins5rm5 := remove' ins5 5 in
    let ins5ins5rm5 := remove' ins5ins5 5 in
    forallb id
                       [
                         negb (contains' new 5);
                         contains' ins5 5;
                         contains' ins5ins5 5;
                         negb (contains' ins5rm5 5);
                         negb (contains' ins5ins5rm5 5);
                         option_nat_eq (get' new 5) None;
                         option_nat_eq (get' ins5 5) (Some 10);
                         option_nat_eq (get' ins5ins5 5) (Some 15);
                         option_nat_eq (get' ins5ins5rm5 5) None;
                         option_nat_eq (get' ins5 3) None
                       ].

  Let nat_dict_fun_tests_pass: tests = true.
  Proof. tauto. Qed.

End NatDictTests.

Section NatDict'.
  Context {V: Type}.
  (* The other implementation of a dictionary is based on a list
     that stores pairs of keys and values. *)
  (* If there are multiple pairs with the same key,
     the one closer to the list head is used. *)

  (* '*' in context of types means the product (aka pair) type. *)
  Definition nat_dict_list := list (nat * V).

  (* Since the functions below operate on list which is defined inductively,
     some of them should also be inductively defined. *)

  (* Implement a function that creates an empty dictionary. *)
  Definition new_dict'' : nat_dict_list := nil
  .
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the insertion *)
  Definition insert'' (d: nat_dict_list) (k: nat) (v: V) : nat_dict_list :=
    cons (pair k v) d
  .
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the deletion. *)
  (* Mind the case when the list contain multple occurences of the same key. *)
  (* You may find useful that a pattern to be matched can be complex: *)
  (*    '(k, v) :: d'     destructs the list into the head and tail (named d')
     and, additionally, destructs the head into the key 'k' and value 'v' *)
  Fixpoint remove'' (d: nat_dict_list) (k: nat) : nat_dict_list :=
  match d with
  | nil => nil
  | cons h t =>
    if (nat_eq k (fst h))
      then remove'' t k
      else cons h (remove'' t k)
  end
  .
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the retrieval function. *)
  Fixpoint get'' (d: nat_dict_list) (k: nat) : option V :=
  match d with
  | nil => None
  | cons h t =>
    if (nat_eq k (fst h))
      then Some (snd h)
      else (get'' t k)
  end
  .
 (* Replace the previous line with ':= (your implementation) . ' *)

  (* Implement the check for key presence. *)
  Fixpoint contains'' (d: nat_dict_list) (k: nat): bool :=
    match (get'' d k) with
   | None => false
   | Some _ => true
   end
  .
 (* Replace the previous line with ':= (your implementation) . ' *)

End NatDict'.

Section NatDict'Tests.

  (* The tests here are the same as for the previous implementation. *)
  Let tests :=
    let new := @new_dict'' nat in
    let ins5 := insert'' new 5 10 in
    let ins5ins5 := insert'' ins5 5 15 in
    let ins5rm5 := remove'' ins5 5 in
    let ins5ins5rm5 := remove'' ins5ins5 5 in
    forallb id
                       [
                         negb (contains'' new 5);
                         contains'' ins5 5;
                         contains'' ins5ins5 5;
                         negb (contains'' ins5rm5 5);
                         negb (contains'' ins5ins5rm5 5);
                         option_nat_eq (get'' new 5) None;
                         option_nat_eq (get'' ins5 5) (Some 10);
                         option_nat_eq (get'' ins5ins5 5) (Some 15);
                         option_nat_eq (get'' ins5ins5rm5 5) None;
                         option_nat_eq (get'' ins5 3) None
                       ].

  Let nat_dict_list_tests_pass: tests = true.
  Proof. tauto. Qed.

End NatDict'Tests.

(* The tasks below are additional and not required. *)

(* As you can see, these two implementations comply to the same interface. *)
(* Yet, since their types are different, we had to write separate test suites,
   despite they're essentially the same. *)
(* Functional languages allow to specify a general interface with typeclasses. *)
Section DictGeneral.

  (* General interface for a dict polymorphic on value type. *)
  (* This actually defines a type whose elements are interface implementations. *)
  Class Dict := {
    D: Type -> Type;
    new_dict: forall (V: Type), D V;
    insert: forall {V: Type}, (D V) -> nat -> V -> (D V);
    remove: forall {V: Type}, (D V) -> nat -> (D V);
    get: forall {V: Type}, (D V) -> nat -> option V;
    contains: forall {V: Type}, (D V) -> nat -> bool
  }.

  (* Now we can specify expected behavior on the level of this interface. *)
  (* The argument is an arbitrary dict implementation. *)
  Let dict_tests (DictImpl: Dict) : bool :=
    let new := @new_dict DictImpl nat in
    let ins5 := insert new 5 10 in
    let ins5ins5 := insert ins5 5 15 in
    let ins5rm5 := remove ins5 5 in
    let ins5ins5rm5 := remove ins5ins5 5 in
    forallb id
                       [
                         negb (contains new 5);
                         contains ins5 5;
                         contains ins5ins5 5;
                         negb (contains ins5rm5 5);
                         negb (contains ins5ins5rm5 5);
                         option_nat_eq (get new 5) None;
                         option_nat_eq (get ins5 5) (Some 10);
                         option_nat_eq (get ins5ins5 5) (Some 15);
                         option_nat_eq (get ins5ins5rm5 5) None;
                         option_nat_eq (get ins5 3) None
                       ].

  (* Now we can state that our function-based implementation
     complies to Dict interface. *)
  Instance FunDict: Dict := {
    D := @nat_dict_fun;
    new_dict := @new_dict';
    insert := @insert';
    remove := @remove';
    get := @get';
    contains := @contains'
  }.

  (* Define instance of Dict class for the list-based implementation. *)

      (* place your code here *)

  (* Then, state and prove 'fun_dict_tests' and 'list_dict_tests' lemmas
     by instantiating 'dict_tests' with instances you've just created.
     These lemmas, as before, should be proved just by 'tauto'. *)

      (* place your code here *)

End DictGeneral.


Require Import Arith.
Inductive tree : Type :=
  | Leaf : tree
  | Node : nat -> tree -> tree -> tree.

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

Fixpoint ltb (m n : nat) : bool :=
match (m, n) with
  | (_, 0) => false
  | (0, _) => true
  | (S m', S n') => ltb m' n'
end.

Fixpoint tinsert (t : tree) (i : nat) : tree :=
match t with
| Leaf => Node i Leaf Leaf
| Node d l r => if ltb d i then Node d l (tinsert r i) else Node d (tinsert l i) r
end.

Fixpoint tinsert_all (t : tree) (l : lst) : tree :=
match l with
| Nil => t
| Cons n l' => tinsert (tinsert_all t l') n
end.

Fixpoint tsize (t : tree) : nat :=
match t with
| Leaf => 0
| Node d l r => 1 + (tsize l) + (tsize r)
end.

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

Lemma leb_refl : forall n, leb n n = true.
Proof.
induction n. reflexivity. simpl. apply IHn.
Qed.

Lemma leb_m_Sn : forall m n, leb m n = true -> leb m (S n) = true.
Proof.
induction m.
- intros. reflexivity.
- intros. simpl. destruct n.
  + inversion H.
  + apply IHm. simpl in H. apply H.
Qed.

Lemma helper : forall t n, (tsize (tinsert t n)) = S (tsize t).
Proof.
intros. induction t.
- reflexivity.
- simpl. destruct (ltb n0 n).
  + simpl. rewrite IHt2. rewrite <- plus_n_Sm. reflexivity.
  + simpl. rewrite IHt1. reflexivity.
Qed.

Theorem tree_insert_all : forall l t,  (tsize t)  <= (tsize (tinsert_all t l)).
Proof.
  intros. induction l.
  - simpl. auto with arith.
  - simpl. rewrite IHl.
    rewrite helper. auto.
Qed.


(* Power.v *)
(* author: Peter Urbak *)
(* version: 2014-06-02 *)

(** * Power *)

(** ** Requirements *)

(* Standard library *)
Require Import Arith.

(* Own modules *)
Require Import Cases.

(** ** Preliminary *)

(*
(* {NATS} *)
Inductive nat : Type :=
| O : nat
| S : nat -> nat.
(* {END} *)
*)

(*
(* {NAT_RECT} *)
nat_rect : forall P : nat -> Type,
  P O ->
  (forall (n : nat), P n -> P (S n)) ->
  (forall (n : nat), P n).
(* {END} *)
*)

(*
(* {EQ} *)
Inductive eq (A : Type) (x : A) : A -> Prop :=
| eq_refl : x = x
(* {END} *)
*)

(** ** Power

  *** Definition *)

(* {POWER} *)
Fixpoint power (e b : nat) : nat :=
  match e with
    | O => 1
    | S e' => b * (b ^ e')
  end
  where "b ^ e" := (power e b).
(* {END} *)
Hint Unfold power : power.

(** *** Unfolding lemmas *)

(* {UNFOLD_POWER_BASE_CASE} *)
Lemma unfold_power_base_case :
  forall b : nat,
    b ^ 0 = 1.
(* {END} *)
Proof.
  intro b.
  unfold power.
  reflexivity.
Qed.
Hint Rewrite unfold_power_base_case : power.

(* {UNFOLD_POWER_INDUCTION_CASE} *)
Lemma unfold_power_induction_case :
  forall b e' : nat,
    b ^ (S e') = b * (b ^ e').
(* {END} *)
Proof.
  intros b e'.
  unfold power.
  reflexivity.
Qed.
Hint Rewrite unfold_power_induction_case : power.

(** *** Properties *)

Lemma power_b_1 :
  forall (b : nat),
    b ^ 1 = b.
Proof.
  intro b.
  rewrite -> unfold_power_induction_case.
  rewrite -> unfold_power_base_case.
  rewrite -> mult_1_r.
  reflexivity.
Qed.
Hint Rewrite power_b_1 : power.

Lemma power_1_e :
  forall (e : nat),
    1 ^ e = 1.
Proof.
  induction e as [ | e' IH_e' ].

  Case "e = 0".
  rewrite -> unfold_power_base_case.
  reflexivity.

  Case "e = S e'".
  rewrite -> unfold_power_induction_case.
  rewrite -> IH_e'.
  rewrite -> mult_1_l.
  reflexivity.
Qed.
Hint Rewrite power_1_e : power.

Lemma power_0_e :
  forall (e' : nat),
    0 ^ (S e') = 0.
Proof.
  intro e'.
  rewrite -> unfold_power_induction_case.
  rewrite -> mult_0_l.
  reflexivity.
Qed.
Hint Rewrite power_0_e : power.

Lemma power_distributivity :
  forall (b e1 e2 : nat),
    b ^ (e1 + e2) = (b ^ e1) * (b ^ e2).
Proof.
  intro b.
  case e1 as [ | e1' ].

  Case "e1 = 0".
  case e2 as [ | e2' ].

  SCase "e2 = 0".
  rewrite -> plus_0_l.
  rewrite -> unfold_power_base_case.
  rewrite -> mult_1_r.
  reflexivity.

  SCase "e2 = S e2'".
  rewrite -> plus_0_l.
  rewrite -> unfold_power_induction_case.
  rewrite -> unfold_power_base_case.
  rewrite -> mult_1_l.
  reflexivity.

  Case "e1 = S e1'".
  induction e2 as [ | e2' IH_e2' ].

  SCase "e2 = 0".
  rewrite -> plus_0_r.
  rewrite -> unfold_power_induction_case.
  rewrite -> unfold_power_base_case.
  rewrite -> mult_1_r.
  reflexivity.

  SCase "e2 = S e2'".
  rewrite <- plus_n_Sm.
  rewrite -> unfold_power_induction_case.
  rewrite -> IH_e2'.
  rewrite ->2 unfold_power_induction_case.
  rewrite <-2 mult_assoc.
  rewrite -> mult_comm.
  rewrite <- mult_assoc.
  rewrite -> (mult_comm b (b ^ e2')).
  rewrite <- mult_assoc.
  reflexivity.
Qed.
Hint Rewrite power_distributivity : power.

Lemma power_e_identity :
  forall (b e1 e2 : nat),
    (b ^ e1) ^ e2 = b ^ (e1 * e2).
Proof.
  intro b.
  case e1 as [ | e1' ].

  Case "e1 = 0".
  case e2 as [ | e2' ].

  SCase "e2 = 0".
  rewrite -> mult_0_r.
  rewrite ->2 unfold_power_base_case.
  reflexivity.

  SCase "e2 = S e2'".
  rewrite -> mult_0_l.
  rewrite -> unfold_power_base_case.
  rewrite -> unfold_power_induction_case.
  rewrite -> power_1_e.
  rewrite -> mult_1_r.
  reflexivity.

  Case "e1 = S e1'".
  induction e2 as [ | e2' IH_e2' ].

  SCase "e2 = 0".
  rewrite -> mult_0_r.
  rewrite ->2 unfold_power_base_case.
  reflexivity.

  SCase "e2 = S e2'".
  rewrite -> mult_succ_r.
  rewrite -> power_distributivity.
  rewrite <- IH_e2'.
  rewrite <- mult_comm.
  rewrite <- unfold_power_induction_case.
  reflexivity.
Qed.
Hint Rewrite power_e_identity : power.

Lemma power_distribution_identity :
  forall (b1 b2 e : nat),
    (b1 * b2) ^ e = (b1 ^ e) * (b2 ^ e).
Proof.
  intros b1 b2.
  induction e as [ | e' IH_e' ].

  Case "e = 0".
  rewrite ->3 unfold_power_base_case.
  rewrite -> mult_1_r.
  reflexivity.

  Case "e = S e'".
  rewrite -> unfold_power_induction_case.
  rewrite -> IH_e'.
  rewrite ->2 unfold_power_induction_case.
  rewrite <-2 mult_assoc.
  rewrite -> (mult_comm b2 _).
  rewrite <- mult_assoc.
  rewrite -> (mult_comm b2 _).
  reflexivity.
Qed.
Hint Rewrite power_distribution_identity : power.


Require Import  Algebra.Utils Algebra.SetoidCat.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Require Import Coq.Lists.List.

Open Scope type_scope.
Section Monoid.

  Context
    {A : Type}
    {SA : Setoid A}.

  Class Monoid : Type :=
    {
      mempty : A;
      mappend : SA ~> SA ~~> SA;
      left_unit_monoid: forall (a : A),
                       mappend @ mempty @ a == a;
      right_unit_monoid: forall (a : A),
                           mappend @ a @ mempty == a;
      associativity_monoid : forall (a b c : A),
                            mappend @ (mappend @ a @ b) @ c == mappend @ a @ (mappend @ b @ c)

    }.

End Monoid.

Class MonoidHomomorphism {A B: Type}
      {SA : Setoid A} {SB : Setoid B} {MA : @Monoid _ SA} {MB : @Monoid _ SB} (f : SA ~> SB) :=
  {
    monoid_homomorphism_mempty :  f @ mempty == mempty;
    monoid_homomorphism_mappend : forall a a2, f @ (mappend @ a @ a2) == mappend @ (f @ a) @ ( f @ a2)
  }.


(*
 * This tutorial is for Shizhuo! But anyone else who likes it
 * is welcome to take a look at it. It's about pairs of unary
 * and binary natural numbers in Coq, and why unary and binary
 * numbers are equivalent, and what that means.
 *
 * Consider the unary natural numbers, which we redefine
 * from scratch inductively:
 *)
Inductive nat : Set :=
| O : nat           (* 0 *)
| S : nat -> nat.   (* successor (1 + n) *)

(*
 * Consider also the binary natural numbers, which we also
 * redefine from scratch inductively, starting with the
 * positive binary numbers:
 *)
Inductive bin_pos : Set :=
| O1 : bin_pos             (* 01 *)
| xO : bin_pos -> bin_pos  (* shift left and add 0 *)
| x1 : bin_pos -> bin_pos. (* shift left and add 1 *)
(*
 * and continuing:
 *)
Inductive bin : Set :=
| OO : bin                 (* 00 *)
| pos : bin_pos -> bin.    (* positive binary numbers *)

(* --- Some related terms --- *)

(*
 * How are these related? Let's define corresponding points/terms.
 *)
Definition zeros : nat * bin :=
  (O, OO). (* 0, 00 *)

Definition ones : nat * bin :=
  (S O, pos O1). (* 1, 01 *)

Definition twos : nat * bin :=
  (S (S O), pos (xO O1)). (* 2, 10 *)

Definition threes : nat * bin :=
  (S (S (S O)), pos (x1 O1)). (* 3, 11 *)

Definition fours : nat * bin :=
  (S (S (S (S O))), pos (xO (xO O1))). (* 4, 100 *)

Definition fives : nat * bin :=
  (S (S (S (S (S O)))), pos (x1 (xO O1))). (* 5, 101 *)

Definition sixes : nat * bin :=
  (S (S (S (S (S (S O))))), pos (xO (x1 O1))). (* 6, 110 *)

(* --- Converting from unary to binary --- *)

(*
 * In general, we can define a function that gets us from unary
 * to binary. First we define the successor function over
 * positive binary numbers:
 *)
Fixpoint S_bin_pos (b : bin_pos) : bin_pos :=
  match b with
  | O1 => xO O1
  | xO bb => x1 bb
  | x1 bb => xO (S_bin_pos bb)
  end.
(*
 * and then over all of binary:
 *)
Definition S_bin (b : bin) : bin :=
  match b with
  | OO => pos O1
  | pos bb => pos (S_bin_pos bb)
  end.

(*
 * Our function f maps O to OO, and S n to S_bin (f n):
 *)
Fixpoint f (n : nat) : bin :=
  match n with
  | O => OO
  | S m => S_bin (f m)
  end.

(*
 * Some tests, which correspond to the examples above:
 *)
Eval compute in (f O).
Eval compute in (f (S O)).
Eval compute in (f (S (S O))).
Eval compute in (f (S (S (S O)))).
Eval compute in (f (S (S (S (S O))))).
Eval compute in (f (S (S (S (S (S O)))))).
Eval compute in (f (S (S (S (S (S (S O))))))).

(* --- Getting from binary to unary --- *)

(*
 * We can also go back in the opposite direction.
 * The easiest way is to play a similar game.
 * We define what "shift to the left and add zero"
 * and "shift to the left and add one" correspond to in unary.
 * The function falls out of that by pattern matching and
 * recursion.
 *
 * First, let's define addition (since we defined
 * numbers from scratch, this isn't a primitive):
 *)
Fixpoint add (n m : nat) : nat :=
  match n with
  | O => m              (* O + m = m *)
  | S p => S (add p m)  (* (1 + p) + m = 1 + (p + m) *)
  end.

(*
 * Now we can define shifting to the left and adding zero/one:
 *)
Definition xO_nat (n : nat) :=
  add n n.

Definition x1_nat (n : nat) :=
  S (add n n).

(*
 * Now we can get back from binary to unary, starting with this:
 *)
Fixpoint g_pos (b : bin_pos) : nat :=
  match b with
  | O1 => S O
  | xO bb => xO_nat (g_pos bb)
  | x1 bb => x1_nat (g_pos bb)
  end.
(*
 * and concluding with this:
 *)
Definition g (b : bin) : nat :=
  match b with
  | OO => O
  | pos bb => g_pos bb
  end.

(* --- This is an equivalence! --- *)

(*
 * Some lemmas, first, about the auxiliary functions we defined.
 * I'm going to automate these a bit since the proofs are not
 * super important.
 *)
Lemma add_n_Sm:
  forall (n m : nat),
    add n (S m) = S (add n m).
Proof.
  induction n; simpl; congruence.
Qed.

Lemma S_OK :
  forall (b : bin), g (S_bin b) = S (g b).
Proof.
  induction b as [|bb]; auto.
  induction bb; auto.
  simpl in *. rewrite IHbb. unfold xO_nat, x1_nat. simpl.
  f_equal. apply add_n_Sm.
Qed.

Definition xO_bin (b : bin) :=
  match b with
  | OO => OO
  | pos bb => pos (xO bb)
  end.

Lemma xO_OK:
  forall (n : nat), f (xO_nat n) = xO_bin (f n).
Proof.
  intros n. induction n; auto.
  simpl. unfold xO_nat in IHn.
  rewrite add_n_Sm. simpl in *. rewrite IHn.
  destruct (f n); auto.
Qed.

Definition x1_bin (b : bin) :=
  match b with
  | OO => pos O1
  | pos bb => pos (x1 bb)
  end.

Lemma x1_OK:
  forall (n : nat), f (x1_nat n) = x1_bin (f n).
Proof.
  intros n. induction n; auto.
  simpl. unfold x1_nat in IHn.
  rewrite add_n_Sm. simpl in *. rewrite IHn.
  destruct (f n); auto.
Qed.

(*
 * OK, the proofs we care about! These are worth stepping through.
 *)
Theorem section:
  forall (n : nat), g (f n) = n.
Proof.
  intros n. induction n.
  - reflexivity.
  - simpl. rewrite S_OK. rewrite IHn. reflexivity.
Qed.

Theorem retraction:
  forall (b : bin), f (g b) = b.
Proof.
  intros b. induction b as [|bb].
  - reflexivity.
  - induction bb.
    + reflexivity.
    + simpl in *. rewrite xO_OK. rewrite IHbb. reflexivity.
    + unfold g. replace (g_pos (x1 bb)) with (x1_nat (g_pos bb)) by reflexivity.
      rewrite x1_OK. simpl in IHbb. rewrite IHbb.
      reflexivity.
Qed.


(* ###################################################################### *)
(** * Proofs and Programs *)

(** [Inductive] is Coq's way of defining an algebraic datatype.  Its
    syntax is similar to OCaml's ([type]) or Haskell's ([data]). Here,
    we define [bool] as a simple algebraic datatype. *)

Module Bool.

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

(** Exercise: Define a three-valued data type, representing ternary
    logic.  Here something can be true, false and unknown. *)

Inductive trivalue : Type :=
| one : trivalue
| two : trivalue
| three : trivalue.

(** We can write functions that operate on [bool]s by simple pattern
    matching, using the [match] keyword. *)

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

Check negb.
Compute (negb true).

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

Print orb.

Definition andb (b1 b2: bool) : bool :=
  if b1 then b2 else false.

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

(** New tactics
    -----------

    - [intros]: Introduce variables into the context, giving them
      names.

    - [simpl]: Simplify the goal.

    - [reflexivity]: Prove that some expression [x] is equal to itself. *)

Example andb_false : forall b, andb false b = false.
Proof.
  intros b1.
  simpl.
  reflexivity.
Qed.

(** Exercise: Prove this. *)
Theorem orb_true_l :
  forall b, orb true b = true.
Proof.
  intros b.
  simpl.
  reflexivity.
Qed.

(** New tactics
    -----------

    - [destruct]: Consider all possible constructors of an inductive
      data type, generating subgoals that need to be solved
      separately. *)

Lemma double_negation : forall b : bool, negb (negb b) = b.
Proof.
  intros b.
  simpl.
  destruct b.
  (* focus on: *)
  + (* case: b is true *)
    simpl.
    reflexivity.
  + (* case: b is false *)
    simpl.
    reflexivity.
Qed.

Theorem andb_commutative : forall b1 b2 : bool, andb b1 b2 = andb b2 b1.
Proof.
 intros b1 b2.
 destruct b1.
 + simpl.
   destruct b2.
   - simpl.
     reflexivity.
   - simpl.
     reflexivity.
 + destruct b2; simpl; reflexivity.
Qed.

(* we should use `+` `-` `*` consistently *)

(** Exercise: Show that false is an identity element for xor -- that
    is, [xor false b] is equal to [b] *)

Theorem xorb_false : forall b : bool, xorb false b = b.
Proof.
 intros b.
 destruct b.
 + simpl.
   reflexivity.
 + simpl; reflexivity.
Qed.

(** New tactics
    -----------

    - [rewrite]: Replace one side of an equation by the other.

    - [apply]: Suppose that the current goal is [Q]. If [H : Q], then
      [apply H] solves the goal. If [H : P -> Q], then [apply H]
      replaces [Q] by [P] in the goal. If [H] has multiple hypotheses,
      [H : P1 -> P2 -> ... -> Pn -> Q], then [apply H] generates one
      subgoal for each [Pi]. *)

Theorem rewrite_example : forall b1 b2 b3 b4 : bool,
  b1 = b4 ->
  b2 = b3 ->
  andb b1 b2 = andb b3 b4.
Proof.
  intros b1 b2 b3 b4 E14 E23.
  rewrite <- E14.
  rewrite <- E23.
  apply andb_commutative.
Qed.

(** Exercise: Show that if [b1 = b2] then [xorb b1 b2] is equal to
    [false] *)

Theorem xorb_same : forall b1 b2 : bool, b1 = b2 -> xorb b1 b2 = false.
Proof.
  intros b1 b2 E.
  rewrite E.
(*
  destruct b2.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
*)
  destruct b2; reflexivity.
Qed.

End Bool.

Module Nat.

(* ###################################################################### *)
(** * Numbers and induction *)

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

Check (S (S O)). (* [C-c C-a C-c] in Proof General *)

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

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

(** Exercise: Define exponentiation *)

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

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

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

  Notation "x ^ y" := (expo x y) (at level 30, right associativity).

  Compute ( (S (S O)) + (S (S O)) ).
  Compute ( (S (S O)) * (S (S O)) ).
  Compute ( (S (S O)) ^ (S (S O)) ).

Lemma plus_0_l: forall n : nat, O + n = n.
Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

(**
    New tactic
    ----------

    - [induction]: Argue by induction. It works as [destruct], but
    additionally giving us an inductive hypothesis in the inductive
    case. *)

Lemma plus_O_r: forall n : nat, n + O = n.
Proof.
  intros n.
  simpl.
  (* instead of: destruct n. *)
  induction n as [| n' IH].
  (* IH ==== Inductive Hypotesis *)
(*
  + simpl.
    reflexivity.

  reflexivity *includes* simpl
*)
  + reflexivity.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

Print plus_O_r.

Theorem plus_assoc: forall m n o, m + (n + o) = (m + n) + o.
Proof.
  intros m n o.
  induction m.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHm.
    reflexivity.
 Qed.

(** Take-home exericse: Try to do induction on [n] and [o] in the
    above proof, and see where it fails. *)

(** Exercise: Show that [n + S m] is equal to [S (n + m)]. *)

Lemma plus_S_r : forall n m, n + S m = S (n + m).
Proof.
  intros n m.
  simpl.
  induction n as [| n' IH].
  + simpl.
    reflexivity.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

(** Exercise: Show that plus is commutative. *)
(** Hint: Look at our earlier lemmas. *)

Lemma plus_comm : forall n m, n + m = m + n.
Proof.
  intros n m.
  induction m.
  + simpl.
    apply plus_O_r.
  + simpl.
    rewrite <- IHm.
   apply plus_S_r.
Qed.

(*
  To search the right lemma: SearchAbout

  e.g. SearchAbout (_ + S = _).
*)

(** Additional take-home exercises: Show that mult has an identity [S
    O], a annihilator [O] and associative, commutative and
    distributive properties. *)

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

Notation "x - y" := (minus x y) (at level 50, left associativity).

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

Fail Fixpoint div (m n: nat) : nat :=
  match n with
  | O => O
  | S n' => if ble_nat n m then S (div (m - n) n) else O
  end.

Fixpoint div (m n: nat) : nat :=
  match n with
  | O => O
  | S n' => match m with
            | O => O
            | S m' => S (div (S m' - S n') (S n'))
            end
  end.
Fixpoint beq_nat (m n : nat) : bool :=
  match m, n with
  | O, O => true
  | S m', S n' => beq_nat m' n'
  | _, _ => false
  end.

Definition max (m n : nat) : nat :=
  if ble_nat m n then n else m.

(** New tactic
    ----------

    - [clear]: Remove hypotheses from the context (needed here to
      simplify our IH). *)

(* revert is the opposite of intros *)

Lemma beq_nat_eq :
  forall m n, m = n -> beq_nat m n = true.
Proof.
  intros m n e. rewrite e. clear m e.
  induction n as [|n IH].
  - reflexivity.
  - simpl. apply IH.
Qed.

(** New tactics
    -----------

    - [discriminate]: Looks for an equation between terms starting
      with different constructors, and solves the current goal.

    - [revert]: The opposite of [intros]; removes variables and
      hypotheses from the context, putting them back in the goal. *)

Lemma eq_beq_nat :
  forall m n, beq_nat m n = true -> m = n.
Proof.
(* 1st try
  intros m n e.
  induction m.
  + destruct n.
      - reflexivity.
      - simpl in e.
         discriminate.
  + rewrite IHm
*)
  intros m n e.
  revert n e.
  induction m.
  + intros n e.
      destruct n.
      - reflexivity.
      - simpl in e.
         discriminate.
  + intros n H.
      destruct n.
      - simpl in H.
          discriminate.
      - simpl in H.
        apply IHm in H.
        rewrite H.
        reflexivity.
Qed.

Lemma plus_eq_0 : forall n m,  n + m = O -> n = O.
Proof.
(*  SearchAbout (_ + (S _) = _).
  intros n.
  induction n.
  + reflexivity.
  + intros m H.
      destruct n.
*)

  intros n.
  induction n.
  + reflexivity.
  + intros m H.
      (* inversion H. *)
       simpl in H.
       discriminate.

Qed.

End Nat.

(** Useful notation... *)

Compute (S (S O)).
Compute (S (S O) + S O).

(* ###################################################################### *)
(** * Lists *)

Module List.

(** Here's a polymorphic definition of a [list] type in Coq: *)

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

(* Explicit polymorphism. *)
Definition singleton_list (T : Type) (x : T) :=
  cons T x (nil T).

(* Inferred (but still a bit explicit) *)
Definition singleton_list' (T : Type) (x : T) :=
  cons _ x (nil _).

(* Implicit, inferred all the time *)
Arguments nil {T}.
Arguments cons {T} _ _.
Definition singleton_list'' {T} (x : T) :=
  cons x nil.

Check (singleton_list'' 3).
Check (@singleton_list'' nat).

(* @ turn off implicit arguments *)

Check @singleton_list''.
Check @nil.

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

(* Exercise: Define "snoc", which adds an element to the end of a list. *)

Fixpoint snoc {T} (l : list T) (x : T) : list T :=
  match l with
  | []       => [x]
  | x' :: l' => x' :: snoc l' x
  end.

Fixpoint app {T} (l1 l2 : list T) : list T :=
  match l1 with
  | [] => l2
  | h :: l1' => h :: (app l1' l2)
  end.

Notation "l1 ++ l2" := (app l1 l2) (at level 60, right associativity).

Lemma app_assoc :
  forall T (l1 l2 l3 : list T),
    l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
(*  intros T l x.
  induction l as [|x' l IH]; simpl.
  - reflexivity.
  - rewrite IH. reflexivity.
Qed.
*)
Admitted.

Lemma snoc_app :
  forall T (l : list T) (x : T),
    snoc l x = l ++ [x].
Proof.
  (* Fill in here *)
Admitted.

End List.

(** Lists, of course, are also defined in the standard library. *)

Require Import Coq.Lists.List.
Import ListNotations.

(** Notice that the definition of rev (list reversal) given in the
    standard library runs in quadratic time. *)

Print rev. (* [C-c C-a C-p] in Proof General *)

(** This is a tail-recursive equivalent that runs in linear time. *)

Fixpoint tr_rev_aux {T} (l acc : list T) : list T :=
  match l with
  | [] => acc
  | x :: l => tr_rev_aux l (x :: acc)
  end.

Definition tr_rev {T} (l: list T) := tr_rev_aux l [].

(** New Tactic
    ----------

    - [unfold]: Calling [unfold foo] expands the definition of [foo]
      in the goal.
*)

Lemma tr_rev_aux_correct :
  forall T (l1 l2 : list T),
    tr_rev_aux l1 l2  = rev l1 ++ l2.
Proof.
  intros T l1 l2.
  revert l2.
  induction l1 as [|x1 l1 IH]; simpl.
  - intros l2. reflexivity.
  - intros l2. rewrite IH.
    SearchAbout (_ ++ _ ++ _).
    rewrite <- app_assoc.
    simpl.
    reflexivity.
Qed.

Lemma tr_rev_correct :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
  intros T l.
  unfold tr_rev.
  rewrite tr_new_aux_correct.
  simpl.
  SearchAbout (_ ++ [])
(*
  induction l as [|x l IH]. simpl.
  - reflexivity.
  - .
*)
  apply app_nil_r.
Qed.

(* ###################################################################### *)
(** * Dependently Typed Programming *)

Definition stack := list.

Definition push {T} (x:T) (s : stack T) : stack T  := x :: s.

(* Definition pop {T} (s : stack T) : T * stack T := *)

(* Length-Indexed Stacks *)

(* Exercise: Write a snoc function to add an element to the bottom of
   an indexed stack. Do not use the combine function (in this case, it
   will make life difficult.) *)


Set Warnings "-notation-overridden,-parsing".
Require Coq.omega.Omega.
From LF Require Export logic.

(*偶数の定義
ev_0:0が偶数である
ev_SS: nが偶数のときn+2は偶数である*)
Inductive even : nat -> Prop :=
| ev_0 : even 0
| ev_SS (n : nat) (H : even n) : even (S (S n)).

(*直感的には下の定義だけどこれは無理。
  帰納的定義にしないと。
 error message:
    "wrong_ev" must have "n" as 1st argument in "wrong_ev 0"*)
Fail Inductive wrong_ev (n : nat) : Prop :=
| wrong_ev_0 : wrong_ev 0
| wrong_ev_SS : wrong_ev n -> wrong_ev (S (S n)).

(*これならOK*)
Inductive even' : nat -> Prop :=
| ev_0' : even' 0
| ev_SS' : forall n, even' n -> even' (S (S n)).

(*4が偶数である証明*)
Theorem ev_4 : even 4.
Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed.
Theorem ev_4' : even 4.
Proof. apply (ev_SS 2 (ev_SS 0 ev_0)). Qed.
Theorem ev_plus4 : forall n, even n -> even (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

Theorem ev_double : forall n,
  even (double n).
Proof.
   intros. induction n. simpl. apply ev_0. simpl. apply ev_SS. apply IHn.
Qed.

Theorem ev_inversion :
  forall (n : nat), even n ->
    (n = 0) \/ (exists n', n = S (S n') /\ even n').
Proof.
  intros n E.
  destruct E as [ | n' E'].
  -
    left. reflexivity.
  -
    right. exists n'. split. reflexivity. apply E'.
Qed.

Theorem ev_minus2 : forall n,
  even n -> even (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  - simpl. apply ev_0.
  - simpl. apply E'.
Qed.

Theorem evSS_ev : forall n, even (S (S n)) -> even n.
Proof.
  intros n E.
  destruct E as [| n' E'].
  -

Abort. (*destructじゃ無理*)

Theorem evSS_ev : forall n, even (S (S n)) -> even n.
Proof. intros n H. apply ev_inversion in H. destruct H.
 - discriminate H.
 - destruct H as [n' [Hnm Hev]]. injection Hnm.
   intro Heq. rewrite Heq. apply Hev.
Qed.

(*inversion使えば簡単*)
Theorem evSS_ev' : forall n,
  even (S (S n)) -> even n.
Proof.
  intros n E.
  inversion E as [| n' E'].
  apply E'.
Qed.

Theorem one_not_even : ~ even 1.
Proof.
  intros H. apply ev_inversion in H.
  destruct H as [ | [m [Hm _]]].
  - discriminate H.
  - discriminate Hm.
Qed.

(*inversionでdiscriminateをできる*)
Theorem one_not_even' : ~ even 1.
  intros H. inversion H. Qed.

Theorem SSSSev__even : forall n,
  even (S (S (S (S n)))) -> even n.
Proof.
  intros. inversion H. inversion H1. apply H3.
Qed.

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

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

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

Lemma ev_even_firsttry : forall n,
  even n -> exists k, n = double k.
Proof.
 intros n E. inversion E as [| n' E'].
  -
    exists 0. reflexivity.
  -
    assert (I : (exists k', n' = double k') ->
                (exists k, S (S n') = double k)).
    { intros [k' Hk']. rewrite Hk'. exists (S k'). reflexivity. }
    apply I.
Abort.

Lemma ev_even : forall n,
  even n -> exists k, n = double k.
Proof.
  intros n E.
  induction E as [|n' E' IH].
  -
    exists 0. reflexivity.
  -
    destruct IH as [k' Hk'].
    rewrite Hk'. exists (S k'). reflexivity.
Qed.

Theorem ev_even_iff : forall n,
  even n <-> exists k, n = double k.
Proof.
  intros n. split.
  - apply ev_even.
  - intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

Theorem ev_sum : forall n m, even n -> even m -> even (n + m).
Proof.
  intros n m. destruct n.
  - intros. apply H0.
  - intros. induction H0 as [|n' E H1].
       + simpl. rewrite <- plus_n_O. apply H.
       + simpl. Search plus. rewrite PeanoNat.Nat.add_succ_r.
         apply ev_SS. rewrite PeanoNat.Nat.add_succ_r. rewrite PeanoNat.Nat.add_succ_l in H1.
          apply H1.
Qed.

Inductive even'' : nat -> Prop :=
| even''_0 : even'' 0
| even''_2 : even'' 2
| even''_sum n m (Hn : even'' n) (Hm : even'' m) : even'' (n + m).

Theorem even''_ev : forall n, even'' n <-> even n.
Proof.
  intros. induction n. split. intros. apply ev_0. intros. apply even''_0.
  - split. intros. induction H.
     + apply ev_0. + apply ev_SS. apply ev_0.
     + apply ev_sum. apply IHeven''1. apply IHeven''2.
     + intro.
     { induction H.
        - apply even''_0.
        - apply even''_sum with (n:= 2) (m:= n0).
             + apply even''_2.
             + apply IHeven. }
Qed.

Theorem ev_ev__ev : forall n m,
  even (n+m) -> even n -> even m.
Proof.
  intros n m H En.
  induction En as [| n' IHn'].
  simpl in H.
  apply H.
  simpl in H.
  inversion H.
  apply IHIHn'.
  apply H1.
Qed.

Theorem ev_plus_plus : forall n m p,
  even (n+m) -> even (n+p) -> even (m+p).
Proof.
  intros n m p H H1 . destruct m.
  - simpl. rewrite plus_comm in H. simpl in H. apply (ev_ev__ev n p) in H1.
    apply H1. apply H.
  - destruct p. + rewrite <- plus_n_O in H1. rewrite <- plus_n_O. apply (ev_ev__ev n (S m)).
    apply H. apply H1.
    + apply (ev_ev__ev n (S m)) in H. apply ev_sum. apply H. apply (ev_ev__ev n (S p)) in H1.
      apply H1. destruct n. apply ev_0.
Admitted.

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

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

Theorem test_le1 :
  3 <= 3.
Proof.
  apply le_n. Qed.

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

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

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

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

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

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

Inductive next_even : nat -> nat -> Prop :=
  | ne_1 n : even (S n) -> next_even n (S n)
  | ne_2 n (H : even (S (S n))) : next_even n (S (S n)).

Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o.
Proof.
  intros. generalize dependent H.
  induction H0.
    - intros. apply H.
    - intros. apply le_S. apply IHle in H. apply H.
Qed.

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

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

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros. inversion H.
  - apply le_n.
  - apply le_trans with (n:= S n).
       + apply le_S. apply le_n.
       + apply H2.
Qed.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  intros. induction b.
  - rewrite plus_comm. simpl. apply le_n.
  - rewrite plus_comm. simpl. apply le_S. rewrite plus_comm. apply IHb.
Qed.

Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
 unfold lt. intros. split.
   - apply le_trans with (n:= S (n1 + n2) ).
    + Search plus S eq. rewrite <- plus_Sn_m. apply le_plus_l.
    + apply H.
  - apply le_trans with (n:= S (n1 + n2) ).
    + Search plus S eq. rewrite plus_n_Sm. rewrite plus_comm. apply le_plus_l.
    + apply H.
Qed.

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

Theorem leb_complete : forall n m,
  n =< m = true -> n <= m.
Proof.
  intros n m.
  generalize dependent m.
  induction n as [| n' IH].
  - intros. apply O_le_n.
  - intros. destruct m.
    + discriminate.
    + apply n_le_m__Sn_le_Sm.
      apply IH.
      apply H.
Qed.

Theorem leb_succ : forall n m,
  (n =< m) = true -> (n =< S m) = true.
Proof.
  intros n m. generalize dependent m. induction n as [| n' IH].  reflexivity. intros. simpl. inversion H.
  destruct m. discriminate. rewrite H1. apply IH. apply H1.
Qed.

Theorem leb_nn : forall n,
  n =< n = true.
Proof.
  intros. induction n.
  - reflexivity.
  - simpl. apply IHn.
Qed.

Theorem leb_correct : forall n m,
  n <= m ->
  n =< m = true.
Proof.
  intros. induction m.
  -  inversion H. simpl. reflexivity.
  - intros. inversion H.
     + rewrite leb_nn. reflexivity.
     + apply leb_succ. apply IHm. apply H2.
Qed.

Theorem leb_true_trans : forall n m o,
  n =< m = true -> m =< o = true -> n =< o = true.
Proof.
  intros n m o H H0. apply leb_correct. apply leb_complete in H. apply leb_complete in H0.
  generalize dependent H0. generalize dependent H. apply le_trans.
Qed.

Theorem leb_iff : forall n m,
  n =< m = true <-> n <= m.
Proof.
  intros. split.
  - apply leb_complete. - apply leb_correct.
Qed.

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

Theorem R112:
  R 1 1 2.
Proof.
  apply c2. apply c3. apply c1.
Qed.
Theorem R226:
  R 2 2 6.
Proof.
  apply c2. apply c3. apply c3. apply c2. apply c4. apply c2. apply c3.
Abort.

Definition fR : nat -> nat -> nat :=
  fun n m =>  n + m.

Theorem R_equiv_fR : forall m n o, R m n o <-> fR m n = o.
Proof.
  unfold fR. intros. split.
  - intros. induction H.
   + reflexivity.
   + apply eq_S with (x:= (m+n)). apply IHR.
   + rewrite plus_comm. simpl. rewrite plus_comm.
     apply eq_S with (x:= (m+n)). apply IHR.
   + simpl in IHR. apply S_injective in IHR. apply S_injective.
     rewrite plus_n_Sm. apply IHR.
   + rewrite plus_comm. apply IHR.
  - intros. destruct H. induction n.
   + rewrite plus_comm. simpl.
    induction m. apply c1. apply c2. apply IHm.
   + rewrite plus_comm. simpl. apply c3. rewrite plus_comm. apply IHn.
Qed.

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

Theorem subseq_refl : forall (l : list nat), subseq l l.
Proof.
  intros. induction l. apply subseq_nil. apply subseq_inboth. apply IHl.
Qed.

Theorem subseq_app : forall (l1 l2 l3 : list nat),
  subseq l1 l2 ->
  subseq l1 (l2 ++ l3).
Proof.
  intros. induction H.
  - apply subseq_nil.
  - simpl. apply subseq_inboth. apply IHsubseq.
  - simpl. apply subseq_in2nd. apply IHsubseq.
Qed.

Theorem subseq_nil_r : forall l : list nat,
  subseq l [] -> l = [].
Proof.
  intros. inversion H. reflexivity.
Qed.

Theorem subseq_trans : forall (l1 l2 l3 : list nat),
  subseq l1 l2 ->
  subseq l2 l3 ->
  subseq l1 l3.
Proof.
  intros l1 l2 l3 T12 T23.
  generalize dependent T12.
  generalize dependent l1.
  induction T23.
  - intros. inversion T12. apply subseq_nil.
  - intros. inversion T12.
    + apply subseq_nil.
    + apply subseq_inboth. apply IHT23. apply H1.
    + apply subseq_in2nd. apply IHT23. apply H1.
  - intros. apply subseq_in2nd. apply IHT23. apply T12.
Qed.

Inductive R' : nat -> list nat -> Prop :=
 | c7 : R' 0 []
 | c8 : forall n l, R' n l -> R' (S n) (n :: l)
 | c9 : forall n l, R' (S n) l -> R' n l.
Theorem R'210:
  R' 2 [1;0].
Proof.
  apply c8. apply c8. apply c7.
Qed.
Theorem R11210 :
  R' 1 [1;2;1;0].
Proof.
  apply c9. apply c8. apply c9. apply c9. apply c8. apply c8. apply c8. apply c7.
Qed.
Theorem R'6321:
  R' 6 [3;2;1;0].
Proof.
  Abort.

(*---------正規表現のモデル化--------------*)
(*
The expression EmptySet does not match any string.
The expression EmptyStr matches the empty string [].
The expression Char x matches the one-character string [x].

If re1 matches s1, and re2 matches s2, then App re1 re2 matches s1 ++ s2.
If at least one of re1 and re2 matches s, then Union re1 re2 matches s.
If we can write some string s as the concatenation of a sequence of strings s = s_1 ++ ... ++ s_k,
    and the expression re matches each one of the strings s_i, then Star re matches s.
As a special case, the sequence of strings may be empty,
   so Star re always matches the empty string [] no matter what re is.*)
Inductive reg_exp {T : Type} : Type :=
  | EmptySet
  | EmptyStr
  | Char (t : T)
  | App (r1 r2 : reg_exp)
  | Union (r1 r2 : reg_exp)
  | Star (r : reg_exp).

Inductive exp_match {T} : list T -> reg_exp -> Prop :=
  | MEmpty : exp_match [] EmptyStr
  | MChar x : exp_match [x] (Char x)
  | MApp s1 re1 s2 re2
             (H1 : exp_match s1 re1)
             (H2 : exp_match s2 re2) :
             exp_match (s1 ++ s2) (App re1 re2)
  | MUnionL s1 re1 re2
                (H1 : exp_match s1 re1) :
                exp_match s1 (Union re1 re2)
  | MUnionR re1 s2 re2
                (H2 : exp_match s2 re2) :
                exp_match s2 (Union re1 re2)
  | MStar0 re : exp_match [] (Star re)
  | MStarApp s1 s2 re
                 (H1 : exp_match s1 re)
                 (H2 : exp_match s2 (Star re)) :
                 exp_match (s1 ++ s2) (Star re).

Notation "s =~ re" := (exp_match s re) (at level 80).
Example reg_exp_ex1 : [1] =~ Char 1.
Proof.
  apply MChar.
Qed.
Example reg_exp_ex2 : [1; 2] =~ App (Char 1) (Char 2).
Proof.
  apply (MApp [1] _ [2]).
  - apply MChar.
  - apply MChar.
Qed.
Example reg_exp_ex3 : ~ ([1; 2] =~ Char 1).
Proof.
  intros H. inversion H.
Qed.

Fixpoint reg_exp_of_list {T} (l : list T) :=
  match l with
  | [] => EmptyStr
  | x :: l' => App (Char x) (reg_exp_of_list l')
  end.

Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3].
Proof.
  simpl. apply (MApp [1]).
  { apply MChar. }
  apply (MApp [2]).
  { apply MChar. }
  apply (MApp [3]).
  { apply MChar. }
  apply MEmpty.
Qed.

Lemma MStar1 :
  forall T s (re : @reg_exp T) ,
    s =~ re ->
    s =~ Star re.
Proof.
  intros T s re H.
  rewrite <- (app_nil_r _ s).
  apply (MStarApp s [] re).
  - apply H.
  - apply MStar0.
Qed.

Lemma empty_is_empty : forall T (s : list T),
  ~ (s =~ EmptySet).
Proof.
  unfold not. intros. inversion H.
Qed.

Lemma MUnion' : forall T (s : list T) (re1 re2 : @reg_exp T),
  s =~ re1 \/ s =~ re2 ->
  s =~ Union re1 re2.
Proof.
  intros. inversion H.
  + apply MUnionL. apply H0.
  + apply MUnionR. apply H0.
Qed.

Lemma MStar' : forall T (ss : list (list T)) (re : reg_exp),
  (forall s, In s ss -> s =~ re) ->
  fold app ss [] =~ Star re.
Proof.
  intros. induction ss.
  - simpl. apply MStar0.
  - simpl. apply MStarApp.
     + apply H. simpl. left. reflexivity.
     + apply IHss. intros. apply H. right. apply H0.
Qed.

Lemma reg_exp_of_list_spec : forall T (s1 s2 : list T),
  s1 =~ reg_exp_of_list s2 <-> s1 = s2.
Proof.
  intros T s1 s2.
  generalize dependent s1.
  induction s2 as [|h t].
  - (* s2 = [] *)
    split.
    + intros H. simpl in H. inversion H. reflexivity.
    + intros H. simpl. rewrite H. apply MEmpty.
  - (* s2 = h::t *)
    intros s1. split.
    + intros H. simpl in H. inversion H.
      inversion H3. simpl.
      apply (IHt s2) in H4. rewrite H4. reflexivity.
    + intros H. simpl. rewrite H.
      assert ( A : forall S (x:S) y, [x]++y = x::y).
      {  intros S x y. simpl. reflexivity.  }
      rewrite <- A. apply MApp.
      * apply MChar.
      * apply IHt. reflexivity.
Qed.

Fixpoint re_chars {T} (re : reg_exp) : list T :=
  match re with
  | EmptySet => []
  | EmptyStr => []
  | Char x => [x]
  | App re1 re2 => re_chars re1 ++ re_chars re2
  | Union re1 re2 => re_chars re1 ++ re_chars re2
  | Star re => re_chars re
  end.

Theorem in_re_match : forall T (s : list T) (re : reg_exp) (x : T),
  s =~ re ->
  In x s ->
  In x (re_chars re).
Proof.
  intros T s re x Hmatch Hin.
  induction Hmatch
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  -
    apply Hin.
  -
    apply Hin.
  - simpl. apply In_app_iff. apply In_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    +
      left. apply (IH1 Hin).
    +
      right. apply (IH2 Hin).
  -
    simpl. apply In_app_iff.
    left. apply (IH Hin).
  -
    simpl. apply In_app_iff.
    right. apply (IH Hin).
  -
    destruct Hin.
  -
    simpl. apply In_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    +
      apply (IH1 Hin).
    +
      apply (IH2 Hin).
Qed.

Fixpoint re_not_empty {T : Type} (re : @reg_exp T) : bool :=
  match re with
  | EmptySet => false
  | EmptyStr => true
  | Char _   => true
  | App re1 re2 => andb (re_not_empty re1) (re_not_empty re2)
  | Union re1 re2 => orb (re_not_empty re1) (re_not_empty re2)
  | Star re1 => true
  end.

Lemma re_not_empty_correct : forall T (re : @reg_exp T),
  (exists s, s =~ re) <-> re_not_empty re = true.
Proof.
  intros. split.
  - intros [s H]. induction H.
    + reflexivity.
    + reflexivity.
    + simpl. rewrite IHexp_match1. rewrite IHexp_match2. reflexivity.
    + simpl. rewrite IHexp_match. reflexivity.
    + simpl. rewrite IHexp_match. apply orb_true_iff. right. reflexivity.
    + reflexivity.
    + rewrite IHexp_match2. reflexivity.

   - intros. induction re.
     + discriminate.
     + exists []. apply MEmpty.
     + exists [t]. apply MChar.
     + simpl in H. apply andb_true_iff in H. inversion H. apply IHre1 in H0. apply IHre2 in H1.
       inversion H0. inversion H1. exists (x ++ x0). apply MApp. apply H2. apply H3.
     + simpl in H. apply orb_true_iff in H. inversion H.
      { apply IHre1 in H0. inversion H0. exists x. apply MUnionL. apply H1. }
      { apply IHre2 in H0. inversion H0. exists x. apply MUnionR. apply H1. }
    + exists []. apply MStar0.
Qed.

(*--------The remember Tactic--------*)

Lemma star_app: forall T (s1 s2 : list T) (re : @reg_exp T),
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros T s1 s2 re H1. induction H1
    as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
        |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
        |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].
  -
    simpl. intros H. apply H.
  -
  Abort.

Lemma star_app: forall T (s1 s2 : list T) (re : reg_exp),
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros T s1 s2 re H1.
  remember (Star re) as re'.
  generalize dependent s2.
  induction H1
    as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
        |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
        |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
  -
    injection Heqre'. intros Heqre'' s H. apply H.
  -
    injection Heqre'. intros H0.
    intros s2 H1. rewrite <- app_assoc.
    apply MStarApp.
    + apply Hmatch1.
    + apply IH2.
      * rewrite H0. reflexivity.
      * apply H1.
Qed.

Lemma MStar'' : forall T (s : list T) (re : reg_exp),
  s =~ Star re ->
  exists ss : list (list T),
    s = fold app ss []
    /\ forall s', In s' ss -> s' =~ re.
Proof.
  intros. remember (Star re) as str.
  induction H  as [|x'|s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        |s1 re1 re2 Hmatch IH|re1 s2 re2 Hmatch IH
        |re''|s1 s2 re'' Hmatch1 IH1 Hmatch2 IH2].
  - inversion Heqstr.
  - inversion Heqstr.
  - inversion Heqstr.
  - inversion Heqstr.
  - inversion Heqstr.
  - exists []. split. reflexivity.
    intros. inversion H.
  - destruct (IH2 Heqstr) as [ss' [L R]].
    exists (s1::ss'). split.
    + simpl. rewrite <- L. reflexivity.
    + intros s' H. destruct H.
      { rewrite <- H. inversion Heqstr. rewrite H1 in Hmatch1. apply Hmatch1. }
      { apply R. apply H. }
Qed.

(*pumping：一定以上の長さの文字列は分割して判定する。*)
Fixpoint pumping_constant {T} (re : @reg_exp T) : nat :=
  match re with
  | EmptySet => 0
  | EmptyStr => 1
  | Char _ => 2
  | App re1 re2 =>
      pumping_constant re1 + pumping_constant re2
  | Union re1 re2 =>
      pumping_constant re1 + pumping_constant re2
  | Star _ => 1
  end.

Fixpoint napp {T} (n : nat) (l : list T) : list T :=
  match n with
  | 0 => []
  | S n' => l ++ napp n' l
  end.

Lemma napp_plus: forall T (n m : nat) (l : list T),
  napp (n + m) l = napp n l ++ napp m l.
Proof.
  intros T n m l.
  induction n as [|n IHn].
  - reflexivity.
  - simpl. rewrite IHn, app_assoc. reflexivity.
Qed.

Lemma pumping : forall T (re : @reg_exp T) s,
  s =~ re ->
  pumping_constant re <= length s ->
  exists s1 s2 s3,
    s = s1 ++ s2 ++ s3 /\
    s2 <> [] /\
    forall m, s1 ++ napp m s2 ++ s3 =~ re.
Proof.
  intros T re s Hmatch. unfold not.
  induction Hmatch
    as [ | x | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
       | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
       | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2 ].
  -
    simpl. intros. inversion H.
  -
   simpl. intros. inversion H. inversion H2.
  -
   simpl. intros.
Admitted.

(*---Case Study: Improving Reflection---*)

(*ブール演算とPropの関連付けで面倒になる証明*)
Theorem filter_not_empty_In : forall n l,
  filter (fun x => n =? x) l <> [] ->
  In n l.
Proof.
  intros n l. induction l as [|m l' IHl'].
  -
    simpl. intros H. apply H. reflexivity.
  -
    simpl. destruct (n =? m) eqn:H.
    +
      intros _. apply eqb_eq in H. rewrite H.
      left. reflexivity.
    +
      intros H'. right. apply IHl'. apply H'.
Qed.

(*boolからPropへ直接変換する関数を用いる*)
Inductive reflect (P : Prop) : bool -> Prop :=
| ReflectT (H : P) : reflect P true
| ReflectF (H : ~ P) : reflect P false.

Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
  intros P b H. destruct b.
  - apply ReflectT. apply H. reflexivity.
  - apply ReflectF. intros H'. apply H in H'. discriminate.
Qed.

Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof.
  intros. induction H.
  - split. intros. reflexivity. intros. apply H.
  - split. intros. induction H. apply H0. intros. discriminate.
Qed.

Lemma eqbP : forall n m, reflect (n = m) (n == m).
Proof.
  intros n m. apply iff_reflect. split. apply eqb_eq. apply eqb_eq.
Qed.

Theorem filter_not_empty_In' : forall n l,
  filter (fun x => n == x) l <> [] ->
  In n l.
Proof.
  intros n l. induction l as [|m l' IHl'].
  -
    simpl. intros H. apply H. reflexivity.
  -
    simpl. destruct (eqbP n m) as [H | H].
    +
      intros _. rewrite H. left. reflexivity.
    +
      intros H'. right. apply IHl'. apply H'.
Qed.

Fixpoint count n l :=
  match l with
  | [] => 0
  | m :: l' => (if n == m then 1 else 0) + count n l'
  end.

Theorem count_0_app : forall n x l,
   count n (x :: l) = 0 ->  count n (l) = 0.
Proof.
  intros. inversion H. destruct (n == x).
  discriminate. simpl. reflexivity.
Qed.

Theorem In_x_app : forall {X: Type}(n x: X) l,
  In n l -> In n (x:: l).
Proof.
  intros. simpl. right. apply H.
Qed.

Theorem eqbP_practice : forall n l,
  count n l = 0 -> ~(In n l).
Proof.
  unfold not. intros. induction l.
  - inversion H0.
  - apply IHl.
     + apply count_0_app in H. apply H.
     + simpl in H0. inversion H0.
      * rewrite H1 in H. simpl in H. rewrite eqb_nn in H. discriminate.
      * apply H1.
Qed.

Inductive nostutter {X:Type} : list X -> Prop :=
  | st_nil : nostutter []
  | st_2nil (x: X): nostutter [x]
  | st_nm  : forall x h t, nostutter (h :: t) -> ~(x = h) -> nostutter (x :: h :: t).

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
Proof. apply st_nm. apply st_nm. apply st_nm. apply st_nm. apply st_nm. apply st_2nil.
       - unfold not. intros. discriminate.
       - unfold not. intros. discriminate.
       - unfold not. intros. discriminate.
       - unfold not. intros. discriminate.
       - unfold not. intros. discriminate.
Qed.

Example test_nostutter_2: nostutter (@nil nat).
Proof. apply st_nil. Qed.

Example test_nostutter_3: nostutter [5].
Proof. apply st_2nil. Qed.

Example test_nostutter_4: not (nostutter [3;1;1;4]).
Proof. unfold not. intros. inversion H. inversion H2.
       unfold not in H9. apply H9. reflexivity.
Qed.

Inductive pal {X: Type} : list X -> Prop :=
  | pal_nil : pal []
  | pal_one (x: X) : pal [x]
  | pal_add : forall (x: X) l, pal l -> pal (x :: l ++ [x]).

Theorem rev_pal : forall {X: Type} (l: list X),
  pal (l ++ rev l).
Proof.
  intros. induction l.
  - simpl. apply pal_nil.
  - simpl. rewrite app_assoc. apply (pal_add x (l ++ rev l)). apply IHl.
Qed.

Theorem pal_rev : forall {X: Type} (l : list X),
  pal l -> l = rev l.
Proof.
  intros. induction H.
  - simpl. reflexivity. - simpl. reflexivity.
  - simpl. rewrite rev_app_distr. simpl. rewrite <- IHpal. reflexivity.
Qed.

Theorem revpal : forall {X: Type} (l: list X),
  l = rev l -> pal l.
Proof.
  intros. induction l.
  - apply pal_nil.
  - induction IHl.
    + apply pal_one.
    + inversion H. assert ([x0; x0] = (x0 :: [] ++ [x0])). { reflexivity. }
      rewrite H0. apply pal_add. apply pal_nil.
    + simpl in H. inversion H.
Admitted.

Theorem in_x : forall {X: Type} (x: X) (l: list X),
  l = [x] -> In x l.
Proof.
  intros. inversion H. simpl. left. reflexivity.
Qed.

Theorem f_equal : forall {X Y : Type} (x y : X) (f: X-> Y),
 x = y -> f x = f y.
  Proof.
    destruct 1; trivial.
Defined.

Lemma in_split : forall (X:Type) (x:X) (l:list X),
  In x l ->
  exists l1 l2, l = l1 ++ x :: l2.
Proof.
  induction l. simpl. intro. inversion H. destruct 1.
  subst x0; auto.
  exists [], l; auto.
  destruct (IHl H) as (l1, (l2, H0)).
  exists (x::l1), l2; simpl.
Admitted.

(*-------鳩の巣の原理無理だった---------*)
Inductive repeats {X:Type} : list X -> Prop :=
  | repeat (x: X): repeats [x ; x]
  | replace_many (l1 l2 l3: list X): repeats l2 -> repeats (l1 ++ l2 ++ l3).

Example retest : repeats [1; 3; 4; 5; 5].
  apply (replace_many [1; 3; 4] [5; 5] []). apply repeat.
Qed.

Theorem app_one : forall {X: Type} (l: list X) x,
  (x :: l) = [x] ++ l.
Proof. reflexivity. Qed.

Lemma lt_not_eq: forall n:nat , ~(n <n).
Proof.
  unfold not. unfold lt. intros. Search le. induction n. inversion H.
  apply IHn. apply Sn_le_Sm__n_le_m in H. apply H.
Qed.

Lemma le_leftS : forall n m : nat, S n <= m -> n <= m.
Proof. intros. apply le_trans with (S n).
   apply le_S. apply le_n. apply H.
Qed.

Theorem le_le_eq : forall n m, n <= m -> m <= n -> n = m.
Proof.
  intros. inversion H. reflexivity.
  inversion H0. rewrite H3. symmetry. apply H5.

(*induction H. reflexivity. induction H0. reflexivity.*)
Admitted.

Lemma lt_nn : forall n, ~(n < n).
Proof.
 intros. unfold lt. unfold not. intros. induction n. inversion H. apply IHn.
 apply Sn_le_Sm__n_le_m in H. apply H.
Qed.

Lemma lt_not_le: forall n m : nat, n < m -> ~ m <= n.
Proof.
 intros. inversion H.
 - apply lt_not_eq.
 - apply n_le_m__Sn_le_Sm in H0. rewrite H2 in H0. rewrite H2. apply le_leftS in H0. apply le_leftS in H0.
 unfold not. intros.
 unfold not. intros. apply le_le_eq in H0. rewrite H0 in H. apply lt_nn in H. apply H. apply H3.
Qed.

Theorem pigeonhole_principle: forall (X:Type) (l1 l2:list X),
   excluded_middle ->
   (forall x, In x l1 -> In x l2) ->
   length l2 < length l1 ->
   repeats l1.
Proof.
 intros X l1. induction l1 as [|x l1' IHl1'].
 - intros. inversion H1.
 - intros. apply not_exists_dist with  (X:= list X) (P:= repeats) (x:= x:: l1') in H. apply H.
  unfold not. intros. inversion H2. apply H3.

(*  rewrite <- app_nil_r. simpl. rewrite app_one. apply replace_many. apply H.
  unfold not. intros. inversion H2. apply H3. induction x0.
 apply IHl1' with (l2:= l2).
  apply H. intros. apply H0. simpl. right. apply H2.
  apply not_exists_dist with  (X:= nat) (P:= lt (length l2)) (x:= length l1') in H. apply H.
  unfold not. intros. inversion H3. induction x0. *)
Abort.

(*以下の4つはexcluded_middleを含めて等価である。
　証明しろ。*)
Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.

Definition double_negation_elimination := 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).