(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import BinInt BinNat Ring_theory.

Local Open Scope Z_scope.

(** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary
      integer (type [positive]) and [z] a signed integer (type [Z]) *)

Definition Zpower_pos (z:Z) (n:positive) :=
 iter_pos n Z (fun x:Z => z * x) 1.

Definition Zpower (x y:Z) :=
    match y with
      | Zpos p => Zpower_pos x p
      | Z0 => 1
      | Zneg p => 0
    end.

Infix "^" := Zpower : Z_scope.

Lemma Zpower_0_r : forall n, n^0 = 1.
Proof. reflexivity. Qed.

Lemma Zpower_succ_r : forall a b, 0<=b -> a^(Zsucc b) = a * a^b.
Proof.
 intros a [|b|b] Hb; [ | |now elim Hb]; simpl.
 reflexivity.
 unfold Zpower_pos. now rewrite Pplus_comm, iter_pos_plus.
Qed.

Lemma Zpower_neg_r : forall a b, b<0 -> a^b = 0.
Proof.
 now destruct b.
Qed.

Lemma Zpower_theory : power_theory 1 Zmult (eq (A:=Z)) Z_of_N Zpower.
Proof.
 constructor. intros.
 destruct n;simpl;trivial.
 unfold Zpower_pos.
 rewrite <- (Zmult_1_r (pow_pos _ _ _)). generalize 1.
 induction p; simpl; intros; rewrite ?IHp, ?Zmult_assoc; trivial.
Qed.

Lemma Zpower_Ppow : forall p q, (Zpos p)^(Zpos q) = Zpos (p^q).
Proof.
 intros. unfold Ppow, Zpower, Zpower_pos.
 symmetry. now apply iter_pos_swap_gen.
Qed.

Lemma Zpower_Npow : forall n m,
 (Z_of_N n)^(Z_of_N m) = Z_of_N (n^m).
Proof.
 intros [|n] [|m]; simpl; trivial.
 unfold Zpower_pos. generalize 1. induction m; simpl; trivial.
 apply Zpower_Ppow.
Qed.

(** An alternative Zpower *)

(** This Zpower_alt is extensionnaly equal to Zpower in ZArith,
    but not convertible with it. The number of
    multiplications is logarithmic instead of linear, but
    these multiplications are bigger. Experimentally, it seems
    that Zpower_alt is slightly quicker than Zpower on average,
    but can be quite slower on powers of 2.
*)

Definition Zpower_alt n m :=
  match m with
    | Z0 => 1
    | Zpos p => Piter_op Zmult p n
    | Zneg p => 0
  end.

Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope.

Lemma iter_pos_mult_acc : forall f,
 (forall x y:Z, (f x)*y = f (x*y)) ->
 forall p k, iter_pos p _ f k = (iter_pos p _ f 1)*k.
Proof.
 intros f Hf.
 induction p; simpl; intros.
 rewrite IHp. rewrite Hf. f_equal. rewrite (IHp (iter_pos _ _ _ _)).
 rewrite <- Zmult_assoc. f_equal. auto.
 rewrite IHp. rewrite (IHp (iter_pos _ _ _ _)).
 rewrite <- Zmult_assoc. f_equal. auto.
 rewrite Hf. f_equal. now rewrite Zmult_1_l.
Qed.

Lemma Piter_op_square : forall p a,
 Piter_op Zmult p (a*a) = (Piter_op Zmult p a)*(Piter_op Zmult p a).
Proof.
 induction p; simpl; intros; trivial.
 rewrite IHp. rewrite <- !Zmult_assoc. f_equal.
 rewrite Zmult_comm, <- Zmult_assoc.
 f_equal. apply Zmult_comm.
Qed.

Lemma Zpower_equiv : forall a b, a^^b = a^b.
Proof.
 intros a [|p|p]; trivial.
 unfold Zpower_alt, Zpower, Zpower_pos.
 revert a.
 induction p; simpl; intros.
 f_equal.
 rewrite iter_pos_mult_acc.
 now rewrite Piter_op_square, IHp.
 intros. symmetry; apply Zmult_assoc.
 rewrite iter_pos_mult_acc.
 now rewrite Piter_op_square, IHp.
 intros. symmetry; apply Zmult_assoc.
 now rewrite Zmult_1_r.
Qed.

Lemma Zpower_alt_0_r : forall n, n^^0 = 1.
Proof. reflexivity. Qed.

Lemma Zpower_alt_succ_r : forall a b, 0<=b -> a^^(Zsucc b) = a * a^^b.
Proof.
 intros a [|b|b] Hb; [ | |now elim Hb]; simpl.
 now rewrite Zmult_1_r.
 rewrite <- Pplus_one_succ_r. apply Piter_op_succ. apply Zmult_assoc.
Qed.

Lemma Zpower_alt_neg_r : forall a b, b<0 -> a^^b = 0.
Proof.
 now destruct b.
Qed.

Lemma Zpower_alt_Ppow : forall p q, (Zpos p)^^(Zpos q) = Zpos (p^q).
Proof.
 intros. now rewrite Zpower_equiv, Zpower_Ppow.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus Zero (mult y x).


(** A library of operators over relations,
    to define transition sequences and their properties. *)

Set Implicit Arguments.

Section SEQUENCES.

Variable A: Type.                 (**r the type of states *)
Variable R: A -> A -> Prop.       (**r the transition relation between states *)

(** ** Finite sequences of transitions *)

(** Zero, one or several transitions: reflexive transitive closure of [R]. *)

Inductive star: A -> A -> Prop :=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

Lemma star_one:
  forall (a b: A), R a b -> star a b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall (a b: A), star a b -> forall c, star b c -> star a c.
Proof.
  induction 1; eauto using star.
Qed.

(** One or several transitions: transitive closure of [R]. *)

Inductive plus: A -> A -> Prop :=
  | plus_left: forall a b c,
      R a b -> star b c -> plus a c.

Lemma plus_one:
  forall a b, R a b -> plus a b.
Proof.
  eauto using star, plus.
Qed.

Lemma plus_star:
  forall a b,
  plus a b -> star a b.
Proof.
  intros. inversion H. eauto using star.
Qed.

Lemma plus_star_trans:
  forall a b c, plus a b -> star b c -> plus a c.
Proof.
  intros. inversion H. eauto using plus, star_trans.
Qed.

Lemma star_plus_trans:
  forall a b c, star a b -> plus b c -> plus a c.
Proof.
  intros. inversion H0. inversion H; eauto using plus, star, star_trans.
Qed.

Lemma plus_right:
  forall a b c, star a b -> R b c -> plus a c.
Proof.
  eauto using star_plus_trans, plus_one.
Qed.

(** Absence of transitions from a state. *)

Definition irred (a: A) : Prop := forall b, ~(R a b).

(** ** Infinite transition sequences *)

(** It is easy to characterize the fact that all transition sequences starting
  from a state [a] are infinite: it suffices to say that any finite sequence
  starting from [a] can always be extended by one more transition. *)

Definition all_seq_inf (a: A) : Prop :=
  forall b, star a b -> exists c, R b c.

(** However, this is not the notion we are trying to characterize: the case
  where there exists an infinite sequence of transitions starting from [a],
  [a --> a1 --> a2 --> ... -> aN -> ...]
  leaving open the possibility that there exists finite sequences
  starting from [a].

  Example: consider [A = nat] and [R] such that [R 0 0] and [R 0 1].
  [all_seq_inf 0] does not hold, because a sequence [0 -->* 1] cannot
  be extended.  Yet, [R] admits an infinite sequence, namely
  [0 --> 0 --> ...].

  Another attempt would be to represent the sequence of states
  [a0 --> a1 --> a2 --> ... -> aN -> ...] explicitly, as a function
  [f: nat -> A] such that [f i] is the [i]-th state [ai] of the sequence. *)

Definition infseq_with_function (a: A) : Prop :=
  exists f: nat -> A, f 0 = a /\ forall i, R (f i) (f (1 + i)).

(** This is a correct characterization of the existence of an infinite
  sequence of reductions.  However, it is inconvenient to work with
  this definition in Coq's constructive logic: in most use cases, the
  function [f] is not computable and therefore cannot be defined in Coq.

  However, we do not really need the function [f]: its codomain [X] is
  all we need!  What matters is the existence of a set [X] such as
  [a] is in [X], and
  every [b] in [X] can make a transition to an element of [X].
  This suffices to prove the existence of an infinite sequence of transitions
  starting from [a].
*)

Definition infseq (a: A) : Prop :=
  exists X: A -> Prop,
  X a /\ (forall a1, X a1 -> exists a2, R a1 a2 /\ X a2).

(** This definition is essentially a coinduction principle.
  Let us show some expected properties.  For instance: if relation [R]
  contains a cycle, an infinite sequence exists. *)

Remark cycle_infseq:
  forall a, R a a -> infseq a.
Proof.
  intros. exists (fun b => b = a); split.
  auto.
  intros. subst a1. exists a; auto.
Qed.

(** Mon generally: if all sequences from [a] are infinite, there exists one
  infinite sequence starting in [a]. *)

Lemma infseq_if_all_seq_inf:
  forall a, all_seq_inf a -> infseq a.
Proof.
  intros a0 ALL0.
  exists all_seq_inf; split; auto.
  intros a1 ALL1. destruct (ALL1 a1) as [a2 R12]. constructor.
  exists a2; split; auto.
  intros a3 S23. destruct (ALL1 a3) as [a4 R23]. apply star_step with a2; auto.
  exists a4; auto.
Qed.

(** Likewise, the characterization [infseq_with_function] based on functions
  implies [infseq]. *)

Lemma infseq_from_function:
  forall a, infseq_with_function a -> infseq a.
Proof.
  intros a0 (f & F0 & Fn). exists (fun a => exists i, f i = a); split.
- exists 0; auto.
- intros a1 (i1 & F1). subst a1. exists (f (1 + i1)); split; auto. exists (1 + i1); auto.
Qed.

(** An "inversion lemma" for [infseq]: if [infseq a], i.e. there exists
  an infinite sequence starting in [a], then [a] can transition to a state [b]
  that satisfies [infseq b]. *)

Lemma infseq_inv:
  forall a, infseq a -> exists b, R a b /\ infseq b.
Proof.
  intros a (X & Xa & XP). destruct (XP a Xa) as (b & Rab & Xb).
  exists b; split; auto. exists X; auto.
Qed.

(** A very useful coinduction principle considers a set [X] where for
  every [a] in [X], we can make one *or several* transitions to reach
  a state [b] that belongs to [X].  *)

Lemma infseq_coinduction_principle:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, plus a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros X H a0 Xa0.
  exists (fun a => exists b, star a b /\ X b); split.
- exists a0; auto using star_refl.
- intros a1 (a2 & S12 & X2). inversion S12; subst.
  + destruct (H a2 X2) as (a3 & P23 & X3). inversion P23; subst.
    exists b; split; auto. exists a3; auto.
  + exists b; split; auto. exists a2; auto.
Qed.

(** ** Determinism properties for functional transition relations. *)

(** A transition relation is functional if every state can transition
  to at most one other state. *)

Hypothesis R_functional:
  forall a b c, R a b -> R a c -> b = c.

(** Uniqueness of finite transition sequences. *)

Lemma star_star_inv:
  forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
+ right. eauto using star.
+ assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma finseq_unique:
  forall a b b',
  star a b -> irred b ->
  star a b' -> irred b' ->
  b = b'.
Proof.
  intros. destruct (star_star_inv H H1).
- inversion H3; subst. auto. elim (H0 _ H4).
- inversion H3; subst. auto. elim (H2 _ H4).
Qed.

(** A state cannot both diverge and terminate on an irreducible state. *)

Lemma infseq_inv':
  forall a b, R a b -> infseq a -> infseq b.
Proof.
  intros a b Rab Ia.
  destruct (infseq_inv Ia) as (b' & Rab' & Xb').
  assert (b' = b) by (eapply R_functional; eauto).
  subst b'. auto.
Qed.

Lemma infseq_star_inv:
  forall a b, star a b -> infseq a -> infseq b.
Proof.
  induction 1; intros.
- auto.
- apply IHstar. apply infseq_inv' with a; auto.
Qed.

Lemma infseq_finseq_excl:
  forall a b,
  star a b -> irred b -> infseq a -> False.
Proof.
  intros.
  destruct (@infseq_inv b) as (c & Rbc & _). eapply infseq_star_inv; eauto.
  apply (H0 c); auto.
Qed.

(** If there exists an infinite sequence of transitions from [a],
  all sequences of transitions arising from [a] are infinite. *)

Lemma infseq_all_seq_inf:
  forall a, infseq a -> all_seq_inf a.
Proof.
  intros. unfold all_seq_inf. intros.
  destruct (@infseq_inv b) as (c & Rbc & _). eapply infseq_star_inv; eauto.
  exists c; auto.
Qed.

End SEQUENCES.


Require Import Bool Arith List CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive binop : Set := Plus | Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

Eval simpl in expDenote (Const 42).

Eval simpl in expDenote (Binop Plus (Const 2) (Const 4)).

Eval simpl in expDenote (Binop Times (Binop Plus (Const 2) (Const 4)) (Const 7)).

(* Target Language *)
Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
    | iConst n => Some (n :: s)
    | iBinop b =>
      match s with
      | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2 :: s')
      | _ => None
      end
    end.

Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
  | nil => Some s
  | i :: p' =>
    match (instrDenote i s) with
    | None => None
    | Some s' => progDenote p' s'
    end
  end.

Fixpoint compile (e : exp) : prog :=
  match e with
  | Const n => iConst n :: nil
  | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

Eval simpl in compile (Const 42).

Eval simpl in compile (Binop Plus (Const 2) (Const 4)).

Eval simpl in compile (Binop Plus (Binop Times (Const 2) (Const 4)) (Const 7)).

Eval simpl in progDenote (compile (Const 42)).

Eval simpl in progDenote (compile (Binop Plus (Const 2) (Const 4))).

Eval simpl in progDenote (compile (Binop Times (Binop Plus (Const 2) (Const 4)) (Const 7))).

Theorem compile_correct : forall e,
  progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.
  induction e; intros; try reflexivity.
Abort.

Lemma compile_correct' : forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e.
  - intros. unfold compile. unfold progDenote at 1. simpl. fold progDenote. reflexivity.
  - intros. unfold compile. fold compile. unfold progDenote. fold progDenote.
    Check app_assoc_reverse. SearchRewrite ((_ ++ _) ++ _). rewrite app_assoc_reverse.
    rewrite IHe2. rewrite app_assoc_reverse. rewrite IHe1. unfold progDenote at 1. simpl. fold progDenote.
    reflexivity.
Abort.

Lemma compile_correct' : forall e s p,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e; crush.
Qed.

Theorem compile_correct : forall e,
  progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.
  intros.
  Check app_nil_end.
  rewrite (app_nil_end (compile e)).
  rewrite compile_correct'.
  reflexivity.
Qed.

(* Typed Expressions *)

Inductive type : Set := Nat | Bool.

Inductive tbinop : type -> type -> type -> Set :=
 | TPlus : tbinop Nat Nat Nat
 | TTimes : tbinop Nat Nat Nat
 | TEq : forall t, tbinop t t Bool
 | TLt : tbinop Nat Nat Bool.

Inductive texp : type -> Set :=
 | TNConst : nat -> texp Nat
 | TBConst : bool -> texp Bool
 | TBinop : forall t t1 t2, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
  | TPlus => plus
  | TTimes => mult
  | TEq Nat => beq_nat
  | TEq Bool => eqb
  | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop _ _ _ b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Eval simpl in texpDenote (TNConst 42).

Eval simpl in texpDenote (TBConst true).

Eval simpl in texpDenote (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 4)) (TNConst 7)).

Eval simpl in texpDenote (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 4)) (TNConst 7)).

Eval simpl in texpDenote (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

(* Target Language *)

Definition tstack := list type.

Inductive tinstr : tstack -> tstack -> Set :=
 | TiNConst : forall s, nat -> tinstr s (Nat :: s)
 | TiBConst : forall s, bool -> tinstr s (Bool :: s)
 | TiBinop : forall arg1 arg2 res s,
    tbinop arg1 arg2 res -> tinstr (arg1 :: arg2 :: s) (res :: s).

Inductive tprog : tstack -> tstack -> Set :=
 | TNil : forall s, tprog s s
 | TCons : forall s1 s2 s3,
    tinstr s1 s2
    -> tprog s2 s3
    -> tprog s1 s3.

Fixpoint vstack (ts : tstack) : Set :=
  match ts with
    | nil => unit
    | t :: ts' => typeDenote t * vstack ts'
  end%type.

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
    | TiNConst _ n => fun s => (n, s)
    | TiBConst _ b => fun s => (b, s)
    | TiBinop _ _ _ _ b => fun s =>
      let '(arg1, (arg2, s')) := s in
        ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
    | TNil _ => fun s => s
    | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

(* Translation *)

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
    | TNil _ => fun p' => p'
    | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
    | TNConst n => TCons (TiNConst _ n) (TNil _)
    | TBConst b => TCons (TiBConst _ b) (TNil _)
    | TBinop _ _ _ b e1 e2 => tconcat (tcompile e2 _)
      (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

Print tcompile.

Eval simpl in tprogDenote (tcompile (TNConst 42) nil) tt.

Eval simpl in tprogDenote (tcompile (TBConst true) nil) tt.

Eval simpl in tprogDenote (tcompile (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 4)) (TNConst 7)) nil) tt.

Eval simpl in tprogDenote (tcompile (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 4)) (TNConst 7)) nil) tt.

Eval simpl in tprogDenote (tcompile (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 4)) (TNConst 7)) nil) tt.

(* Translation Correctness *)

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
  tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; crush.
Abort.

Lemma tconcat_correct : forall ts ts' ts'' (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
  tprogDenote (tconcat p p') s
  = tprogDenote p' (tprogDenote p s).
Proof.
  induction p; crush.
Qed.

Hint Rewrite tconcat_correct.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
  tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; crush.
Qed.

Hint Rewrite tcompile_correct'.

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Proof.
  induction e; crush.
Qed.

Require Coq.extraction.Extraction.
Extraction Language OCaml.

Extraction tcompile.


(* ========================================================================== *]
 THINGS COQ CAN DO
[* ========================================================================== *)
Require Import Nat List Lia.

Inductive tree {A} :=
| Empty : tree
| Node : tree -> A -> tree -> tree
.

Fixpoint height {A} (t : @tree A) :=
    match t with
    | Empty => 0
    | Node l_t x r_t => 1 + max (height l_t) (height r_t)
    end.

Fixpoint tree_map {A B} (f : A -> B) (t : @tree A) :=
    match t with
    | Empty => Empty
    | Node l_t x r_t => Node (tree_map f l_t) (f x) (tree_map f r_t)
    end.

(* -------------------------------------------------------------------------- *]
 A very useful thing is defining relations between terms (as propositions).
 This is something that we usually do by defining functions that map
 to `bool`, but by defining the relation inductively, allows us to perform
 induction on the 'proof' that two terms are related.

 Consider the following relation, that links trees with the same shape.
[* -------------------------------------------------------------------------- *)

Inductive same_shape {A B} : @tree A -> @tree B -> Prop :=
| both_empty : ???
| both_nodes lt_a lt_b a b rt_a rt_b : ???
.

(* -------------------------------------------------------------------------- *]
 Trees of the same shape have the same height, meaning that height is not
 impacted by the data of the tree (which is obvious to us, but sometimes
 obvious things turn out to be just our imagination...).
[* -------------------------------------------------------------------------- *)

Lemma same_shape_same_height {A B} (ta : @tree A) (tb : @tree B) :
    same_shape ta tb -> height ta = height tb.
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 We can check that functions such as `map` do not alter the shape of the tree,
 only its data.

 Here we need to construct the proof that the trees have the same shape, so
 we apply the constructors of `same_shape`.
[* -------------------------------------------------------------------------- *)

Lemma map_preserves_shape {A B} (f : A -> B) (t : @tree A):
    same_shape t (tree_map f t).
Proof.
    admit.
Qed.

(* -------------------------------------------------------------------------- *]
 Coq also allows the use of 'values' in types. A standard example are vectors,
 which have their length specified as part of their type.
[* -------------------------------------------------------------------------- *)

Inductive vector {A} : nat -> Type :=
| Nil : vector 0
| Cons {n} : A -> vector n -> vector (S n)
.

Example vector_3 : vector 3 := Cons true (Cons true (Cons true Nil)).

(* -------------------------------------------------------------------------- *]
 Types now clearly state what happens to the vector length, which can help us
 avoid issues such as 'index out of range'.
[* -------------------------------------------------------------------------- *)

Fixpoint concat ??? :=
    match v1 with
    | Nil => v2
    | Cons x xs => Cons x (concat xs v2)
    end.

Compute (concat vector_3 vector_3).


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import PL.CoqInductiveType.
Local Open Scope Z.
Local Open Scope string.

(** **** Exercise **** *)
(** 请证明下面引理_[size_nonneg]_。*)

Lemma size_nonneg: forall t,
  0 <= tree_size t.
Proof.
  intros.
  induction t.
  + simpl. reflexivity.
  + simpl.
    lia.
Qed.

(** **** Exercise **** *)
(** 下面定义的_[left_most]_与_[right_most]_函数分别计算了二叉树中最左边的节点编
    号以及最右边的节点编号。如果树是空树，则返回_[default]_参数。请证明下面引理
    _[left_most_reverse]_。*)

Fixpoint left_most (t: tree) (default: Z): Z :=
  match t with
  | Leaf => default
  | Node l n r => left_most l n
  end.

Fixpoint right_most (t: tree) (default: Z): Z :=
  match t with
  | Leaf => default
  | Node l n r => right_most r n
  end.

(** 提示：如果你的前两步证明指令是_[intros]_以及_[induction t]_，那么你会发现，
    归纳步骤的结论是无法证明的。你会发现你需要使用的_[default]_参数与归纳假设中
    的不一致。你可以尝试用_[intros t]_以及_[induction t]_开始你的证明，看看有什
    么不同。*)

Lemma left_most_reverse: forall t default,
  left_most (tree_reverse t) default = right_most t default.
Proof.
  intros t.
  induction t.
  + simpl. reflexivity.
  + simpl.
    rewrite IHt2.
    reflexivity.
Qed.

(** **** Exercise **** *)
(** 下面定义的_[string_rev_append]_是一种用尾递归方法定义字符串左右翻转的方法。
    请你证明它与我们先前定义的_[string_rev]_之间的关系。  *)

Fixpoint string_rev_append (s1 s2: string): string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => string_rev_append s1' (String c s2)
  end.

Lemma string_rev_append_spec: forall s1 s2: string,
  string_rev_append s1 s2 = string_app (string_rev s1) s2.
Proof.
  intros s1.
  induction s1.
  + simpl. reflexivity.
  + simpl.
    intros s2.
    rewrite <- string_app_assoc.
    simpl.
    rewrite IHs1.
    reflexivity.
Qed.


Welcome to Coq 8.4pl6 (January 2017)

Coq < Inductive natlist : Type := | nil : natlist | cons : nat -> natlist -> natlist.
natlist is defined
natlist_rect is defined
natlist_ind is defined
natlist_rec is defined

Coq < Definition mylist := cons 1 (cons 2 (cons 3 nil)).
mylist is defined

Coq < Notation "x :: l" := (cons x l) (at level 60, right associativity).

Coq < Notation "[ ]" := nil.
Setting notation at level 0.

Coq < Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Setting notation at level 0.

Coq < Definition mylist1 := 1 :: (2 :: (3 :: nil)).
mylist1 is defined

Coq < Definition mylist2 := 1 :: 2 :: 3 :: nil.
mylist2 is defined

Coq < Definition mylist3 := [1;2;3].
mylist3 is defined

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

Coq < Fixpoint repeat (n count : nat) : natlist := match count with | O => nil | S count' => n :: (repeat n count') end.
repeat is recursively defined (decreasing on 2nd argument)

Coq < Fixpoint length (l:natlist) : nat := match l with | nil => O | h :: t => S (length t) end.
length is recursively defined (decreasing on 1st argument)

Coq < Fixpoint app (l1 l2 : natlist) : natlist := match l1 with | nil => l2 | h :: t => h :: (app t l2) end.
app is recursively defined (decreasing on 1st argument)

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

Coq < Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
1 subgoal

  ============================
   [1; 2; 3] ++ [4; 5] = [1; 2; 3; 4; 5]

test_app1 < Proof.
1 subgoal

  ============================
   [1; 2; 3] ++ [4; 5] = [1; 2; 3; 4; 5]

test_app1 < reflexivity.
No more subgoals.

test_app1 < Qed.
reflexivity.

test_app1 is defined

Coq < Example test_app2: nil ++ [4;5] = [4;5].
1 subgoal

  ============================
   [] ++ [4; 5] = [4; 5]

test_app2 < Proof.
1 subgoal

  ============================
   [] ++ [4; 5] = [4; 5]

test_app2 < reflexivity.
No more subgoals.

test_app2 < Qed.
reflexivity.

test_app2 is defined

Coq < Example test_app3: [1;2;3] ++ nil = [1;2;3].
1 subgoal

  ============================
   [1; 2; 3] ++ [] = [1; 2; 3]

test_app3 < Proof.
1 subgoal

  ============================
   [1; 2; 3] ++ [] = [1; 2; 3]

test_app3 < reflexivity.
No more subgoals.

test_app3 < Qed.
reflexivity.

test_app3 is defined


(* week-04_live-coding-session.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 05 Sep 2020, after a minimal cleanup *)

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

(* Paraphernalia: *)

Ltac fold_unfold_tactic name :=
  intros; unfold name; fold name; reflexivity.

Require Import Arith Bool.

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

Definition test_power (candidate : nat -> nat -> nat) : bool :=
  (candidate 2 0 =? 1) &&
  (candidate 10 2 =? 10 * 10) &&
  (candidate 3 2 =? 3 * 3).

Definition specification_of_power (power : nat -> nat -> nat) :=
  (forall x : nat,
      power x 0 = 1)
  /\
  (forall (x : nat)
          (n' : nat),
      power x (S n') = x * power x n').

Theorem soundness_of_test_power :
  forall power : nat -> nat -> nat,
    specification_of_power power ->
    test_power power = true.
Proof.
  intro power.
  unfold specification_of_power.
  intros [S_power_O S_power_S].
  unfold test_power.
  Check (S_power_O 2).
  rewrite -> (S_power_O 2).
  Search (_ =? _).
  Check (Nat.eqb_refl 1).
  rewrite -> (Nat.eqb_refl 1).
  Search (true && _ = _).
  Check (true && (true && true), (true && true) && true).
  Check (andb_true_l (power 10 2 =? 100)).
  rewrite -> (andb_true_l (power 10 2 =? 10 * 10)).
  assert (helpful :
            forall x : nat,
              power x 2 = x * x).
  { intro x.
    Check (S_power_S x 1).
    rewrite -> (S_power_S x 1).
    Check (S_power_S x 0).
    rewrite -> (S_power_S x 0).
    rewrite -> (S_power_O x).
    rewrite -> (Nat.mul_1_r x).
    reflexivity. }
  rewrite -> (helpful 10).
  rewrite -> (Nat.eqb_refl (10 * 10)).
  rewrite -> (andb_true_l (power 3 2 =? 3 * 3)).
  rewrite -> (helpful 3).
  rewrite -> (Nat.eqb_refl (3 * 3)).
  reflexivity.
Qed.

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

Proposition identity :
  forall A : Prop,
    A -> A.
Proof.
  intros A H_A.
  apply H_A.
Qed.

(* ***** *)

Proposition modus_ponens :
  forall A B : Prop,
    A -> (A -> B) -> B.
Proof.
  intros A B H_A H_A_implies_B.
  apply H_A_implies_B.
  apply H_A.
  Show Proof.
(*(fun (A B : Prop) (H_A : A) (H_A_implies_B : A -> B) => H_A_implies_B H_A)*)

  Restart.

  intros A B H_A H_A_implies_B.
  Check (H_A_implies_B H_A).
  apply (H_A_implies_B H_A).
  Show Proof.
(*(fun (A B : Prop) (H_A : A) (H_A_implies_B : A -> B) => H_A_implies_B H_A)*)

  Restart.

  intros A B H_A H_A_implies_B.
  assert (H_B := H_A_implies_B H_A).
  apply H_B.
  Show Proof.
(*(fun (A B : Prop) (H_A : A) (H_A_implies_B : A -> B) => (fun H_B : B => H_B) (H_A_implies_B H_A)) *)

Qed.

(* ***** *)

Proposition foo :
  forall A B C1 C2 : Prop,
    A -> (A -> B) -> (B -> C1) /\ (B -> C2) -> C1 /\ C2.
Proof.
  intros A B C1 C2 H_A H_A_implies_B [H_B_implies_C1 H_B_implies_C2].
  split.
  - apply H_B_implies_C1.
    apply H_A_implies_B.
    apply H_A.
  - apply H_B_implies_C2.
    apply H_A_implies_B.
    apply H_A.

  Restart.

  intros A B C1 C2 H_A H_A_implies_B [H_B_implies_C1 H_B_implies_C2].
  - Check (H_A_implies_B H_A).
    Check (H_B_implies_C1 (H_A_implies_B H_A)).
    Check (H_B_implies_C2 (H_A_implies_B H_A)).
    Check (conj (H_B_implies_C1 (H_A_implies_B H_A)) (H_B_implies_C2 (H_A_implies_B H_A))).
    exact (conj (H_B_implies_C1 (H_A_implies_B H_A)) (H_B_implies_C2 (H_A_implies_B H_A))).

  Restart.

  intros A B C1 C2 H_A H_A_implies_B [H_B_implies_C1 H_B_implies_C2].
  apply H_A_implies_B in H_A.
  Check (H_B_implies_C1 H_A).
  Check (H_B_implies_C2 H_A).
  Check (conj (H_B_implies_C1 H_A) (H_B_implies_C2 H_A)).
  exact (conj (H_B_implies_C1 H_A) (H_B_implies_C2 H_A)).

  Restart.

  intros A B C1 C2 H_A H_A_implies_B [H_B_implies_C1 H_B_implies_C2].
  assert (H_B := H_A_implies_B H_A).
  Check (H_B_implies_C1 H_B).
  Check (conj (H_B_implies_C1 H_B) (H_B_implies_C2 H_B)).
  exact (conj (H_B_implies_C1 H_B) (H_B_implies_C2 H_B)).
Qed.

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

Fixpoint power_v0 (x n : nat) : nat :=
  match n with
  | O =>
    1
  | S n' =>
    x * (power_v0 x n')
  end.

Lemma fold_unfold_power_v0_O :
  forall x : nat,
    power_v0 x O =
    1.
Proof.
  fold_unfold_tactic power_v0.
Qed.

Lemma fold_unfold_power_v0_S :
  forall x n' : nat,
    power_v0 x (S n') =
    x * (power_v0 x n').
Proof.
  fold_unfold_tactic power_v0.
Qed.

(* ***** *)

Fixpoint power_v1_aux (x n a : nat) : nat :=
  match n with
  | O =>
    a
  | S n' =>
    power_v1_aux x n' (x * a)
  end.

Lemma fold_unfold_power_v1_aux_O :
  forall x a : nat,
    power_v1_aux x 0 a =
    a.
Proof.
  fold_unfold_tactic power_v1_aux.
Qed.

Lemma fold_unfold_power_v1_aux_S :
  forall x n' a : nat,
    power_v1_aux x (S n') a =
    power_v1_aux x n' (x * a).
Proof.
  fold_unfold_tactic power_v1_aux.
Qed.

Definition power_v1 (x n : nat) : nat :=
  power_v1_aux x n 1.

(* ***** *)

(* Eureka lemma: *)

Lemma about_power_v0_and_power_v1_aux :
  forall x n a : nat,
    power_v0 x n * a = power_v1_aux x n a.
(*
    power_v0 x n is       x * x * ... * x n times

    power_v1_aux x n a is x * x * ... * x * a
 *)
Proof.
  intros x n.
  induction n as [ | n' IHn'].
  - intro a.
    rewrite -> (fold_unfold_power_v0_O x).
    rewrite -> (fold_unfold_power_v1_aux_O x a).
    exact (Nat.mul_1_l a).
  - intro a.
    rewrite -> (fold_unfold_power_v0_S x n').
    rewrite -> (fold_unfold_power_v1_aux_S x n' a).
    Check (IHn' (x * a)).
    rewrite <- (IHn' (x * a)).
    rewrite -> (Nat.mul_comm x (power_v0 x n')).
    Check (Nat.mul_assoc).
    symmetry.
    exact (Nat.mul_assoc (power_v0 x n') x a).
Qed.

(* Lemma that proved unnecessary: *)

Lemma power_v0_and_power_v1_are_equivalent_aux :
  forall x n : nat,
    power_v0 x n = power_v1_aux x n 1.
Proof.
  intros x n.
  induction n as [ | n' IHn'].
  - rewrite -> (fold_unfold_power_v0_O x).
    rewrite -> (fold_unfold_power_v1_aux_O x 1).
    reflexivity.
  - rewrite -> (fold_unfold_power_v0_S x n').
    rewrite -> (fold_unfold_power_v1_aux_S x n' 1).
    rewrite -> (Nat.mul_1_r x).
    Check (about_power_v0_and_power_v1_aux x n' x).
    rewrite <- (about_power_v0_and_power_v1_aux x n' x).
    Check (Nat.mul_comm x (power_v0 x n')).
    exact (Nat.mul_comm x (power_v0 x n')).
Qed.
(*
    case n' as [ | n''].
    + rewrite -> (fold_unfold_power_v0_O x).
      rewrite -> (fold_unfold_power_v1_aux_O x x).
      exact (Nat.mul_1_r x).
    + rewrite -> (fold_unfold_power_v0_S x n'').
      rewrite -> (fold_unfold_power_v1_aux_S x n'' x).
*)

Theorem power_v0_and_power_v1_are_equivalent :
  forall x n : nat,
    power_v0 x n = power_v1 x n.
Proof.
  intros x n.
  unfold power_v1.
  Check (about_power_v0_and_power_v1_aux x n 1).
  rewrite <- (Nat.mul_1_r (power_v0 x n)).
  exact (about_power_v0_and_power_v1_aux x n 1).
Qed.

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

Fixpoint fib (n : nat) : nat :=
  match n with
  | O =>
    0
  | S n' =>
    match n' with
    | O =>
      1
    | S n'' =>
      fib n' + fib n''
    end
  end.

Lemma fold_unfold_lemma_fib_O :
  fib 0 =
  0.
Proof.
  fold_unfold_tactic fib.
 Qed.

Lemma fold_unfold_lemma_fib_S :
  forall n' : nat,
    fib (S n') =
    match n' with
    | O =>
      1
    | S n'' =>
      fib n' + fib n''
    end.
Proof.
  fold_unfold_tactic fib.
Qed.

Corollary fold_unfold_lemma_fib_1 :
  fib 1 =
  1.
Proof.
  Check (fold_unfold_lemma_fib_S 0).
  exact (fold_unfold_lemma_fib_S 0).
Qed.

Corollary fold_unfold_lemma_fib_SS :
  forall n'' : nat,
    fib (S (S n'')) =
    fib (S n'') + fib n''.
Proof.
  intro n''.
  Check (fold_unfold_lemma_fib_S (S n'')).
  exact (fold_unfold_lemma_fib_S (S n'')).
Qed.

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

(* end of week-04_live-coding-session.v *)


(** * ProofObjects: The Curry-Howard Correspondence *)

(**Set Warnings "-notation-overridden,-parsing".*)
Require Export IndProp.

(** "_Algorithms are the computational content of proofs_."  --Robert Harper *)

(** We have seen that Coq has mechanisms both for _programming_,
    using inductive data types like [nat] or [list] and functions over
    these types, and for _proving_ properties of these programs, using
    inductive propositions (like [ev]), implication, universal
    quantification, and the like.  So far, we have mostly treated
    these mechanisms as if they were quite separate, and for many
    purposes this is a good way to think.  But we have also seen hints
    that Coq's programming and proving facilities are closely related.
    For example, the keyword [Inductive] is used to declare both data
    types and propositions, and [->] is used both to describe the type
    of functions on data and logical implication.  This is not just a
    syntactic accident!  In fact, programs and proofs in Coq are
    almost the same thing.  In this chapter we will study how this
    works.

    We have already seen the fundamental idea: provability in Coq is
    represented by concrete _evidence_.  When we construct the proof
    of a basic proposition, we are actually building a tree of
    evidence, which can be thought of as a data structure.

    If the proposition is an implication like [A -> B], then its proof
    will be an evidence _transformer_: a recipe for converting
    evidence for A into evidence for B.  So at a fundamental level,
    proofs are simply programs that manipulate evidence. *)

(** Question: If evidence is data, what are propositions themselves?

    Answer: They are types! *)

(** Look again at the formal definition of the [ev] property.  *)

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

(** Suppose we introduce an alternative pronunciation of "[:]".
    Instead of "has type," we can say "is a proof of."  For example,
    the second line in the definition of [ev] declares that [ev_0 : ev
    0].  Instead of "[ev_0] has type [ev 0]," we can say that "[ev_0]
    is a proof of [ev 0]." *)

(** This pun between types and propositions -- between [:] as "has type"
    and [:] as "is a proof of" or "is evidence for" -- is called the
    _Curry-Howard correspondence_.  It proposes a deep connection
    between the world of logic and the world of computation:

                 propositions  ~  types
                 proofs        ~  data values

    See [Wadler 2015] for a brief history and an up-to-date exposition. *)

(** Many useful insights follow from this connection.  To begin with,
    it gives us a natural interpretation of the type of the [ev_SS]
    constructor: *)

Check ev_SS.
(* ===> ev_SS : forall n,
                  ev n ->
                  ev (S (S n)) *)

(** This can be read "[ev_SS] is a constructor that takes two
    arguments -- a number [n] and evidence for the proposition [ev
    n] -- and yields evidence for the proposition [ev (S (S n))]." *)

(** Now let's look again at a previous proof involving [ev]. *)

Theorem ev_4 : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

(** As with ordinary data values and functions, we can use the [Print]
    command to see the _proof object_ that results from this proof
    script. *)

Print ev_4.
(* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0)
     : ev 4  *)

(** Indeed, we can also write down this proof object _directly_,
    without the need for a separate proof script: *)

Check (ev_SS 2 (ev_SS 0 ev_0)).
(* ===> ev 4 *)

(** The expression [ev_SS 2 (ev_SS 0 ev_0)] can be thought of as
    instantiating the parameterized constructor [ev_SS] with the
    specific arguments [2] and [0] plus the corresponding proof
    objects for its premises [ev 2] and [ev 0].  Alternatively, we can
    think of [ev_SS] as a primitive "evidence constructor" that, when
    applied to a particular number, wants to be further applied to
    evidence that that number is even; its type,

      forall n, ev n -> ev (S (S n)),

    expresses this functionality, in the same way that the polymorphic
    type [forall X, list X] expresses the fact that the constructor
    [nil] can be thought of as a function from types to empty lists
    with elements of that type. *)

(** We saw in the [Logic] chapter that we can use function
    application syntax to instantiate universally quantified variables
    in lemmas, as well as to supply evidence for assumptions that
    these lemmas impose.  For instance: *)

Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

(* ################################################################# *)
(** * Proof Scripts *)

(** The _proof objects_ we've been discussing lie at the core of how
    Coq operates.  When Coq is following a proof script, what is
    happening internally is that it is gradually constructing a proof
    object -- a term whose type is the proposition being proved.  The
    tactics between [Proof] and [Qed] tell it how to build up a term
    of the required type.  To see this process in action, let's use
    the [Show Proof] command to display the current state of the proof
    tree at various points in the following tactic proof. *)

Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

(** At any given moment, Coq has constructed a term with a
    "hole" (indicated by [?Goal] here, and so on), and it knows what
    type of evidence is needed to fill this hole.

    Each hole corresponds to a subgoal, and the proof is
    finished when there are no more subgoals.  At this point, the
    evidence we've built stored in the global context under the name
    given in the [Theorem] command. *)

(** Tactic proofs are useful and convenient, but they are not
    essential: in principle, we can always construct the required
    evidence by hand, as shown above. Then we can use [Definition]
    (rather than [Theorem]) to give a global name directly to this
    evidence. *)

Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

(** All these different ways of building the proof lead to exactly the
    same evidence being saved in the global environment. *)

Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)

(** **** Exercise: 2 stars (eight_is_even)  *)
(** Give a tactic proof and a proof object showing that [ev 8]. *)

Theorem ev_8 : ev 8.
Proof.
  apply ev_SS. apply ev_SS. apply ev_SS. apply ev_SS. apply ev_0.
Qed.

Definition ev_8' : ev 8 :=
  ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0))).
(** [] *)

(* ################################################################# *)
(** * Quantifiers, Implications, Functions *)

(** In Coq's computational universe (where data structures and
    programs live), there are two sorts of values with arrows in their
    types: _constructors_ introduced by [Inductive]ly defined data
    types, and _functions_.

    Similarly, in Coq's logical universe (where we carry out proofs),
    there are two ways of giving evidence for an implication:
    constructors introduced by [Inductive]ly defined propositions,
    and... functions! *)

(** For example, consider this statement: *)

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

(** What is the proof object corresponding to [ev_plus4]?

    We're looking for an expression whose _type_ is [forall n, ev n ->
    ev (4 + n)] -- that is, a _function_ that takes two arguments (one
    number and a piece of evidence) and returns a piece of evidence!

    Here it is: *)

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

(** Recall that [fun n => blah] means "the function that, given [n],
    yields [blah]," and that Coq treats [4 + n] and [S (S (S (S n)))]
    as synonyms. Another equivalent way to write this definition is: *)

Definition ev_plus4'' (n : nat) (H : ev n)
                    : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.
(* ===>
     : forall n : nat, ev n -> ev (4 + n) *)

(** When we view the proposition being proved by [ev_plus4] as a
    function type, one interesting point becomes apparent: The second
    argument's type, [ev n], mentions the _value_ of the first
    argument, [n].

    While such _dependent types_ are not found in conventional
    programming languages, they can be useful in programming too, as
    the recent flurry of activity in the functional programming
    community demonstrates. *)

(** Notice that both implication ([->]) and quantification ([forall])
    correspond to functions on evidence.  In fact, they are really the
    same thing: [->] is just a shorthand for a degenerate use of
    [forall] where there is no dependency, i.e., no need to give a
    name to the type on the left-hand side of the arrow:

           forall (x:nat), nat
        =  forall (_:nat), nat
        =  nat -> nat
*)

(** For example, consider this proposition: *)

Definition ev_plus2 : Prop :=
  forall n, forall (E : ev n), ev (n + 2).

(** A proof term inhabiting this proposition would be a function
    with two arguments: a number [n] and some evidence [E] that [n] is
    even.  But the name [E] for this evidence is not used in the rest
    of the statement of [ev_plus2], so it's a bit silly to bother
    making up a name for it.  We could write it like this instead,
    using the dummy identifier [_] in place of a real name: *)

Definition ev_plus2' : Prop :=
  forall n, forall (_ : ev n), ev (n + 2).

(** Or, equivalently, we can write it in more familiar notation: *)

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n + 2).

(** In general, "[P -> Q]" is just syntactic sugar for
    "[forall (_:P), Q]". *)

(* ################################################################# *)
(** * Programming with Tactics *)

(** If we can build proofs by giving explicit terms rather than
    executing tactic scripts, you may be wondering whether we can
    build _programs_ using _tactics_ rather than explicit terms.
    Naturally, the answer is yes! *)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Compute add1 2.
(* ==> 3 : nat *)

(** Notice that we terminate the [Definition] with a [.] rather than
    with [:=] followed by a term.  This tells Coq to enter _proof
    scripting mode_ to build an object of type [nat -> nat].  Also, we
    terminate the proof with [Defined] rather than [Qed]; this makes
    the definition _transparent_ so that it can be used in computation
    like a normally-defined function.  ([Qed]-defined objects are
    opaque during computation.)

    This feature is mainly useful for writing functions with dependent
    types, which we won't explore much further in this book.  But it
    does illustrate the uniformity and orthogonality of the basic
    ideas in Coq. *)

(* ################################################################# *)
(** * Logical Connectives as Inductive Types *)

(** Inductive definitions are powerful enough to express most of the
    connectives and quantifiers we have seen so far.  Indeed, only
    universal quantification (and thus implication) is built into Coq;
    all the others are defined inductively.  We'll see these
    definitions in this section. *)

Module Props.

(** ** Conjunction

    To prove that [P /\ Q] holds, we must present evidence for both
    [P] and [Q].  Thus, it makes sense to define a proof object for [P
    /\ Q] as consisting of a pair of two proofs: one for [P] and
    another one for [Q]. This leads to the following definition. *)

Module And.

Inductive and (P Q : Prop) : Prop :=
| conj : P -> Q -> and P Q.

End And.

(** Notice the similarity with the definition of the [prod] type,
    given in chapter [Poly]; the only difference is that [prod] takes
    [Type] arguments, whereas [and] takes [Prop] arguments. *)

Print prod.
(* ===>
   Inductive prod (X Y : Type) : Type :=
   | pair : X -> Y -> X * Y. *)

(** This should clarify why [destruct] and [intros] patterns can be
    used on a conjunctive hypothesis.  Case analysis allows us to
    consider all possible ways in which [P /\ Q] was proved -- here
    just one (the [conj] constructor).  Similarly, the [split] tactic
    actually works for any inductively defined proposition with only
    one constructor.  In particular, it works for [and]: *)

Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
Qed.

(** This shows why the inductive definition of [and] can be
    manipulated by tactics as we've been doing.  We can also use it to
    build proofs directly, using pattern-matching.  For instance: *)

Definition and_comm'_aux P Q (H : P /\ Q) :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(** **** Exercise: 2 stars, optional (conj_fact)  *)
(** Construct a proof object demonstrating the following proposition. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun P Q R (PandQ: P/\Q) (QandR: Q/\R) =>
    match PandQ with
      | conj HP HQ => match QandR with
                        | conj HQ HR => conj HP HR
                      end
    end.
(** [] *)

(** ** Disjunction

    The inductive definition of disjunction uses two constructors, one
    for each side of the disjunct: *)

Module Or.

Inductive or (P Q : Prop) : Prop :=
| or_introl : P -> or P Q
| or_intror : Q -> or P Q.

End Or.

(** This declaration explains the behavior of the [destruct] tactic on
    a disjunctive hypothesis, since the generated subgoals match the
    shape of the [or_introl] and [or_intror] constructors.

    Once again, we can also directly write proof objects for theorems
    involving [or], without resorting to tactics. *)

(** **** Exercise: 2 stars, optional (or_commut'')  *)
(** Try to write down an explicit proof object for [or_commut] (without
    using [Print] to peek at the ones we already defined!). *)

Definition or_comm : forall P Q, P \/ Q -> Q \/ P. Admitted.
(** [] *)

(** ** Existential Quantification

    To give evidence for an existential quantifier, we package a
    witness [x] together with a proof that [x] satisfies the property
    [P]: *)

Module Ex.

Inductive ex {A : Type} (P : A -> Prop) : Prop :=
| ex_intro : forall x : A, P x -> ex P.

End Ex.

(** This may benefit from a little unpacking.  The core definition is
    for a type former [ex] that can be used to build propositions of
    the form [ex P], where [P] itself is a _function_ from witness
    values in the type [A] to propositions.  The [ex_intro]
    constructor then offers a way of constructing evidence for [ex P],
    given a witness [x] and a proof of [P x]. *)

(** The more familiar form [exists x, P x] desugars to an expression
    involving [ex]: *)

Check ex (fun n => ev n).
(* ===> exists n : nat, ev n
        : Prop *)

(** Here's how to define an explicit proof object involving [ex]: *)

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(** **** Exercise: 2 stars, optional (ex_ev_Sn)  *)
(** Complete the definition of the following proof object: *)

Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
  ex_intro (fun n => ev (S n)) 1 (ev_SS 0 ev_0).
(** [] *)

(* ================================================================= *)
(** ** [True] and [False] *)

(** The inductive definition of the [True] proposition is simple: *)

Inductive True : Prop :=
  | I : True.

(** It has one constructor (so every proof of [True] is the same, so
    being given a proof of [True] is not informative.) *)

(** [False] is equally simple -- indeed, so simple it may look
    syntactically wrong at first glance! *)

Inductive False : Prop :=.

(** That is, [False] is an inductive type with _no_ constructors --
    i.e., no way to build evidence for it. *)

End Props.

(* ################################################################# *)
(** * Equality *)

(** Even Coq's equality relation is not built in.  It has the
    following inductive definition.  (Actually, the definition in the
    standard library is a small variant of this, which gives an
    induction principle that is slightly easier to use.) *)

Module MyEquality.

Inductive eq {X:Type} : X -> X -> Prop :=
| eq_refl : forall x, eq x x.

Notation "x = y" := (eq x y)
                    (at level 70, no associativity)
                    : type_scope.

(** The way to think about this definition is that, given a set [X],
    it defines a _family_ of propositions "[x] is equal to [y],"
    indexed by pairs of values ([x] and [y]) from [X].  There is just
    one way of constructing evidence for each member of this family:
    applying the constructor [eq_refl] to a type [X] and a value [x :
    X] yields evidence that [x] is equal to [x]. *)

(** We can use [eq_refl] to construct evidence that, for example, [2 =
    2].  Can we also use it to construct evidence that [1 + 1 = 2]?
    Yes, we can.  Indeed, it is the very same piece of evidence!

    The reason is that Coq treats as "the same" any two terms that are
    _convertible_ according to a simple set of computation rules.

    These rules, which are similar to those used by [Compute], include
    evaluation of function application, inlining of definitions, and
    simplification of [match]es.  *)

Lemma four: 2 + 2 = 1 + 3.
Proof.
  apply eq_refl.
Qed.

(** The [reflexivity] tactic that we have used to prove equalities up
    to now is essentially just short-hand for [apply eq_refl].

    In tactic-based proofs of equality, the conversion rules are
    normally hidden in uses of [simpl] (either explicit or implicit in
    other tactics such as [reflexivity]).

    But you can see them directly at work in the following explicit
    proof objects: *)

Definition four' : 2 + 2 = 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X:Type) (x:X), []++[x] = x::[]  :=
  fun (X:Type) (x:X) => eq_refl [x].

End MyEquality.

(** **** Exercise: 2 stars (equality__leibniz_equality)  *)
(** The inductive definition of equality implies _Leibniz equality_:
    what we mean when we say "[x] and [y] are equal" is that every
    property on [P] that is true of [x] is also true of [y].  *)

Lemma equality__leibniz_equality : forall (X : Type) (x y: X),
  x = y -> forall P:X->Prop, P x -> P y.
Proof.
  intros.
  induction H.
  apply H0.
Qed.
(** [] *)

(** **** Exercise: 5 stars, optional (leibniz_equality__equality)  *)
(** Show that, in fact, the inductive definition of equality is
    _equivalent_ to Leibniz equality: *)

Lemma leibniz_equality__equality : forall (X : Type) (x y: X),
  (forall P:X->Prop, P x -> P y) -> x = y.
Proof.
  intros.
  apply H.
  reflexivity.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Inversion, Again *)

(** We've seen [inversion] used with both equality hypotheses and
    hypotheses about inductively defined propositions.  Now that we've
    seen that these are actually the same thing, we're in a position
    to take a closer look at how [inversion] behaves.

    In general, the [inversion] tactic...

    - takes a hypothesis [H] whose type [P] is inductively defined,
      and

    - for each constructor [C] in [P]'s definition,

      - generates a new subgoal in which we assume [H] was
        built with [C],

      - adds the arguments (premises) of [C] to the context of
        the subgoal as extra hypotheses,

      - matches the conclusion (result type) of [C] against the
        current goal and calculates a set of equalities that must
        hold in order for [C] to be applicable,

      - adds these equalities to the context (and, for convenience,
        rewrites them in the goal), and

      - if the equalities are not satisfiable (e.g., they involve
        things like [S n = O]), immediately solves the subgoal. *)

(** _Example_: If we invert a hypothesis built with [or], there are
    two constructors, so two subgoals get generated.  The
    conclusion (result type) of the constructor ([P \/ Q]) doesn't
    place any restrictions on the form of [P] or [Q], so we don't get
    any extra equalities in the context of the subgoal. *)

(** _Example_: If we invert a hypothesis built with [and], there is
    only one constructor, so only one subgoal gets generated.  Again,
    the conclusion (result type) of the constructor ([P /\ Q]) doesn't
    place any restrictions on the form of [P] or [Q], so we don't get
    any extra equalities in the context of the subgoal.  The
    constructor does have two arguments, though, and these can be seen
    in the context in the subgoal. *)

(** _Example_: If we invert a hypothesis built with [eq], there is
    again only one constructor, so only one subgoal gets generated.
    Now, though, the form of the [refl_equal] constructor does give us
    some extra information: it tells us that the two arguments to [eq]
    must be the same!  The [inversion] tactic adds this fact to the
    context. *)

(** $Date: 2017-11-29 14:31:19 -0500 (Wed, 29 Nov 2017) $ *)


Module Playground1.

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

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

Eval simpl in (next_weekday friday).
Eval simpl in (next_weekday (next_weekday saturday)).

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

Proof. simpl. reflexivity. Qed.

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

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

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

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

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

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

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

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

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

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

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

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.

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

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

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

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

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

End Playground1.

Module Playground2.

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

Check S( S( S( S O ) ) ).
Eval simpl in (minustwo 11).
Check S.
Check pred.
Check minustwo.

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

Definition oddb (n:nat) : bool := negb (evenb n).

Eval simpl in ( evenb 10 ). (* true *)
Eval simpl in ( evenb 9).   (* false *)
Eval simpl in ( oddb 10 ).  (* oddb 10 (!?) *)
Eval simpl in ( oddb 9).    (* oddb 9 (!?) *)

Example test_oddb1: (oddb (S O)) = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. simpl. reflexivity. Qed.

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

Eval simpl in (plus (S (S (S O))) (S (S O)) ).

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

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

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

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

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

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

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

(* nat_scope ってなんだろう？ *)

Check (0 + (1 + 1)).
Check (0 + 1) + 1.

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

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

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

Definition blt_nat (n m : nat) : bool := ble_nat (S n) m.
Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

(*
Theorem plus_n_0 : forall n:nat, n + 0 = n.
Proof.
  simpl. reflexivity. Qed.
  (* Error: Impossible to unify "n" with "n + 0". *)
  (* see plus_0_r *)
*)

Eval simpl in (forall n:nat, n + 0 = n).
(*
scripts
     = forall n : nat, n + 0 = n
     : Prop
*)
Eval simpl in (forall n:nat, 0 + n = n).
(*
scripts
     = forall n : nat, n = n
     : Prop
*)
(* 違い：後者は、最初の引数が0なので、match clauseが選べる。再帰不要。 *)

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

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

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.

Proof.
  intros n m o.
  intros H.
  intros I.
  rewrite -> H.
  rewrite -> I.
  reflexivity.
  Qed.

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

Theorem mult_1_plus : forall n m : nat,
  (1 + n) * m = m + (n * m).
Proof.
  intros n m.
  simpl.
  reflexivity.
  Qed.

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

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b as [|].
  simpl. reflexivity.
  simpl. reflexivity.
  Qed.

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

(* tactic Case *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c.
  intros H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H.
    reflexivity.
  Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct c.
  Case "c = true".
    reflexivity.
  Case "c = false".
    rewrite <- H.
    destruct b.
    SCase "b = true".
      reflexivity.
    SCase "b = false".
      reflexivity.
  Qed.

Theorem plus_0_r : forall n : nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity.
  Qed.

Theorem minus_diag : forall n, minus n n = 0.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite <- IHn'. reflexivity.
  Qed.

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

Theorem plus_n_Sm : forall n m : nat, S(n + m) = n + S(m).
Proof.
  intros n m.
  induction n as [|n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S(n')".
    simpl. rewrite -> IHn'. reflexivity.
  Qed.

Theorem plus_comm : forall n m : nat, n + m = m + n.
Proof.
  intros n m.
  induction m as [|m'].
  Case "m = 0".
    simpl. rewrite -> plus_0_r. reflexivity.
  Case "m = S(m')".
    simpl. rewrite <- IHm'. rewrite -> plus_n_Sm. reflexivity.
  Qed.

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

Lemma double_plus : forall n : nat, double n = n + n.
  intros n.
  induction n.
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S(n')".
    simpl. rewrite -> IHn. rewrite -> plus_n_Sm. reflexivity.
  Qed.

(* Exercise destruct_induction
 * induction は コンテキストに induction hypothesis が入る。natでなくても使える。
 *)
(*
Inductive tree : Type :=
| Leaf
| Node : tree -> tree -> tree.

Fixpoint tree_size (t : tree) : nat :=
  match t with
  | Leaf => 1
  | Node t' t'' => tree_size t' + tree_size t''
  end.

Theorem tree_size_plus : forall t u : tree, tree_size(Node t u) = tree_size t + tree_size u.
  intros t u.
  destruct t.
  Case "t = Leaf". simpl. reflexivity.
  Case "t = Node(t1 t2)". simpl. reflexivity.
  Qed.

Theorem tree_size_swap : forall t u : tree, tree_size(Node t u) = tree_size(Node u t).
  intros t u.
  induction u.
  Case "u = Leaf". simpl.
    induction t.
      simpl. reflexivity.
      simpl. rewrite <- tree_size_plus. rewrite <- plus_n_Sm. rewrite -> plus_0_r. reflexivity.
  Case "u = Node(t1 t2)". simpl.
    ...
*)

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

(* Exercise plus_comm_informal

 定理：加法は可換である。すなわち、任意の n, m について、以下が成り立つ。

  n + m = m + n

 証明： m についての帰納法を適用する。

 * まず m = 0 とおくと、証明するべき式は以下のようになる。
   n + 0 = 0 + n
   右辺を + の定義にしたがって簡約すると、 n となる。
   ところで定理「任意のnについて n + 0 = n である」が成り立つので
   左辺も n である。したがって n = n となり、この式は真である。
 * つぎに m = S m' と置き、帰納法の仮定を
   n + m' = m' + n とすると、
   S(n + m') = S(m' + n) も成立する。
   定理「任意の n, m について、S(n + m) = n + S(m) である」で左辺を変形すると：
   S(n + m') = n + S(m') = n + m
   + の定義にしたがって右辺を変形すると：
   S(m' + n) = S(m') + n = m + n
   したがって n + m = m + n が成立する。これは、直後の値について帰納法の仮定が成り立つことを示している。
 (証明終わり)
 *)

Theorem beq_nat_refl : forall n, true = beq_nat n n.
Proof. induction n. simpl. reflexivity.
  simpl. rewrite <- IHn. reflexivity.
  Qed.

(* Exercise beq_nat_refl_informal
 定理：任意の n について n ≧ n は常に真である
 証明：n についての帰納法を適用する。
 * n = 0 のとき: 0 ≧ 0 は真である。これは「≧」の定義より直ちに導かれる。
 * n = S(n') のとき: 帰納法の仮定より n' ≧ n' は真である。
   ここで「≧」の定義より S(n') ≧ S(n') も真である。
   これは成立を示すべき式「n ≧ n は真である」そのものなので、直後の値について帰納法の仮定が成立することが示された。
 (証明終わり)
*)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  assert (H: (m + n) + p = m + (n + p)).
    Case "Proof of assertion".
      rewrite <- plus_assoc. reflexivity.
  rewrite <- H.
  assert (H': m + n = n + m).
    Case "Proof of assertion".
      rewrite <- plus_comm. reflexivity.
  rewrite -> H'.
  rewrite <- plus_assoc.
  reflexivity.
  Qed.

Lemma mult_m_Sn: forall m n : nat,
  m + m * n = m * S n.
Proof.
  intros m n.
  induction m as [|m'].
    Case "m=0". reflexivity.
    Case "m=Sm'".
      simpl. rewrite <- IHm'.
      rewrite <- plus_swap.
      reflexivity.
  Qed.

Theorem mult_comm: forall m n : nat,
  m * n = n * m.
Proof.
  intros m n.
  induction n as [| n'].
  Case "n=0".
    rewrite -> mult_0_r. reflexivity.
  Case "n=S(n')".
    simpl.
    rewrite <- IHn'.
    rewrite -> mult_m_Sn.
    reflexivity.
  Qed.

Theorem ble_nat_refl : forall n:nat,
  true = ble_nat n n.
Proof.
  (* 予想: inductionが必要。そのままじゃ簡約できないし、destructしてもそこで詰む。 *)
  intros n.
  induction n as [|n'].
    Case "n=0". simpl. reflexivity.
    Case "n=Sn'". simpl. rewrite <- IHn'. reflexivity.
  Qed.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  (* 予想: 簡約だけで終わる。 *)
  reflexivity. Qed.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  (* 予想: 簡約のためにはbが邪魔。destructで十分。 *)
  intros b. destruct b. reflexivity. reflexivity. Qed.

Theorem plus_ble_compat_l : forall n m p : nat,
  ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  (* 予想: pについてのinduction。 *)
  intros n m p. intro H.
  induction p as [|p'].
    Case "p=0". simpl. rewrite -> H. reflexivity.
    Case "p=Sp'". simpl. rewrite -> IHp'. reflexivity.
  Qed.

Theorem S_nbeq_0 : forall n:nat,
  beq_nat (S n) 0 = false.
Proof. (* 予想: reflexivityで終了 *)
  reflexivity. Qed.

Theorem mult_1_l : forall n:nat, 1 * n = n.
Proof. (* 予想: 簡約だけで終了。 *)
  intros n.
  simpl.
  rewrite -> plus_0_r. (* 残念 rewriteが必要だった。 これは中でinductionしてる。 *)
  reflexivity.
  Qed.

Theorem all3_spec : forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
           (negb c))
  = true.
Proof. (* 予想: destructが必要。inductionいらない。 *)
  intros b c.
  destruct b.
    Case "b=true". simpl.
      destruct c. reflexivity. reflexivity.
    Case "b=false". reflexivity.
  Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof. (* 予想: pについてのinduction *)
  intros n m.
  intro p.
  induction p as [|p'].
    Case "p=0". rewrite -> mult_0_r.
                rewrite -> mult_0_r.
                rewrite -> mult_0_r. reflexivity.
    Case "p=Sp'". rewrite <- mult_m_Sn.
                  rewrite <- mult_m_Sn.
                  rewrite <- mult_m_Sn.
                  rewrite -> IHp'.
                  rewrite <- plus_assoc.
                  rewrite <- plus_assoc.
                  assert (H: m + (n * p' + m * p') = n * p' + (m + m * p')).
                         rewrite -> plus_swap. reflexivity.
                  rewrite -> H.
                  reflexivity.
  Qed.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof. (* 予想: nについてのinductionでできる。
          が、destructと分配則と交換則でいけそうな気もするので試してみる *)
  intros n m p.
  induction n as [|n'].
    Case "n=0". reflexivity.
    Case "n=Sn'".
      simpl. rewrite -> mult_plus_distr_r.
      (* n' * (m * p) = n' * m * p がでてきてしまったのでやっぱりinduction必要だった *)
      rewrite -> IHn'. reflexivity.
  Qed.

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  replace (n + p) with (p + n).
  replace (n + (m + p)) with ((m + p) + n).
  rewrite -> plus_assoc. reflexivity.
  Case "proof of replace 1".
    rewrite -> plus_comm. reflexivity.
  Case "proof of replace 2".
    rewrite -> plus_comm. reflexivity.
  Qed.

(* (a) *)
Inductive bin : Type :=
| B : bin
| Ev : bin -> bin
| Od : bin -> bin
.

(* (b) *)
Fixpoint bin_succ (x : bin) : bin :=
match x with
| B => Od B
| Ev x' => Od x'
| Od x' => Ev (bin_succ x')
end.

Fixpoint nat_from_bin ( x : bin ) : nat :=
match x with
| B => 0
| Ev x' => nat_from_bin x' + nat_from_bin x'
| Od x' => S(nat_from_bin x' + nat_from_bin x')
end.

(* (c) *)

Theorem binsucc_binnat_compatible: forall x : bin,
  nat_from_bin(bin_succ(x)) = S(nat_from_bin(x)).

Proof.
  intro x.
  induction x as [|x'|x'].
  Case "x=B".
    reflexivity.
  Case "x=Ev x'".
    simpl. reflexivity.
  Case "x=Od x'".
    simpl.
    rewrite -> IHx'. simpl. rewrite -> plus_comm. simpl.
    reflexivity.
    Qed.

(* exercise binary_inverse *)
(* (a) *)

Fixpoint bin_from_nat ( n : nat ) : bin :=
match n with
| O => B
| S n' => bin_succ (bin_from_nat n')
end.

Theorem nat_from_bin_from_nat : forall n : nat,
  nat_from_bin ( bin_from_nat n ) = n.

Proof.
  intros n.
  induction n as [|n'].
  Case "n=0". simpl. reflexivity.
  Case "n=S n'".
    simpl.
    rewrite -> binsucc_binnat_compatible.
    rewrite -> IHn'.
    reflexivity.
  Qed.

(* (b)
  O に対応する二進表現が複数、というか無限にあるため。
  B, Ev B, Ev( Ev B ), ...
  これらはいわゆる leading zero に相当する。
 *)

(* (c) *)

Fixpoint normalize ( x : bin ) : bin :=
  bin_from_nat ( nat_from_bin x ).

Theorem normalize_binsucc : forall x : bin,
   normalize (bin_succ x) = bin_succ (normalize x).
Proof.
  intros x.
  destruct x as [|x'|x'].
  Case "x=B". reflexivity.
  Case "x=Ev x'".
    simpl. reflexivity.
  Case "x=Od x'".
    simpl.
    rewrite -> binsucc_binnat_compatible.
    replace (S (nat_from_bin x') + S (nat_from_bin x')) with
      (S(S(nat_from_bin x' + nat_from_bin x'))).
    SCase "original goal".
      simpl.
      reflexivity.
    SCase "replaced goal".
      simpl. rewrite -> plus_n_Sm. reflexivity.
  Qed.

Theorem normalize_nat : forall n : nat,
  nat_from_bin( normalize ( bin_from_nat n ) ) = n.
Proof.
  intros n.
  induction n as [|n'].
  Case "n=0". reflexivity.
  Case "n=Sn'".
    simpl.
    rewrite -> normalize_binsucc.
    rewrite -> binsucc_binnat_compatible.
    rewrite -> IHn'.
    reflexivity.
  Qed.

Fixpoint bin_plus (x y : bin) : bin :=
  match x with
  | B => y
  | Ev x' => match y with
    | B => x
    | Ev y' => Ev (bin_plus x' y')
    | Od y' => Od (bin_plus x' y')
    end
  | Od x' => match y with
    | B => x
    | Ev y' => Od (bin_plus x' y')
    | Od y' => Ev (bin_succ (bin_plus x' y'))
    end
  end.

Lemma binsucc_left_dec : forall x y : bin,
  bin_succ (bin_plus x y) = bin_plus (bin_succ x) y.
Proof.
  intros x.
  induction x as [|x'|x'].
  Case "B". simpl.
    destruct y as [|y'|y'].
    reflexivity. reflexivity. reflexivity.
  Case "Ev".
    simpl.
    destruct y as [|y'|y'].
    SCase "B". reflexivity.
    SCase "Ev". reflexivity.
    SCase "Od". reflexivity.
  Case "Od". simpl.
    destruct y as [|y'|y'].
    SCase "B". reflexivity.
    SCase "Ev". simpl.
      rewrite -> IHx'.
      reflexivity.
    SCase "Od". simpl.
      rewrite -> IHx'.
      reflexivity.
  Qed.

Theorem nat_from_bin_plus : forall n m : nat,
  bin_from_nat( n + m ) = bin_plus (bin_from_nat n) (bin_from_nat m).
Proof.
  intros n m.
  induction n as [|n'].
  Case "0". reflexivity.
  Case "n'".
    simpl.
    rewrite -> IHn'.
    rewrite -> binsucc_left_dec.
    reflexivity.
  Qed.

Theorem plus_nnmm : forall n m : nat,
  (n + n) + (m + m) = (n + m) + (n + m).
Proof.
  intros n m.
  rewrite -> plus_comm.
  rewrite -> plus_assoc.
  rewrite -> plus_comm.
  rewrite <- plus_assoc.
  replace (m + n) with (n + m).
  assert (H: forall p : nat, n + (m + p) = (n + m) + p).
    intro p. rewrite -> plus_assoc. reflexivity.
  rewrite -> H. reflexivity.
  rewrite -> plus_comm. reflexivity.
  Qed.

Theorem bin_from_nat_plus : forall x y : bin,
  nat_from_bin (bin_plus x y) = (nat_from_bin x) + (nat_from_bin y).
Proof.
  intro x.
  induction x as [|x'|x'].
  Case "B". reflexivity.
  Case "Ev". simpl.
    destruct y as [|y'|y'].
    SCase "B". simpl. rewrite -> plus_0_r. reflexivity.
    SCase "Ev". simpl. rewrite -> IHx'. rewrite -> plus_nnmm. reflexivity.
    SCase "Od". simpl. rewrite -> IHx'.
      rewrite <- plus_n_Sm. rewrite -> plus_nnmm. reflexivity.
  Case "Od". simpl.
    destruct y as [|y'|y'].
    SCase "B". simpl. rewrite -> plus_0_r. reflexivity.
    SCase "Ev". simpl. rewrite -> IHx'. rewrite -> plus_nnmm. reflexivity.
    SCase "Od". simpl. rewrite -> binsucc_binnat_compatible. rewrite -> IHx'.
      rewrite <- plus_n_Sm.
      rewrite <- plus_n_Sm.
      rewrite -> plus_nnmm. reflexivity.
  Qed.

Theorem bin_plus_right_B : forall x : bin,
  bin_plus x B = x.
Proof.
  destruct x as [|x'|x'].
  Case "B". reflexivity.
  Case "Ev". reflexivity.
  Case "Od". reflexivity.
  Qed.

Theorem normalize_expand : forall x : bin,
  normalize x = bin_from_nat (nat_from_bin x).
Proof.
  intro x.
  destruct x as [|x'|x'].
  Case "B". reflexivity.
  Case "Ev". reflexivity.
  Case "Od". reflexivity.
  Qed.

Theorem binplus_comm : forall x y : bin,
  bin_plus x y = bin_plus y x.
Proof.
  intro x.
  induction x as [|x'|x'].
  Case "B". simpl.
    destruct y. reflexivity. reflexivity. reflexivity.
  Case "Ev". simpl.
    destruct y.
    SCase "B". reflexivity.
    SCase "Ev". simpl. rewrite -> IHx'. reflexivity.
    SCase "Od". simpl. rewrite -> IHx'. reflexivity.
  Case "Od". simpl.
    destruct y.
    SCase "B". reflexivity.
    SCase "Od". simpl. rewrite -> IHx'. reflexivity.
    SCase "Ev". simpl. rewrite -> IHx'. reflexivity.
  Qed.

Theorem succ_natbin : forall n : nat,
  bin_from_nat(S n) = bin_succ(bin_from_nat n).
Proof.
  intro n.
  destruct n as [|n'].
  Case "O". reflexivity.
  Case "S". reflexivity.
  Qed.

Theorem normalize_bin_plus : forall x y : bin,
  bin_plus (normalize x) (normalize y) = normalize (bin_plus x y).
Proof.
  intro x.
  induction x as [|x'|x'].
  Case "B". reflexivity.
  Case "Ev". simpl.
    destruct y as [|y'|y'].
    SCase "B". simpl.
      rewrite -> nat_from_bin_plus.
      rewrite -> bin_plus_right_B.
      reflexivity.
    SCase "Ev". simpl.
      rewrite <- nat_from_bin_plus.
      rewrite -> bin_from_nat_plus.
      rewrite -> plus_nnmm. reflexivity.
    SCase "Od".
      simpl.
      rewrite -> binplus_comm.
      rewrite <- binsucc_left_dec.
      assert (H:
        (bin_plus (bin_from_nat (nat_from_bin y' + nat_from_bin y'))
                  (bin_from_nat (nat_from_bin x' + nat_from_bin x')))
      = (bin_from_nat
          (nat_from_bin (bin_plus x' y') + nat_from_bin (bin_plus x' y')))).
      SSCase "H".
        rewrite <- nat_from_bin_plus.
        rewrite -> bin_from_nat_plus.
        rewrite -> plus_comm.
        rewrite -> plus_nnmm. reflexivity.
      SSCase "original".
        rewrite -> H. reflexivity.
  Case "Od".
    simpl.
    destruct y as [|y'|y'].
    SCase "B". simpl. rewrite <- binsucc_left_dec.
      assert (H:
        (bin_plus (bin_from_nat (nat_from_bin x' + nat_from_bin x')) B)
      =           (bin_from_nat (nat_from_bin x' + nat_from_bin x'))
      ).
      SSCase "H".
        rewrite -> binplus_comm. simpl. reflexivity.
      SSCase "original". rewrite -> H. reflexivity.
    SCase "Ev". simpl. rewrite <- binsucc_left_dec.
      assert (H:
        (bin_plus (bin_from_nat (nat_from_bin x' + nat_from_bin x'))
                  (bin_from_nat (nat_from_bin y' + nat_from_bin y')))
      =
        (bin_from_nat
          ( nat_from_bin (bin_plus x' y')
          + nat_from_bin (bin_plus x' y')))
      ).
      SSCase "H".
        rewrite <- nat_from_bin_plus.
        rewrite -> bin_from_nat_plus.
        rewrite -> plus_nnmm. reflexivity.
      SSCase "original". rewrite -> H. reflexivity.
    SCase "Od". simpl.
      rewrite <- binsucc_left_dec.
      rewrite -> binplus_comm.
      rewrite <- binsucc_left_dec.
      rewrite -> binplus_comm.
      rewrite -> binsucc_binnat_compatible.
      rewrite <- plus_n_Sm.
      rewrite -> succ_natbin.
      simpl.
      rewrite <- nat_from_bin_plus.
      rewrite -> bin_from_nat_plus.
      rewrite -> plus_nnmm.
      reflexivity.
  Qed.

Theorem normalize_fixpoint : forall x : bin,
  normalize x = normalize(normalize x).

Proof.
  intros x.

  induction x as [|x'|x'].
  Case "x=B". reflexivity.
  Case "x=Ev x'".
    simpl.
    rewrite -> nat_from_bin_plus.
    replace ( bin_from_nat (nat_from_bin x')) with (normalize x').
    SCase "original goal".
      rewrite <- normalize_bin_plus.
      rewrite <- IHx'. reflexivity.
    SCase "replaced goal".
      destruct x' as [|x''|x''].
        SSCase "B". reflexivity.
        SSCase "Ev".
          simpl. reflexivity.
        SSCase "Od".
          simpl. reflexivity.
  Case "x=Od x'".
    simpl.
    rewrite -> nat_from_bin_plus.
    rewrite -> normalize_binsucc.
    rewrite <- normalize_bin_plus.
    replace ( bin_from_nat (nat_from_bin x')) with (normalize x').
    SCase "original goal".
      rewrite <- IHx'. reflexivity.
    SCase "replaced goal".
      destruct x' as [|x''|x''].
        reflexivity. reflexivity. reflexivity.
  Qed.

(* Exercise 'decreasing' *)
(*
Fixpoint swaprec (n m : nat) : nat :=
match n with
| 0 => 0
| S n' => match m with
  | 0 => 0
  | S m' => swaprec m' n'
  end
end.

  =>  Error: Cannot guess decreasing argument of fix.
*)

End Playground2.


Require Import bool.
Require Import nat.
Require Import Setoid.

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

Arguments nil {a}.
Arguments cons {a} _ _.

Fixpoint repeat (a:Type) (x:a) (count:nat):list a :=
    match count with
    | 0     => nil
    | S n   => cons x (repeat a x n)
    end.

Arguments repeat {a} _ _.

Notation "x :: xs" := (cons x xs) (at level 60, right associativity).
Notation "[]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..). (* syntax file has bug *)

Fixpoint app (a:Type) (k l: list a) : list a :=
    match k with
    | []        => l
    | x::xs     => x :: (app a xs l)
    end.

Arguments app {a} _ _. (* type argument declared as implicit *)

Notation "l ++ k" := (app l k) (at level 60, right associativity).

Theorem  app_nil_r : forall (a:Type) (l:list a), l ++ [] = l.
Proof.
    induction l as [|x xs H].
    - reflexivity.
    - simpl. rewrite H. reflexivity.
Qed.

(* not computationally efficient *)
Fixpoint rev (a:Type) (l:list a) : list a :=
    match l with
    |   []          => []
    |   x :: xs     => (rev a xs) ++ [x]
    end.

Arguments rev {a} _.

Fixpoint length (a:Type) (l:list a) : nat :=
    match l with
    | []        => 0
    | (_::xs)   => S (length a xs)
    end.

Arguments length {a} _.

Theorem app_assoc : forall (a:Type) (l m n: list a),
    l ++ m ++ n = (l ++ m) ++ n.
Proof.
    induction l as [|x xs H].
    - reflexivity.
    - simpl. intros m n. rewrite H. reflexivity.
Qed.

Theorem app_length : forall (a:Type) (l k: list a),
    length (l ++ k) = length l + length k.
Proof.
    induction l as [| x xs H].
    - reflexivity.
    - intro k. simpl. rewrite H. reflexivity.
Qed.

Theorem rev_app_distr : forall (a:Type) (l k: list a),
    rev (l ++ k) = rev k ++ rev l.
Proof.
    induction l as [| x xs H].
    - intro k. simpl. rewrite app_nil_r. reflexivity.
    - intro k. simpl. rewrite H. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall (a:Type) (l: list a),
    rev (rev l) = l.
Proof.
    induction l as [|x xs H].
    - reflexivity.
    - simpl. rewrite rev_app_distr. simpl. rewrite H. reflexivity.
Qed.

(* we are not using app_length, exercise *)
Theorem app_length_cons : forall (a:Type) (l k:list a) (x:a) (n:nat),
    length (l ++ (x :: k)) = n -> S (length (l ++ k)) = n.
Proof.
    intros a l. induction l as [|y ys H].
    - intros k x n. simpl. intros H. exact H.
    - intros k x n. simpl. destruct n.
        + intros H'. inversion H'.
        + intros H'. inversion H' as [H1]. clear H'.
            rewrite H1. apply H in H1. rewrite H1. reflexivity.
Qed.

(* we are not using app_length, exercise *)
Theorem app_length_twice : forall (a:Type) (n:nat) (l:list a),
    length l = n -> length (l ++ l) = n + n.
Proof.
    intros a n l. generalize n. clear n. induction l as [|x xs H].
    - destruct n.
        + intros. reflexivity.
        + intros H. inversion H.
    - destruct n.
        + intros H'. inversion H'.
        + intros H'. inversion H' as [H1]. clear H'.
            simpl. rewrite H1. rewrite (plus_comm n (S n)).
            simpl. apply H in H1.
            assert ( S (length (xs ++ xs)) = length (xs ++ x :: xs)) as H'.
                { apply app_length_cons with (x:=x). reflexivity. }
            rewrite <- H'. rewrite H1. reflexivity.
Qed.

Lemma app_cons : forall (a:Type) (l k:list a) (x:a),
    (x :: l) ++ k = x :: (l ++ k).
Proof. reflexivity. Qed.

Fixpoint eqb_list (a:Type)(eqb: a -> a -> bool) (l k:list a) : bool :=
    match l with
    | []        =>
        match k with
        | []        => true
        | _ :: _    => false
        end
    | x :: xs   =>
        match k with
        | []        => false
        | y :: ys   => eqb x y && eqb_list a eqb xs ys
        end
    end.

Arguments eqb_list {a} _ _ _.

Lemma eqb_list_true_iff : forall (a:Type) (eqb: a -> a -> bool),
    (forall x y, eqb x y = true <-> x = y) ->
    (forall l k, eqb_list eqb l k = true <-> l = k).
Proof.
    intros a eqb H. split.
    - generalize k. clear k. induction l as [|x xs IH].
        + intros [|y ys].
            { intros. reflexivity. }
            { intros H'. inversion H'. }
        + intros [|y ys].
            { intros H'. inversion H'. }
            { intros H'. simpl in H'. rewrite andb_true_iff in H'.
                destruct H' as [H1 H2]. destruct (H x y) as [H' H''].
                apply H' in H1. rewrite H1.
                assert (xs = ys) as E. { apply IH. exact H2. }
                rewrite E. reflexivity. }
    - generalize k. clear k. induction l as [|x xs IH].
        + intros [|y ys].
            { intros. reflexivity. }
            { intros H'. inversion H'. }
        + intros [|y ys].
            { intros H'. inversion H'. }
            { intros H'. inversion H'. simpl. apply andb_true_iff. split.
                { apply H. reflexivity. }
                { rewrite <- H2. apply IH. reflexivity. } }
Qed.

Lemma length_0_iff_nil : forall (a:Type) (l:list a),
    length l = 0 <-> l = nil.
Proof.
    intros a l. split.
    - destruct l as [|x xs].
        + intros. reflexivity.
        + intros H. inversion H.
    - intros H. rewrite H. reflexivity.
Qed.

Lemma l_not_cons_l : forall (a:Type) (l:list a) (x:a),
    ~ (l = x :: l).
Proof.
    intros a l. induction l as [|x xs IH].
    - intros x H. inversion H.
    - intros y H. inversion H. apply (IH y). exact H2.
Qed.

Lemma l_not_l_app : forall (a:Type) (l:list a) (x:a),
    ~ (l = l ++ [x]).
Proof.
    intros a l x H. remember (rev l) as l' eqn:H'.
    assert (l' = x :: l') as H0.
    { rewrite H'. rewrite H at 1. rewrite rev_app_distr. reflexivity. }
    revert H0. apply l_not_cons_l.
Qed.

Lemma list_3_cases : forall (a:Type) (l:list a),
    l = []                              \/
    (exists x, l = [x])                 \/
    (exists x y k, l = x :: k ++ [y])   .
Proof.
    intros a l. induction l as [|x xs [IH|[[y IH]|[x' [y [k IH]]]]]].
    - left. reflexivity.
    - right. left. exists x. rewrite IH. reflexivity.
    - right. right. exists x, y, []. rewrite IH. reflexivity.
    - right. right. exists x, y, (x' :: k). rewrite IH.
        rewrite app_cons. reflexivity.
Qed.

Lemma app_cons' : forall (a:Type) (l k:list a) (x:a),
    l ++ x :: k = (l ++ [x]) ++ k.
Proof.
    intros a l. induction l as [|x xs IH].
    - intros k x. reflexivity.
    - intros k y. rewrite app_cons, app_cons, app_cons.
        rewrite <- (IH k y). reflexivity.
Qed.

Lemma app_injective_l : forall (a:Type) (l k m:list a),
    k ++ l = m ++ l -> k = m.
Proof.
    intros a l. induction l as [|x xs IH].
    - intros k m H. rewrite app_nil_r in H. rewrite app_nil_r in H. exact H.
    - intros k m H.
      rewrite (app_cons' a k xs x) in H.
      rewrite (app_cons' a m xs x) in H.
      apply IH in H.
      assert (rev (k ++ [x])  = rev (m ++ [x])) as H'.
      { rewrite H. reflexivity. }
      rewrite rev_app_distr in H'.
      rewrite rev_app_distr in H'.
      simpl in H'. inversion H' as [H0].
      rewrite <- (rev_involutive a k).
      rewrite <- (rev_involutive a m).
      rewrite H0. reflexivity.
Qed.

Lemma app_injective_r : forall (a:Type) (l k m:list a),
    l ++ k = l ++ m -> k = m.
Proof.
    intros a l. induction l as [|x xs IH].
    - intros k m H. exact H.
    - intros k m H. rewrite app_cons in H. rewrite app_cons in H.
        inversion H as [H']. apply IH. exact H'.
Qed.

Lemma rev_list_3_cases : forall (a:Type) (l:list a), l = rev l ->
    l = []                                          \/
    (exists x, l = [x])                             \/
    (exists x k, l = x :: k ++ [x] /\ k = rev k)    .
Proof.
    intros a l H.
    assert (l = [] \/ (exists x,l = [x]) \/
        (exists x y k, l = x :: k ++ [y])) as [H'|[[x H']|[x [y [k H']]]]].
        { apply list_3_cases. }
    - left. exact H'.
    - right. left. exists x. exact H'.
    - right. right. exists x, k.
        rewrite H' in H at 2. simpl in H. rewrite rev_app_distr in H.
        simpl in H. rewrite H' in H. inversion H as [H0]. split.
        + rewrite H', H0. reflexivity.
        + apply app_injective_l with (l:=[y]). exact H1.
Qed.