(** Brainfuck *)
(** @suharahiromicihi *)
(** 2019_10_26 *)

From mathcomp Require Import all_ssreflect.
Require Import ssrclosure.
Require Import ssrstring.

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

Inductive inst : Set :=                     (* c *)
| ileft                                     (* < *)
| iright                                    (* > *)
| iinc                                      (* + *)
| idec                                      (* - *)
| iin                                       (* , *)
| iout                                      (* . *)
| iloop (i : seq inst)                      (* [ と ] *)
.

Definition cstack := seq inst.              (* c :: cs *)
Definition lstack := seq nat.               (* l :: ls *)
Definition rstack := seq nat.               (* r :: rs *)
Definition input := seq nat.                (* x :: ins *)
Definition output := seq nat.               (* x :: outs *)
Definition env := (cstack * lstack * nat * rstack * input * output)%type.

Inductive step : relation env :=            (* env -> env -> Prop *)
| stepdone x rs ls ins outs :
    step (         [::],     ls,     x,      rs,      ins,      outs)
         (         [::],     ls,     x,      rs,      ins,      outs)
| stepleft_z x cs rs ins outs :             (* < *)
    step (ileft   :: cs,    [::],    x,      rs,      ins,      outs)
         (           cs,    [::],    0, x :: rs,      ins,      outs)
| stepleft_v x y cs ls rs ins outs :        (* < *)
    step (ileft   :: cs, y :: ls,    x,      rs,      ins,      outs)
         (           cs,      ls,    y, x :: rs,      ins,      outs)
| stepright_z x cs ls ins outs :            (* > *)
    step (iright  :: cs,      ls,    x,    [::],      ins,      outs)
         (           cs, x :: ls,    0,    [::],      ins,      outs)
| stepright_v x y cs rs ls ins outs :       (* > *)
    step (iright  :: cs,      ls,    x, y :: rs,      ins,      outs)
         (           cs, x :: ls,    y,      rs,      ins,      outs)
| stepinc x cs rs ls ins outs :             (* + *)
    step (iinc    :: cs,      ls,    x,      rs,      ins,      outs)
         (           cs,      ls, x.+1,      rs,      ins,      outs)
| stepdec x cs rs ls ins outs :             (* - *)
    step (idec    :: cs,      ls,    x,      rs,      ins,      outs)
         (           cs,      ls, x.-1,      rs,      ins,      outs)
| stepin_z x cs rs ls outs :                (* . *)
    step (iin     :: cs,      ls,    x,      rs,     [::],      outs)
         (           cs,      ls,    0,      rs,     [::],      outs)
| stepin_v x y cs rs ls ins outs :          (* . *)
    step (iin     :: cs,      ls,    x,      rs, y :: ins,      outs)
         (           cs,      ls,    y,      rs,      ins,      outs)
| stepout x cs rs ls ins outs :             (* , *)
    step (iout    :: cs,      ls,    x,      rs,      ins,      outs)
         (           cs,      ls,    x,      rs,      ins, x :: outs)
| steploop_z c cs rs ls ins outs :          (* [ *)
    step (iloop c :: cs,      ls,    0,      rs,      ins,      outs)
         (           cs,      ls,    0,      rs,      ins,      outs)
| steploop_v x c cs rs ls ins outs :        (* ] *)
    step (iloop c :: cs,      ls, x.+1,      rs,      ins,      outs)
 (c ++  (iloop c :: cs),      ls, x.+1,      rs,      ins,      outs)
.

Hint Constructors step.
Hint Constructors refl_step_closure.

Definition steprec := refl_step_closure step. (* env -> env -> Prop *)

Infix "|=>" := step (at level 50, no associativity).
Infix "|=>*" := steprec (at level 50, no associativity).

Lemma steprsc_refl (e : env) : e |=>* e.
Proof. done. Qed.

Lemma steprsc_refl' (e1 e2 : env) : e1 = e2 -> e1 |=>* e2.
Proof. by move=> <-. Qed.

Lemma steprsc_step' (e1 e2 : env) : e1 |=> e2 -> e1 |=>* e2.
Proof. by apply: rsc_R. Qed.

Lemma steprsc_step (e1 e2 e3 : env) : e1 |=> e2 -> e2 |=>* e3 -> e1 |=>* e3.
Proof. by apply: rsc_step. Qed.

Lemma steprsc_trans (e1 e2 e3 : env) : e1 |=>* e2 -> e2 |=>* e3 -> e1 |=>* e3.
Proof. by apply: rsc_trans. Qed.

Theorem decide_step (e1 : env) : exists (e2 : env), e1 |=> e2.
Proof.
  case: e1  => [[[[[cs ls] x] rs] ins] outs].
  case: cs => [|c cs].
  - by eexists; constructor.
  - case: c.
    + case: ls => [|x' ls']; by eexists; constructor.   (* < *)
    + case: rs => [|x' rs']; by eexists; constructor.   (* > *)
    + by eexists; constructor.                          (* + *)
    + by eexists; constructor.                          (* - *)
    + case: ins => [|x' ins']; by eexists; constructor. (* . *)
    + by eexists; constructor.                          (* , *)
    + move=> cs'.
      case: x => [| x']; by eexists; constructor. (* [ と ] *)
Defined.

Ltac stepstep_0 e1 e2 :=
  match eval hnf in (decide_step e1) with
  | (ex_intro _ _ ?p) => apply: (steprsc_step p)
  end.
Check ex_intro.
(* ex_intro P x H の
   P = (fun e2 : env => e1 |=> e2)
   x = e2
   H : e1 |=> e2、なる 命題
*)

Ltac stepstep :=
  match goal with
  | |- ?e1 |=>* ?e2 => stepstep_0 e1 e2
  end.

Definition sample :=
  [:: ileft;
     iinc;
     iout;
     ileft
  ].

Goal (sample, [::], 0, [::], [::], [::]) |=>*
     ([::],   [::], 0, [:: 1; 0], [::], [:: 1]).
Proof.
  do !stepstep.
  (* これが、無限ループにならないのは、cstack が空になるから。 *)
  done.
Qed.

Lemma test : exists x ls rs outputs,
    (sample, [::], 0, [::], [::], [::]) |=>* ([::], ls, x, rs, [::], outputs).
Proof.
  eexists.
  eexists.
  eexists.
  eexists.
  do !stepstep.
  match goal with
  | |- ?e1 |=>* ?e2 => idtac e2
  end.
  done.
Qed.

Print test.
(*
  これから
  ex_intro _ x (ex_intro ls (ex_intro rs (ex_intro out _)))
  をパターンを取り出すと、より計算しているように見える。
*)

(*
Variable H1 : ([:: vn 1], [:: idrop; idrop]) |=> ([::], [:: idrop]).
Variable H2 : ([::], [:: idrop]) |=> ([::], [::]).
Variable H3 : ([::], [::]) |=> ([::], [::]).

Goal ([:: vn 1], sample) |=>* ([::], [::]).
Proof.
  Check exists e2 : env, ([:: vn 1], sample) |=> e2.
  Check ex_intro (fun e2 : env => ([:: vn 1], [:: idrop; idrop]) |=> e2)
        ([::], [:: idrop])
        H1.
  apply: (steprsc_step H1).

  Check ex_intro (fun e2 : env => ([::], [:: idrop]) |=> e2)
        ([::], [::])
        H2.
  apply: (steprsc_step H2).

  Check ex_intro (fun e2 : env => ([::], [::]) |=> e2)
        ([::], [::])
        H3.
  apply: (steprsc_step H3).                 (* もう、進まない。 *)
  done.
Qed.
*)

(* ********* *)
(* Hello World!\n *)
(* ********* *)

(*
>+++++ +++++             initialize counter (cell #0) to 10
[                       use loop to set 70/100/30/10
    > +++++ ++              add  7 to cell #1
    > +++++ +++++           add 10 to cell #2
    > +++                   add  3 to cell #3
    > +                     add  1 to cell #4
<<<< -                  decrement counter (cell #0)
]
> ++ .                  print 'H'
> + .                   print 'e'
+++++ ++ .              print 'l'
.                       print 'l'
+++ .                   print 'o'
> ++ .                  print ' '
<< +++++ +++++ +++++ .  print 'W'
> .                     print 'o'
+++ .                   print 'r'
----- - .               print 'l'
----- --- .             print 'd'
> + .                   print '!'
> .                     print '\n'
 *)

Definition hello :=
  [::iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; (* 10 *)
     iloop [::iright; iinc; iinc; iinc; iinc; iinc; iinc; iinc; (* 7 *)
              iright; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; (* 10 *)
                iright; iinc; iinc; iinc;   (* 3 *)
                  iright; iinc;             (* 1 *)
                    ileft; ileft; ileft; ileft; idec];
     (* 70 100 30 10 *)
     iright; iinc; iinc; iout;                           (* H *)
       iright; iinc; iout;                               (* e *)
         iinc; iinc; iinc; iinc; iinc; iinc; iinc; iout; (* l *)
           iout;                                         (* l *)
           iinc; iinc; iinc; iout;                       (* o *)
             iright; iinc; iinc; iout;                   (*   *)
               ileft; ileft; iinc; iinc; iinc; iinc; iinc;
                 iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iout; (* W *)
                   iright; iout;             (* o *)
                     iinc; iinc; iinc; iout; (* r *)
                       idec; idec; idec; idec; idec; idec; iout; (* l *)
                         idec; idec; idec; idec; idec; idec; idec; idec; iout; (* d *)
                           iright; iinc; iout; (* ! *)
                             iright; iout].    (* \n *)

Goal exists ls x rs ins,
    (hello, [::], 0, [::], [::], [::])
      |=>*
      ([::], ls, x, rs, ins,
       [:: 10; 33; 100; 108; 114; 111; 87; 32; 111; 108; 108; 101; 72]).
(* \n ! d l r o W ' ' o l l e H *)
Proof.
  do !eexists.
  do !stepstep => /=.
  done.
Qed.

(* ****** *)
(* Parser *)
(* ****** *)

(* このパーサは、特に以下を参考にしました。 *)
(* https://qiita.com/erutuf13/items/98f15cc7e74b0570c971 *)

Fixpoint parse' (str : string) : (cstack * seq cstack)%type :=
  match str with
  | ""%string => ([::], [::])
  | String x xs =>
    let (body, rest) := parse' xs in
    match x with
    | ">"%char => (iright :: body, rest)
    | "<"%char => (ileft  :: body, rest)
    | "+"%char => (iinc   :: body, rest)
    | "-"%char => (idec   :: body, rest)
    | ","%char => (iin    :: body, rest)
    | "."%char => (iout   :: body, rest)
    | "["%char =>
      match rest with
      | [::]       => ([:: iloop body], [::])
      | s :: rest' => (iloop body :: s, rest')
      end
    | "]"%char => ([::], body :: rest)
    | _        => ([::], [::])
    end
  end.

Definition parse str := (parse' str).1.

Compute parse ",>,<[-<+>]<.".
Compute parse ",>,<[->[->>+<<]>>[-<+<+>>]<<<]>>.".
Compute parse "+[>.+<]".

(* END *)


Require Import VST.floyd.proofauto.
Require Import sha.SHA256.
Require Import sha.sha.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.

Lemma Zland_15:
 forall i, Z.land i 15 = i mod 16.
Proof.
intros.
change 15%Z with (Z.ones 4).
rewrite Z.land_ones by (compute; congruence).
reflexivity.
Qed.

Lemma Znth_nthi:
  forall i b,
  (0 <= i < Zlength b)%Z -> Znth i b = nthi b i.
Proof.
intros; unfold Znth.
rewrite if_false by omega.
reflexivity.
Qed.

Hint Rewrite Znth_nthi using (auto; omega) : sublist.

Lemma Zland_in_range:
  forall i, (0 <= Z.land i 15 < 16)%Z.
Proof.
intros.
rewrite Zland_15. apply Z_mod_lt. compute; congruence.
Qed.
Hint Resolve Zland_in_range.

Lemma and_mone':
 forall x, Int.and x (Int.repr (-1)) = x.
Proof.
apply Int.and_mone.
Qed.

Lemma Sigma_1_eq: forall f_,
  Sigma_1 f_ =
            (Int.xor
              (Int.xor
                 (Int.or (Int.shl f_ (Int.repr 26))
                    (Int.shru (Int.and f_ (Int.repr (-1)))
                       (Int.sub (Int.repr 32) (Int.repr 26))))
                 (Int.or (Int.shl f_ (Int.repr 21))
                    (Int.shru (Int.and f_ (Int.repr (-1)))
                       (Int.sub (Int.repr 32) (Int.repr 21)))))
              (Int.or (Int.shl f_ (Int.repr 7))
                 (Int.shru (Int.and f_ (Int.repr (-1)))
                    (Int.sub (Int.repr 32) (Int.repr 7))))).
Proof.
intros.
unfold Sigma_1, Rotr.
repeat rewrite and_mone'.
repeat rewrite <- Int.or_ror by reflexivity.
change (Int.sub (Int.repr 32) (Int.repr 26)) with (Int.repr 6).
change (Int.sub (Int.repr 32) (Int.repr 21)) with (Int.repr 11).
change (Int.sub (Int.repr 32) (Int.repr 7)) with (Int.repr 25).
reflexivity.
Qed.

Lemma  Sigma_0_eq: forall b_,
   Sigma_0 b_ =
      (Int.xor
        (Int.xor
           (Int.or (Int.shl b_ (Int.repr 30))
              (Int.shru (Int.and b_ (Int.repr (-1)))
                 (Int.sub (Int.repr 32) (Int.repr 30))))
           (Int.or (Int.shl b_ (Int.repr 19))
              (Int.shru (Int.and b_ (Int.repr (-1)))
                 (Int.sub (Int.repr 32) (Int.repr 19)))))
        (Int.or (Int.shl b_ (Int.repr 10))
           (Int.shru (Int.and b_ (Int.repr (-1)))
              (Int.sub (Int.repr 32) (Int.repr 10))))).
Proof.
intros.
unfold Sigma_0, Rotr.
repeat rewrite and_mone'.
repeat rewrite <- Int.or_ror by reflexivity.
change (Int.sub (Int.repr 32) (Int.repr 19)) with (Int.repr 13).
change (Int.sub (Int.repr 32) (Int.repr 10)) with (Int.repr 22).
change (Int.sub (Int.repr 32) (Int.repr 30)) with (Int.repr 2).
reflexivity.
Qed.

Lemma Ch_eq: forall f_ g_ h_,
  Ch f_ g_ h_ =
        (Int.xor (Int.and f_ g_) (Int.and (Int.not f_) h_)).
Proof. reflexivity.
Qed.

Lemma Maj_eq:
  forall b c d,
  Maj b c d =
  (Int.xor (Int.xor (Int.and b c) (Int.and b d)) (Int.and c d)).
Proof.
intros.
unfold Maj.
rewrite (Int.xor_commut) at 1.
rewrite Int.xor_assoc. auto.
Qed.

Lemma sigma_1_eq:
 forall s, sigma_1 s =
   Int.xor
     (Int.xor
        (Int.or (Int.shl s (Int.repr 15))
           (Int.shru s (Int.sub (Int.repr 32) (Int.repr 15))))
        (Int.or (Int.shl s (Int.repr 13))
           (Int.shru s (Int.sub (Int.repr 32) (Int.repr 13)))))
  (Int.shru s (Int.repr 10)).
Proof.
intros.
unfold sigma_1.
f_equal. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
Qed.

Lemma sigma_0_eq:
 forall s, sigma_0 s =
  Int.xor
   (Int.xor
     (Int.or (Int.shl s (Int.repr 25))
        (Int.shru s (Int.sub (Int.repr 32) (Int.repr 25))))
     (Int.or (Int.shl s (Int.repr 14))
        (Int.shru s (Int.sub (Int.repr 32) (Int.repr 14)))))
   (Int.shru s (Int.repr 3)).
Proof.
intros.
unfold sigma_0.
f_equal. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
Qed.

Lemma and_mod_15_lem:
 forall (n: Z),
 (0 <= Int.signed (Int.and (Int.repr n) (Int.repr 15)) < 16)%Z.
Proof.
intro n.
unfold Int.and.
rewrite (Int.unsigned_repr 15) by rep_omega.
change 15%Z with (Z.ones 4).
assert (0 <= Z.land (Int.unsigned (Int.repr n)) (Z.ones 4) < 16)%Z.
rewrite Z.land_ones.
apply Z.mod_bound_pos.
apply Int.unsigned_range. clear; omega. clear; omega.
rewrite Int.signed_repr; auto.
rep_omega.
Qed.

Definition c64 := 64%nat.  Global Opaque c64.
Definition c48 := 48%nat.  Global Opaque c48.


(** * Norm_J: STLCの正規化 *)
(* * Norm: Normalization of STLC *)

(* $Date: 2011-04-13 14:34:47 -0400 (Wed, 13 Apr 2011) $ *)
(* Chapter maintained by Andrew Tolmach *)

(* (Based on TAPL Ch. 12.) *)

Require Import Stlc_J.
Require Import Relations.

(*
(This chapter is optional.)

In this chapter, we consider another fundamental theoretical property
of the simply typed lambda-calculus: the fact that the evaluation of a
well-typed program is guaranteed to halt in a finite number of
steps---i.e., every well-typed term is _normalizable_.

Unlike the type-safety properties we have considered so far, the
normalization property does not extend to full-blown programming
languages, because these languages nearly always extend the simply
typed lambda-calculus with constructs, such as general recursion
(as we discussed in the MoreStlc chapter) or recursive types, that can
be used to write nonterminating programs.  However, the issue of
normalization reappears at the level of _types_ when we consider the
metatheory of polymorphic versions of the lambda calculus such as
F_omega: in this system, the language of types effectively contains a
copy of the simply typed lambda-calculus, and the termination of the
typechecking algorithm will hinge on the fact that a ``normalization''
operation on type expressions is guaranteed to terminate.

Another reason for studying normalization proofs is that they are some
of the most beautiful---and mind-blowing---mathematics to be found in
the type theory literature, often (as here) involving the fundamental
proof technique of _logical relations_.

The calculus we shall consider here is the simply typed
lambda-calculus over a single base type [bool] and with pairs. We'll
give full details of the development for the basic lambda-calculus
terms treating [bool] as an uninterpreted base type, and leave the
extension to the boolean operators and pairs to the reader.  Even for
the base calculus, normalization is not entirely trivial to prove,
since each reduction of a term can duplicate redexes in subterms. *)
(**
(この章はオプションです。)

この章では、単純型付きラムダ計算の別の基本的な理論的性質を検討します。
型付けされるプログラムは有限回のステップで停止することが保証されるという事実です。
つまり、すべての型付けされた項は正規化可能(_normalizable_)です。

ここまで考えてきた型安全性とは異なり、
正規化性は本格的なプログラミング言語には拡張されません。
なぜなら、本格的な言語ではほとんどの場合、単純型付きラムダ計算に、
(MoreStlc_J章で議論したような)一般再帰や再帰型が拡張され、
停止しないプログラムが書けるようになっているからです。
しかし、正規化性の問題は「型のレベル」で再度現れます。
それが現れるのは、F_ωのようなラムダ計算の多相バージョンの、メタ理論を考えるときです。
F_ωでは、型の言語は単純型付きラムダ計算のコピーを効果的に包括しており、
型チェックアルゴリズムの停止性は、
型の式の「正規化」操作が停止することが保証されていることに依拠しています。

正規化の証明を学習する別の理由は、それが、
(ここでやっているように)論理的関係の基本的証明テクニックを含むような型理論の文献に見られる、
一番美しい---そして刺激的な---数学だからです。

ここで考える計算は、基本型[bool]と対を持つ単純型付きラムダ計算です。
ここでは[bool]を未解釈基本型として扱う基本ラムダ計算項の処理を細部まで示します。
ブール演算と対の拡張は読者に残しておきます。
基本計算においてさえ、正規化は証明が完全に自明ということはありません。
なぜなら、項の各簡約は部分項のリデックスを複製することがあるからです。 *)

(* **** Exercise: 1 star *)
(** **** 練習問題: ★ *)
(* Where do we fail if we attempt to prove normalization by a
straightforward induction on the size of a well-typed term? *)
(** 型付けされた項のサイズについての素直な帰納法で正規化性を証明しようとしたとき、
    どこで失敗するでしょうか？ *)

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

(* ###################################################################### *)
(* * Language *)
(** * 言語 *)

(* We begin by repeating the relevant language definition, which is
similar to those in the MoreStlc chapter, and supporting results
including type preservation and step determinism.  (We won't need
progress.)  You may just wish to skip down to the Normalization
section... *)
(** 関係する言語の定義から始めます。MoreStlc_J章のものと同様です。
そして、型の保存とステップの決定性を含む結果も成立します。
(進行は使いません。)
正規化の節まで飛ばしても構いません... *)

(* ###################################################################### *)
(* *** Syntax and Operational Semantics *)
(** *** 構文と操作的意味 *)

Inductive ty : Type :=
  | ty_Bool : ty
  | ty_arrow : ty -> ty -> ty
  | ty_prod  : ty -> ty -> ty
.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ty_Bool" | Case_aux c "ty_arrow" | Case_aux c "ty_prod" ].

Inductive tm : Type :=
    (* pure STLC *)
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
    (* pairs *)
  | tm_pair : tm -> tm -> tm
  | tm_fst : tm -> tm
  | tm_snd : tm -> tm
    (* booleans *)
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm.
          (* i.e., [if t0 then t1 else t2] *)

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tm_var" | Case_aux c "tm_app" | Case_aux c "tm_abs"
  | Case_aux c "tm_pair" | Case_aux c "tm_fst" | Case_aux c "tm_snd"
  | Case_aux c "tm_true" | Case_aux c "tm_false" | Case_aux c "tm_if" ].

(* ###################################################################### *)
(* *** Substitution *)
(** *** 置換 *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tm_var y => if beq_id x y then s else t
  | tm_abs y T t1 =>  tm_abs y T (if beq_id x y then t1 else (subst x s t1))
  | tm_app t1 t2 => tm_app (subst x s t1) (subst x s t2)
  | tm_pair t1 t2 => tm_pair (subst x s t1) (subst x s t2)
  | tm_fst t1 => tm_fst (subst x s t1)
  | tm_snd t1 => tm_snd (subst x s t1)
  | tm_true => tm_true
  | tm_false => tm_false
  | tm_if t0 t1 t2 => tm_if (subst x s t0) (subst x s t1) (subst x s t2)
  end.

(* ###################################################################### *)
(* *** Reduction *)
(** *** 簡約 *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tm_abs x T11 t12)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (tm_pair v1 v2)
  | v_true : value tm_true
  | v_false : value tm_false
.

Hint Constructors value.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tm_app (tm_abs x T11 t12) v2) ==> (subst x v2 t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tm_app t1 t2) ==> (tm_app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tm_app v1 t2) ==> (tm_app v1 t2')
  (* pairs *)
  | ST_Pair1 : forall t1 t1' t2,
        t1 ==> t1' ->
        (tm_pair t1 t2) ==> (tm_pair t1' t2)
  | ST_Pair2 : forall v1 t2 t2',
        value v1 ->
        t2 ==> t2' ->
        (tm_pair v1 t2) ==> (tm_pair v1 t2')
  | ST_Fst : forall t1 t1',
        t1 ==> t1' ->
        (tm_fst t1) ==> (tm_fst t1')
  | ST_FstPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (tm_fst (tm_pair v1 v2)) ==> v1
  | ST_Snd : forall t1 t1',
        t1 ==> t1' ->
        (tm_snd t1) ==> (tm_snd t1')
  | ST_SndPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (tm_snd (tm_pair v1 v2)) ==> v2
  (* booleans *)
  | ST_IfTrue : forall t1 t2,
        (tm_if tm_true t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
        (tm_if tm_false t1 t2) ==> t2
  | ST_If : forall t0 t0' t1 t2,
        t0 ==> t0' ->
        (tm_if t0 t1 t2) ==> (tm_if t0' t1 t2)

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Pair1" | Case_aux c "ST_Pair2"
    | Case_aux c "ST_Fst" | Case_aux c "ST_FstPair"
    | Case_aux c "ST_Snd" | Case_aux c "ST_SndPair"
  | Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Notation stepmany := (refl_step_closure step).
Notation "t1 '==>*' t2" := (stepmany t1 t2) (at level 40).

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Lemma value__normal : forall t, value t -> step_normal_form t.
Proof with eauto.
  intros t H; induction H; intros [t' ST]; inversion ST...
Qed.

(* ###################################################################### *)
(* *** Typing *)
(** *** 型付け *)

Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=
  (* Typing rules for proper terms *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tm_var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tm_abs x T11 t12) (ty_arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (ty_arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tm_app t1 t2) T2
  (* pairs *)
  | T_Pair : forall Gamma t1 t2 T1 T2,
      has_type Gamma t1 T1 ->
      has_type Gamma t2 T2 ->
      has_type Gamma (tm_pair t1 t2) (ty_prod T1 T2)
  | T_Fst : forall Gamma t T1 T2,
      has_type Gamma t (ty_prod T1 T2) ->
      has_type Gamma (tm_fst t) T1
  | T_Snd : forall Gamma t T1 T2,
      has_type Gamma t (ty_prod T1 T2) ->
      has_type Gamma (tm_snd t) T2
  (* booleans *)
  | T_True : forall Gamma,
      has_type Gamma tm_true ty_Bool
  | T_False : forall Gamma,
      has_type Gamma tm_false ty_Bool
  | T_If : forall Gamma t0 t1 t2 T,
      has_type Gamma t0 ty_Bool ->
      has_type Gamma t1 T ->
      has_type Gamma t2 T ->
      has_type Gamma (tm_if t0 t1 t2) T
.

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Pair" | Case_aux c "T_Fst" | Case_aux c "T_Snd"
  | Case_aux c "T_True" | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Extern 2 (has_type _ (tm_app _ _) _) => eapply T_App; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

(* ###################################################################### *)
(* *** Context Invariance *)
(** *** コンテキスト不変性 *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tm_abs y T11 t12)
  (* pairs *)
  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tm_pair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tm_pair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (tm_fst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (tm_snd t)
  (* booleans *)
  | afi_if0 : forall x t0 t1 t2,
      appears_free_in x t0 ->
      appears_free_in x (tm_if t0 t1 t2)
  | afi_if1 : forall x t0 t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tm_if t0 t1 t2)
  | afi_if2 : forall x t0 t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tm_if t0 t1 t2)
.

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold extend. remember (beq_id x y) as e.
    destruct e...
  Case "T_Pair".
    apply T_Pair...
  Case "T_If".
    eapply T_If...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    apply not_eq_beq_id_false in H2. rewrite H2 in Hctx...
Qed.

Corollary typable_empty__closed : forall t T,
    has_type empty t T  ->
    closed t.
Proof.
  intros. unfold closed. intros x H1.
  destruct (free_in_context _ _ _ _ H1 H) as [T' C].
  inversion C.  Qed.

(* ###################################################################### *)
(* *** Preservation *)
(** *** 保存 *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma (subst x v t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- (subst x v t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tm_var and tm_abs.
     The former aren't automatic because we must reason about how the
     variables interact. *)
  tm_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tm_var".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- subst x v y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [subst x v y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      apply beq_id_eq in Heqe. subst.
      unfold extend in H1. rewrite <- beq_id_refl in H1.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var... unfold extend in H1. rewrite <- Heqe in H1...
  Case "tm_abs".
    rename i into y. rename t into T11.
    (* If [t = tm_abs y T11 t0], then we know that
         [Gamma,x:U |- tm_abs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- subst x v t0 S].

       We can calculate that
         subst x v t = tm_abs y T11 (if beq_id x y
                                      then t0
                                      else subst x v t0)
       And we must show that [Gamma |- subst x v t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else subst x v t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- subst x v t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tm_abs x T11 t12]
         and
           [t2 = v2].
         We must show that [empty |- subst x v2 t12 : T2].
         We know by assumption that
             [empty |- tm_abs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  Case "T_Fst".
    inversion HT...
  Case "T_Snd".
    inversion HT...
Qed.
(** [] *)

(* ###################################################################### *)
(* *** Determinism *)
(** *** 決定性 *)

Lemma step_deterministic :
   partial_function step.
Proof with eauto.
   unfold partial_function.
   (* FILL IN HERE *)
   (** ここを埋めなさい *) Admitted.

(* ###################################################################### *)
(* * Normalization *)
(** * 正規化 *)

(* Now for the actual normalization proof.

    Our goal is to prove that every well-typed term evaluates to a
    normal form.  In fact, it turns out to be convenient to prove
    something slightly stronger, namely that every well-typed term
    evaluates to a _value_.  This follows from the weaker property
    anyway via the Progress lemma (why?) but otherwise we don't need
    Progress, and we didn't bother re-proving it above.

    Here's the key definition: *)
(** ここからが本当の正規化の証明です。

    ゴールはすべての型付けされた項が正規形になることを証明することです。
    実際のところ、もうちょっと強いことを証明した方が便利です。
    つまり、すべての型付けされた項が値になるということです。
    この強い方は、いずれにしろ弱い方から進行補題を使って得ることができますが(なぜでしょう？)、
    最初から強い方を証明すれば進行性は必要ありません。
    そして、進行性を再び証明することは上では行いませんでした。

    これがキーとなる定義です: *)

Definition halts  (t:tm) : Prop :=  exists t', t ==>* t' /\  value t'.

(* A trivial fact: *)
(** あたりまえの事実: *)

Lemma value_halts : forall v, value v -> halts v.
Proof.
  intros v H. unfold halts.
  exists v. split.
  apply rsc_refl.
  assumption.
Qed.

(* The key issue in the normalization proof (as in many proofs by
induction) is finding a strong enough induction hypothesis.  To this
end, we begin by defining, for each type [T], a set [R_T] of closed
terms of type [T].  We will specify these sets using a relation [R]
and write [R T t] when [t] is in [R_T]. (The sets [R_T] are sometimes
called _saturated sets_ or _reducibility candidates_.)

Here is the definition of [R] for the base language:

- [R bool t] iff [t] is a closed term of type [bool] and [t] halts in a value

- [R (T1 -> T2) t] iff [t] is a closed term of type [T1 -> T2] and [t] halts
  in a value _and_ for any term [s] such that [R T1 s], we have [R
  T2 (t s)]. *)
(** 正規化の証明のキーとなる問題は、
(多くの帰納法による証明と同様に)十分な強さの帰納法の仮定を見つけることです。
このために、それぞれの型[T]に対して型[T]の閉じた項の集合[R_T]を定義することから始めます。
これらの集合を関係[R]を使って定め、[t]が[R_T]の要素であることを [R T t] と書きます。
(集合[R_T]はしばしば飽和集合(_saturated sets_)あるいは簡約可能性候補
(_reducibility candidates_)と呼ばれます。)

基本言語に対する[R]の定義は以下の通りです:

- [R bool t] とは、[t]が型[bool]の閉じた項で[t]が値になることである

- [R (T1 -> T2) t] とは、[t]が型 [T1 -> T2] の閉じた項で、[t]が値になり、かつ、
  [R T1 s] となる任意の項[s]について、[R T2 (t s)] となることである。 *)

(* This definition gives us the strengthened induction hypothesis that we
need.  Our primary goal is to show that all _programs_ ---i.e., all
closed terms of base type---halt.  But closed terms of base type can
contain subterms of functional type, so we need to know something
about these as well.  Moreover, it is not enough to know that these
subterms halt, because the application of a normalized function to a
normalized argument involves a substitution, which may enable more
evaluation steps.  So we need a stronger condition for terms of
functional type: not only should they halt themselves, but, when
applied to halting arguments, they should yield halting results.

The form of [R] is characteristic of the _logical relations_ proof
technique.  (Since we are just dealing with unary relations here, we
could perhaps more properly say _logical predicates_.)  If we want to
prove some property [P] of all closed terms of type [A], we proceed by
proving, by induction on types, that all terms of type [A] _possess_
property [P], all terms of type [A->A] _preserve_ property [P], all
terms of type [(A->A)->(A->A)] _preserve the property of preserving_
property [P], and so on.  We do this by defining a family of
predicates, indexed by types.  For the base type [A], the predicate is
just [P].  For functional types, it says that the function should map
values satisfying the predicate at the input type to values satisfying
the predicate at the output type.

When we come to formalize the definition of [R] in Coq, we hit a
problem.  The most obvious formulation would be as a parameterized
Inductive proposition like this:

[[
Inductive R : ty -> tm -> Prop :=
| R_bool : forall b t, has_type empty t ty_Bool ->
                halts t ->
                R ty_Bool t
| R_arrow : forall T1 T2 t, has_type empty t (ty_arrow T1 T2) ->
                halts t ->
                (forall s, R T1 s -> R T2 (tm_app t s)) ->
                R (ty_arrow T1 T2) t.
]]

Unfortunately, Coq rejects this definition because it violates the
_strict positivity requirement_ for inductive definitions, which says
that the type being defined must not occur to the left of an arrow in
the type of a constructor argument. Here, it is the third argument to
[R_arrow], namely [(forall s, R T1 s -> R TS (tm_app t s))], and
specifically the [R T1 s] part, that violates this rule.  (The
outermost arrows separating the constructor arguments don't count when
applying this rule; otherwise we could never have genuinely inductive
predicates at all!)  The reason for the rule is that types defined
with non-positive recursion can be used to build non-terminating
functions, which as we know would be a disaster for Coq's logical
soundness. Even though the relation we want in this case might be
perfectly innocent, Coq still rejects it because it fails the
positivity test.

Fortunately, it turns out that we _can_ define [R] using a
[Fixpoint]: *)
(** この定義は必要な強化された帰納法の仮定を与えます。
最初のゴールはすべてのプログラム(つまり、基本型のすべての閉じた項)が停止することを示すことです。
しかし、基本型の閉じた項は関数型の部分項を含むこともできるので、
これらについても性質を知ることが必要です。
さらに、これらの部分項が停止することを知るだけでは不十分です。なぜなら、
正規化された関数を正規化された引数へ適用すると置換が行われるため、
さらに評価ステップが発生する可能性があるからです。
これから関数型の項についてより強い条件が必要です。つまり、
自分自身が停止するだけでなく、停止する引数に適用されると停止する結果にならなければならないという条件です。

[R]の形は論理的関係(_logical relations_)証明テクニックの特徴です。
(ここで扱うのは単項関係のみなので、おそらく論理的述語(_logical predicates_)
という方がより適切でしょう。)
型[A]のすべての閉じた項についてある性質[P]を証明したい場合、
型についての帰納法により、型[A]のすべての項が性質[P]を「持ち」、型[A->A]
のすべての項が性質[P]を「保存し」、型[(A->A)->(A->A)]のすべての項が性質[P]を
「保存することを保存し」、...ということを証明していきます。
このために型をインデックスとする述語の族を定義します。
基本型[A]に対しては、述語は単に[P]です。関数型に対しては、述語は、
その関数が入力の型の述語を満たす値を出力の型の述語を満たす値に写像することを言うものです。

Coqで[R]の定義を形式化しようとするとき、問題が生じます。
一番自明な形式化は、次のようなパラメータ化された Inductive による命題でしょう：

[[
Inductive R : ty -> tm -> Prop :=
| R_bool : forall b t, has_type empty t ty_Bool ->
                halts t ->
                R ty_Bool t
| R_arrow : forall T1 T2 t, has_type empty t (ty_arrow T1 T2) ->
                halts t ->
                (forall s, R T1 s -> R T2 (tm_app t s)) ->
                R (ty_arrow T1 T2) t.
]]

残念ながらCoqはこの定義を受け付けません。なぜなら帰納的定義の
_strict positivity requirement_を満たさないからです。
_strict positivity requirement_とは、
定義される型がコンストラクタ引数の型の矢印の左に現れてはいけないというものです。
ここで、この規則を破っているのは、[R_arrow]の第3引数、すなわち、
[(forall s, R T1 s -> R TS (tm_app t s))] の、特に [R T1 s] の部分です。
(一番外側のコンストラクタ引数を分離している矢印は規則の対象外です。
そうでなければ、純粋な帰納的述語はまったく定義できません!)
この規則がある理由は、正ではない再帰(non-positive recursion)
を使って定義された型は停止しない関数を作るのに使うことができ、
それがCoqの論理的健全性を脅かすからです。
ここで定義しようとしている関係が完全に問題ないものであるにもかかわらず、
_strict positivity requirement_のテストを通らないので、Coqはこれを拒否します。

幸い、[Fixpoint]を使うと[R]が定義できます: *)

Fixpoint R (T:ty) (t:tm) {struct T} : Prop :=
  has_type empty t T /\ halts t /\
  (match T with
   | ty_Bool  => True
   | ty_arrow T1 T2 => (forall s, R T1 s -> R T2 (tm_app t s))
(* FILL IN HERE *)
(** ここを埋めなさい *)
   | ty_prod T1 T2 => False (* ... and delete this line *)
   end).

(* As immediate consequences of this definition, we have that every
element of every set [R_T] halts in a value and is closed with type
[t] :*)
(** この定義からすぐに導かれることとして、
すべての集合[R_T]について、
そのすべての要素は停止して値となり、また型[T]について閉じていることが言えます: *)

Lemma R_halts : forall {T} {t}, R T t -> halts t.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1;  assumption.
Qed.

Lemma R_typable_empty : forall {T} {t}, R T t -> has_type empty t T.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1; assumption.
Qed.

(* Now we proceed to show the main result, which is that every
well-typed term of type [T] is an element of [R_T].  Together with
[R_halts], that will show that every well-typed term halts in a
value.  *)
(** さて、メインの結果に進みます。
すべての型[T]の項が[R_T]の要素であることを示すことです。
[R_halts]と組み合わせると、すべての型付けされる項は停止して値になることが示されます。 *)

(* ###################################################################### *)
(* **  Membership in [R_T] is invariant under evaluation *)
(** **  [R_T] の要素であるか否かは評価によって変化しない *)

(* We start with a preliminary lemma that shows a kind of strong
preservation property, namely that membership in [R_T] is _invariant_
under evaluation. We will need this property in both directions,
i.e. both to show that a term in [R_T] stays in [R_T] when it takes a
forward step, and to show that any term that ends up in [R_T] after a
step must have been in [R_T] to begin with.

First of all, an easy preliminary lemma. Note that in the forward
direction the proof depends on the fact that our language is
determinstic. This lemma might still be true for non-deterministic
languages, but the proof would be harder! *)
(** 一種の強保存性を示す予備的補題から始めます。[R_T]の要素であるか否かは
評価によって「不変」(_invariant_)であるという補題です。
この性質は両方向が必要です。つまり、[R_T]の項がステップを進めても[R_T]にあることを示すことと、
ステップ後[R_T]の要素になる任意の項が最初から[R_T]であることを示すことです。

一番最初に、簡単な予備的補題です。
前向き方法については、言語が決定性を持つという事実に証明が依存していることに注意します。
この補題は非決定的な言語でも成立するかもしれませんが、証明はより難しくなるでしょう! *)

Lemma step_preserves_halting : forall t t', (t ==> t') -> (halts t <-> halts t').
Proof.
 intros t t' ST.  unfold halts.
 split.
 Case "->".
  intros [t'' [STM V]].
  inversion STM; subst.
   apply ex_falso_quodlibet.  apply value__normal in V. unfold normal_form in V. apply V. exists t'. auto.
   rewrite (step_deterministic _ _ _ ST H). exists t''. split; assumption.
 Case "<-".
  intros [t'0 [STM V]].
  exists t'0. split; eauto.
Qed.

(* Now the main lemma, which comes in two parts, one for each
   direction.  Each proceeds by induction on the structure of the type
   [T].  In fact, this is where we make fundamental use of the
   finiteness of types.

   One requirement for staying in [R_T] is to stay in type [T]. In the
   forward direction, we get this from ordinary type Preservation. *)
(** さてメインの補題ですが、2つの方向に対応する2つの部分から成ります。
   それぞれは型[T]の構造についての帰納法で進みます。
   事実、ここでは型の有限性を本質的な部分で使っています。

   ステップを進んだ結果が[R_T]の要素であるためには型[T]を持つことが必要です。
   このことは、前向き方向については、もともとの型保存から得られます。 *)

Lemma step_preserves_R : forall T t t', (t ==> t') -> R T t -> R T t'.
Proof.
 induction T;  intros t t' E Rt; unfold R; fold R; unfold R in Rt; fold R in Rt;
               destruct Rt as [typable_empty_t [halts_t RRt]].
  (* ty_Bool *)
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  auto.
  (* ty_arrow *)
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  intros.
  eapply IHT2.
  apply  ST_App1. apply E.
  apply RRt; auto.
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

(* The generalization to multiple steps is trivial: *)
(** 複数ステップへの一般化については自明です: *)

Lemma stepmany_preserves_R : forall T t t',
  (t ==>* t') -> R T t -> R T t'.
Proof.
  intros T t t' STM; induction STM; intros.
  assumption.
  apply IHSTM. eapply step_preserves_R. apply H. assumption.
Qed.

(* In the reverse direction, we must add the fact that [t] has type
   [T] before stepping as an additional hypothesis. *)
(** 逆向き方向については、
   [t]がステップ前に型[T]を持つという事実を追加の仮定として加える必要があります。 *)

Lemma step_preserves_R' : forall T t t',
  has_type empty t T -> (t ==> t') -> R T t' -> R T t.
Proof.
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

Lemma stepmany_preserves_R' : forall T t t',
  has_type empty t T -> (t ==>* t') -> R T t' -> R T t.
Proof.
  intros T t t' HT STM.
  induction STM; intros.
    assumption.
    eapply step_preserves_R'.  assumption. apply H. apply IHSTM.
    eapply preservation;  eauto. auto.
Qed.

(* ###################################################################### *)
(* ** Closed instances of terms of type [T] belong to [R_T] *)
(** ** [R_T]に含まれる型[T]の項の閉じたインスタンス *)

(* Now we proceed to show that every term of type [T] belongs to
[R_T].  Here, the induction will be on typing derivations (it would be
surprising to see a proof about well-typed terms that did not
somewhere involve induction on typing derivations!).  The only
technical difficulty here is in dealing with the abstraction case.
Since we are arguing by induction, the demonstration that a term
[tm_abs x T1 t2] belongs to [R_(T1->T2)] should involve applying the
induction hypothesis to show that [t2] belongs to [R_(T2)].  But
[R_(T2)] is defined to be a set of _closed_ terms, while [t2] may
contain [x] free, so this does not make sense.

This problem is resolved by using a standard trick to suitably
generalize the induction hypothesis: instead of proving a statement
involving a closed term, we generalize it to cover all closed
_instances_ of an open term [t].  Informally, the statement of the
lemma will look like this:

If [x1:T1,..xn:Tn |- t : T] and [v1,...,vn] are values such that
[R T1 v1], [R T2 v2], ..., [R Tn vn], then [R T ([v1/x1][v2/x2]...[vn/xn]t)].

The proof will proceed by induction on the typing derivation
[x1:T1,..xn:Tn |- t : T]; the most interesting case will be the one
for abstraction. *)
(** これから、型[T]のすべての項が[R_T]に含まれることを示すことに取りかかります。
ここで使う帰納法は型付け導出についてのものです
(もし、型付け導出の帰納法と全く関係がない型付けされた項についての証明があったら、
驚くでしょう!)。
ここで技術的に難しいのは、関数抽象の場合だけです。
帰納法で議論していることから、項 [tm_abs x T1 t2] が[R_(T1->T2)]に属していることを示すことには
[t2]が[R_(T2)]に属するという帰納法の仮定を含みます。
しかし[R_(T2)]は「閉じた」項の集合である一方、[t2]は[x]を自由変数として含む可能性があるので、
これは筋が通りません。

この問題は帰納法の仮定を適度に一般化するという標準的なトリックを使うことで解決されます。
閉じた項を含む主張を証明する代わりに、開いた項[t]のすべての閉じたインスタンス(_instances_)
をカバーするように一般化します。非形式的には、補題の主張は次のようになります:

もし [x1:T1,..xn:Tn |- t : T] かつ、 [v1,...,vn] が
[R T1 v1], [R T2 v2], ..., [R Tn vn] となる値ならば、
[R T ([v1/x1][v2/x2]...[vn/xn]t)] である。

証明は、型付け [x1:T1,..xn:Tn |- t : T] の導出についての帰納法で進みます。
一番興味深いのは、関数抽象の場合です。 *)

(* ###################################################################### *)
(* *** Multisubstitutions, multi-extensions, and instantiations *)
(** *** 多重置換、多重拡張、インスタンス化 *)

(* However, before we can proceed to formalize the statement and
proof of the lemma, we'll need to build some (rather tedious)
machinery to deal with the fact that we are performing _multiple_
substitutions on term [t] and _multiple_ extensions of the typing
context.  In particular, we must be precise about the order in which
the substitutions occur and how they act on each other.  Often these
details are simply elided in informal paper proofs, but of course Coq
won't let us do that. Since here we are substituting closed terms, we
don't need to worry about how one substitution might affect the term
put in place by another.  But we still do need to worry about the
_order_ of substitutions, because it is quite possible for the same
identifier to appear multiple times among the [x1,...xn] with
different associated [vi] and [Ti].

To make everything precise, we will assume that environments are
extended from left to right, and multiple substitutions are performed
from right to left.  To see that this is consistent, suppose we have
an environment written as [...,y:bool,...,y:nat,...]  and a
corresponding term substitution written as [...[(tm_bool
true)/y]...[(tm_nat 3)/y]...t].  Since environments are extended from
left to right, the binding [y:nat] hides the binding [y:bool]; since
substitutions are performed right to left, we do the substitution
[(tm_nat 3)/y] first, so that the substitution [(tm_bool true)/y] has
no effect. Substitution thus correctly preserves the type of the term.

With these points in mind, the following definitions should make sense.

A _multisubstitution_ is the result of applying a list of
substitutions, which we call an _environment_. *)
(** しかしながら、主張と補題の証明の形式化に進む前に、項[t]の多重置換(_multiple_
substitutions)と型付けコンテキストの多重拡張(_multiple_ extensions)
についての事実を扱う、ある(かなり退屈な)機構を構築する必要があります。
特に、置換が現れる順序とそれらの相互関係を正確にする必要があります。
これらの詳細は非形式的な紙の証明では単に省略されるのが通常です。
しかしもちろん、Coqはそうはしません。ここでは閉じた項を置換していることから、
1つの置換が他の置換によってできた項に影響するかどうかを心配する必要はありません。
しかしそれでも置換の順序については考慮する必要があります。
なぜなら、[x1,...xn]に同じ識別子が複数回出現しそれらが違う[vi]や[Ti]
と関連付けされている可能性があるからです。

すべてを正確にするために、環境は左から右へ拡張されることとし、
多重置換は右から左へ実行されることとします。
これが整合的であることを見るために、[...,y:bool,...,y:nat,...] と書かれる環境と、
対応する [...[(tm_bool true)/y]...[(tm_nat 3)/y]...t]
と書かれる項の置換があるとします。
環境は左から右に拡張されることから、[y:nat]は[y:bool]を隠します。
置換は右から左に実行されることから、[(tm_nat 3)/y] が最初に実行され、
[(tm_bool true)/y] は何の作用もしません。
これから置換は項の型を正しく保存します。

このポイントを覚えておくと、次の定義が理解できます。

多重置換(_multisubstitution_)は置換のリストの適用結果です。
置換のリストは環境と呼ばれます(_environment_)。 *)

Definition env := list (id * tm).

Fixpoint msubst (ss:env) (t:tm) {struct ss} : tm :=
match ss with
| nil => t
| ((x,s)::ss') => msubst ss' (subst x s t)
end.

(* We need similar machinery to talk about repeated extension of a
    typing context using a list of (identifier, type) pairs, which we
    call a _type assignment_. *)
(** (識別子、型)の対のリストを使った型付けコンテキストの継続的拡張についても同様の機構が必要です。
    この型付けコンテキストを「型割当て」(_type assignment_)と呼びます。 *)

Definition tass := list (id * ty).

Fixpoint mextend (Gamma : context) (xts : tass) :=
  match xts with
  | nil => Gamma
  | ((x,v)::xts') => extend (mextend Gamma xts') x v
  end.

(* We will need some simple operations that work uniformly on
environments and type assigments *)
(** 環境と型割当てに同様にはたらくいくつかの簡単な操作が必要です。 *)

Fixpoint lookup {X:Set} (k : id) (l : list (id * X)) {struct l} : option X :=
  match l with
    | nil => None
    | (j,x) :: l' =>
      if beq_id j k then Some x else lookup k l'
  end.

Fixpoint drop {X:Set} (n:id) (nxs:list (id * X)) {struct nxs} : list (id * X) :=
  match nxs with
    | nil => nil
    | ((n',x)::nxs') => if beq_id n' n then drop n nxs' else (n',x)::(drop n nxs')
  end.

(* An _instantiation_ combines a type assignment and a value
   environment with the same domains, where corresponding elements are
   in R *)
(** インスタンス化(_instantiation_)は型割当てと値環境を同じ定義域で結合します。
   この定義域の要素はRに含まれます。 *)

Inductive instantiation :  tass -> env -> Prop :=
| V_nil : instantiation nil nil
| V_cons : forall x T v c e, value v -> R T v -> instantiation c e -> instantiation ((x,T)::c) ((x,v)::e).

(* We now proceed to prove various properties of these definitions. *)
(** これから、これらの定義についてのいろいろな性質を証明します。 *)

(* ###################################################################### *)
(* *** More Substitution Facts *)
(** *** 置換についてのさらなる事実 *)

(* First we need some additional lemmas on (ordinary) substitution. *)
(** 最初に(もともとの)置換について、ある追加の補題が必要です。 *)

Lemma vacuous_substitution : forall  t x,
     ~ appears_free_in x t  ->
     forall t', subst x t' t = t.
Proof with eauto.
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

Lemma subst_closed: forall t,
     closed t  ->
     forall x t', subst x t' t = t.
Proof.
  intros. apply vacuous_substitution. apply H.  Qed.

Lemma subst_not_afi : forall t x v, closed v ->  ~ appears_free_in x (subst x v t).
Proof with eauto.  (* rather slow this way *)
  unfold closed, not.
  tm_cases (induction t) Case; intros x v P A; simpl in A.
    Case "tm_var".
     remember (beq_id x i) as e; destruct e...
       inversion A; subst. rewrite <- beq_id_refl in Heqe; inversion Heqe.
    Case "tm_app".
     inversion A; subst...
    Case "tm_abs".
     remember (beq_id x i) as e; destruct e...
       apply beq_id_eq in Heqe; subst. inversion A; subst...
       inversion A; subst...
    Case "tm_pair".
     inversion A; subst...
    Case "tm_fst".
     inversion A; subst...
    Case "tm_snd".
     inversion A; subst...
    Case "tm_true".
     inversion A.
    Case "tm_false".
     inversion A.
    Case "tm_if".
     inversion A; subst...
Qed.

Lemma duplicate_subst : forall t' x t v,
  closed v -> subst x t (subst x v t') = subst x v t'.
Proof.
  intros. eapply vacuous_substitution. apply subst_not_afi.  auto.
Qed.

Lemma swap_subst : forall t x x1 v v1, x <> x1 -> closed v -> closed v1 ->
                   subst x1 v1 (subst x v t) = subst x v (subst x1 v1 t).
Proof with eauto.
 tm_cases (induction t) Case; intros; simpl.
  Case "tm_var".
   remember (beq_id x i) as e; destruct e; remember (beq_id x1 i) as e; destruct e.
      apply  beq_id_eq in Heqe. apply beq_id_eq in Heqe0. subst.
         apply ex_falso_quodlibet...
      apply beq_id_eq in Heqe; subst.  simpl.
         rewrite <- beq_id_refl.  apply subst_closed...
      apply beq_id_eq in Heqe0; subst.  simpl.
         rewrite <- beq_id_refl. rewrite subst_closed...
      simpl. rewrite <- Heqe. rewrite <- Heqe0...
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

(* ###################################################################### *)
(* *** Properties of multi-substitutions *)
(** *** 多重置換の性質 *)

Lemma msubst_closed: forall t, closed t -> forall ss, msubst ss t = t.
Proof.
  induction ss.
    reflexivity.
    destruct a. simpl. rewrite subst_closed; assumption.
Qed.

(* Closed environments are those that contain only closed terms. *)
(** 閉じた環境とは、閉じた項のみを含む環境です。 *)

Fixpoint closed_env (env:env) {struct env} :=
match env with
| nil => True
| (x,t)::env' => closed t /\ closed_env env'
end.

(* Next come a series of lemmas charcterizing how [msubst] of closed terms
    distributes over [subst] and over each term form *)
(** 次は、閉じた項についての[msubst]がどのように[subst]
    や各項の形に分配されるかを特徴づける一連の補題です。 *)

Lemma subst_msubst: forall env x v t, closed v -> closed_env env ->
  msubst env (subst x v t) = subst x v (msubst (drop x env) t).
Proof.
  induction env0; intros.
    auto.
    destruct a. simpl.
    inversion H0. fold closed_env in H2.
    remember (beq_id i x) as e; destruct e.
      apply  beq_id_eq in Heqe; subst.
        rewrite duplicate_subst; auto.
      symmetry in Heqe. apply beq_id_false_not_eq in Heqe.
      simpl. rewrite swap_subst; eauto.
Qed.

Lemma msubst_var:  forall ss x, closed_env ss ->
   msubst ss (tm_var x) =
   match lookup x ss with
   | Some t => t
   | None => tm_var x
  end.
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
     simpl. destruct (beq_id i x).
      apply msubst_closed. inversion H; auto.
      apply IHss. inversion H; auto.
Qed.

Lemma msubst_abs: forall ss x T t,
  msubst ss (tm_abs x T t) = tm_abs x T (msubst (drop x ss) t).
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
      simpl. destruct (beq_id i x); simpl; auto.
Qed.

Lemma msubst_app : forall ss t1 t2, msubst ss (tm_app t1 t2) = tm_app (msubst ss t1) (msubst ss t2).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

(* You'll need similar functions for the other term constructors. *)
(** 他の項コンストラクタに対しても同様の関数が必要になるでしょう。 *)

(* FILL IN HERE *)
(** ここを埋めなさい *)

(* ###################################################################### *)
(* *** Properties of multi-extensions *)
(** *** 多重拡張の性質 *)

(* We need to connect the behavior of type assignments with that of their
   corresponding contexts. *)
(** 型割当てのふるまいを、対応するコンテキストのふるまいと結合する必要があります。 *)

Lemma mextend_lookup : forall (c : tass) (x:id), lookup x c = (mextend empty c) x.
Proof.
  induction c; intros.
    auto.
    destruct a. unfold lookup, mextend, extend. destruct (beq_id i x); auto.
Qed.

Lemma mextend_drop : forall (c: tass) Gamma x x',
       mextend Gamma (drop x c) x' = if beq_id x x' then Gamma x' else mextend Gamma c x'.
   induction c; intros.
      destruct (beq_id x x'); auto.
      destruct a. simpl.
      remember (beq_id i x) as e; destruct e.
        apply beq_id_eq in Heqe; subst. rewrite IHc.
            remember (beq_id x x') as e; destruct e.  auto. unfold extend. rewrite <- Heqe. auto.
        simpl.  unfold extend.  remember (beq_id i x') as e; destruct e.
            apply beq_id_eq in Heqe0; subst.
                              remember (beq_id x x') as e; destruct e.
                  apply beq_id_eq in Heqe0; subst.  rewrite <- beq_id_refl in Heqe.  inversion Heqe.
                  auto.
            auto.
Qed.

(* ###################################################################### *)
(* *** Properties of Instantiations *)
(** *** インスタンス化の性質 *)

(* These are strightforward. *)
(** 以下は簡単です。 *)

Lemma instantiation_domains_match: forall {c} {e},
  instantiation c e -> forall {x} {T}, lookup x c = Some T -> exists t, lookup x e = Some t.
Proof.
  intros c e V. induction V; intros x0 T0 C.
    solve by inversion .
    simpl in *.
    destruct (beq_id x x0); eauto.
Qed.

Lemma instantiation_env_closed : forall c e,  instantiation c e -> closed_env e.
Proof.
  intros c e V; induction V; intros.
    econstructor.
    unfold closed_env. fold closed_env.
    split.  eapply typable_empty__closed. eapply R_typable_empty. eauto.
        auto.
Qed.

Lemma instantiation_R : forall c e, instantiation c e ->
                        forall x t T, lookup x c = Some T ->
                                      lookup x e = Some t -> R T t.
Proof.
  intros c e V. induction V; intros x' t' T' G E.
    solve by inversion.
    unfold lookup in *.  destruct (beq_id x x').
      inversion G; inversion E; subst.  auto.
      eauto.
Qed.

Lemma instantiation_drop : forall c env,
  instantiation c env -> forall x, instantiation (drop x c) (drop x env).
Proof.
  intros c e V. induction V.
    intros.  simpl.  constructor.
    intros. unfold drop. destruct (beq_id x x0); auto. constructor; eauto.
Qed.

(* ###################################################################### *)
(* *** Congruence lemmas on stepmany *)
(** *** stepmany([==>*])についての合同補題 *)

(* We'll need just a few of these; add them as the demand arises. *)
(** これらのいくつかだけが必要になります。必要が生じた時点で追加しなさい。 *)

Lemma stepmany_App2 : forall v t t',
  value v -> (t ==>* t') -> (tm_app v t) ==>* (tm_app v t').
Proof.
  intros v t t' V STM. induction STM.
   apply rsc_refl.
   eapply rsc_step.
     apply ST_App2; eauto.  auto.
Qed.

(* FILL IN HERE *)
(** ここを埋めなさい *)

(* ###################################################################### *)
(* *** The R Lemma. *)
(** *** R補題 *)

(* We finally put everything together.

    The key lemma about preservation of typing under substitution can
    be lifted to multi-substitutions: *)
(** 最後にすべてをまとめます。

    置換についての型付けの保存についてのキーとなる補題は、
    多重置換に対応する形にすることができます: *)

Lemma msubst_preserves_typing : forall c e,
     instantiation c e ->
     forall Gamma t S, has_type (mextend Gamma c) t S ->
     has_type Gamma (msubst e t) S.
Proof.
  induction 1; intros.
    simpl in H. simpl. auto.
    simpl in H2.  simpl.
    apply IHinstantiation.
    eapply substitution_preserves_typing; eauto.
    apply (R_typable_empty H0).
Qed.

(* And at long last, the main lemma. *)
(** そして一番最後に、メインの補題です。 *)

Lemma msubst_R : forall c env t T,
  has_type (mextend empty c) t T -> instantiation c env -> R T (msubst env t).
Proof.
  intros c env0 t T HT V.
  generalize dependent env0.
  (* We need to generalize the hypothesis a bit before setting up the induction. *)
  remember (mextend empty c) as Gamma.
  assert (forall x, Gamma x = lookup x c).
    intros. rewrite HeqGamma. rewrite mextend_lookup. auto.
  clear HeqGamma.
  generalize dependent c.
  has_type_cases (induction HT) Case; intros.

  Case "T_Var".
   rewrite H0 in H. destruct (instantiation_domains_match V H) as [t P].
   eapply instantiation_R; eauto.
   rewrite msubst_var.  rewrite P. auto. eapply instantiation_env_closed; eauto.

  Case "T_Abs".
    rewrite msubst_abs.
    (* We'll need variants of the following fact several times, so its simplest to
       establish it just once. *)
    assert (WT: has_type empty (tm_abs x T11 (msubst (drop x env0) t12)) (ty_arrow T11 T12)).
     eapply T_Abs. eapply msubst_preserves_typing.  eapply instantiation_drop; eauto.
      eapply context_invariance.  apply HT.
      intros.
      unfold extend. rewrite mextend_drop. remember (beq_id x x0) as e; destruct e.  auto.
        rewrite H.
          clear - c Heqe. induction c.
              simpl.  rewrite <- Heqe.  auto.
              simpl. destruct a.  unfold extend. destruct (beq_id i x0); auto.
    unfold R. fold R. split.
       auto.
     split. apply value_halts. apply v_abs.
     intros.
     destruct (R_halts H0) as [v [P Q]].
     pose proof (stepmany_preserves_R _ _ _ P H0).
     apply stepmany_preserves_R' with (msubst ((x,v)::env0) t12).
       eapply T_App. eauto.
       apply R_typable_empty; auto.
       eapply rsc_trans.  eapply stepmany_App2; eauto.
       eapply rsc_R.
       simpl.  rewrite subst_msubst.
       eapply ST_AppAbs; eauto.
       eapply typable_empty__closed.
       apply (R_typable_empty H1).
       eapply instantiation_env_closed; eauto.
       eapply (IHHT ((x,T11)::c)).
          intros. unfold extend, lookup. destruct (beq_id x x0); auto.
       constructor; auto.

  Case "T_App".
    rewrite msubst_app.
    destruct (IHHT1 c H env0 V) as [_ [_ P1]].
    pose proof (IHHT2 c H env0 V) as P2.  fold R in P1.  auto.

  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

(* ###################################################################### *)
(* *** Normalization Theorem *)
(** *** 正規化定理 *)

Theorem normalization : forall t T, has_type empty t T -> halts t.
Proof.
  intros.
  replace t with (msubst nil t).
  eapply R_halts.
  eapply msubst_R; eauto. instantiate (2:= nil). eauto.
  eapply V_nil.
  auto.
Qed.


Require Export Maximal_Principle.

(** Zorn Lemma **)

Module Type Zorn_Lemma.

Declare Module Max : Maximal_Principle.

Definition En_Fs X le x := \{ λ u, u∈X /\ Rrelation u le x \}.

Definition En_FF X A le := \{ λ u, exists a, u = (En_Fs X le a) /\ a∈A \}.
Axiom Property_FF : forall X A le a,
  (En_Fs X le a) ∈ (En_FF X A le) ->
  (forall b, En_Fs X le a = En_Fs X le b -> a = b).

Definition En_A X A le := \{ λ u, (En_Fs X le u) ∈ A \}.

Lemma Property_Fs : forall X le u v,
  PartialOrder le X -> u∈X ->
  (En_Fs X le u ⊂ En_Fs X le v <-> Rrelation u le v).
Proof.
  intros; unfold PartialOrder in H.
  destruct H, H1, H2, H3; split; intros.
  - assert (u ∈ (En_Fs X le u)).
    { unfold En_Fs; apply Axiom_Scheme; repeat split; Ens. }
    unfold Subclass in H5; apply H5 in H6; unfold En_Fs in H6.
    apply Axiom_Scheme in H6; try apply H6.
  - unfold Subclass; intros; unfold En_Fs in H6; unfold En_Fs.
    apply Axiom_Scheme in H6; apply Axiom_Scheme; destruct H6, H7.
    repeat split; auto; unfold Transitivity in H4; apply H4 with (v:=u).
    repeat split; auto; destruct H1; unfold Subclass in H9.
    unfold Rrelation in H5; apply H9 in H5; unfold Cartesian in H5.
    apply Axiom_SchemeP in H5; apply H5.
Qed.

Lemma LemmaZ1 : forall A X le,
  PartialOrderSet X le ->
  (Chain A X le <-> (En_FF X A le)⊂(En_FF X X le) /\ Nest(En_FF X A le) /\ A≠Φ).
Proof.
  intros; split; intros.
  - double H; unfold PartialOrderSet in H1; unfold Chain in H0.
    apply H0 in H1; clear H0; destruct H1, H0; split.
    + unfold Subclass; intros; apply Axiom_Scheme in H3; apply Axiom_Scheme.
      destruct H3, H4, H4; split; auto; exists x; split; auto.
    + split; auto; unfold Nest; intros; destruct H3; apply Axiom_Scheme in H3.
      apply Axiom_Scheme in H4; destruct H3, H4, H5, H5, H6, H6.
      generalize (classic (x=x0)); intros; destruct H9.
      * rewrite H9 in H5; rewrite H5, H6.
        right; unfold Subclass; intros; auto.
      * unfold TotalOrder in H1; destruct H1; clear H1; double H7.
        add (x0∈A) H7; apply H10 in H7; auto; clear H10; clear H9.
        unfold PartialOrderSet in H; unfold PartialOrder in H.
        destruct H, H9, H10 as [H11 H10], H10 as [H12 H10]; clear H11 H12.
        unfold Transitivity in H10; rewrite H5, H6; destruct H7.
        -- left; unfold Subclass; intros; apply Axiom_Scheme in H11.
           destruct H11, H12; apply Axiom_Scheme; repeat split; auto.
           assert (Rrelation x le x0).
           { unfold Rrelation in H7; unfold Rrelation.
             apply Theorem4' in H7; apply H7. }
           unfold Subclass in H0; apply H0 in H1; apply H0 in H8.
           apply H10 with (v:= x); auto.
        -- right; unfold Subclass; intros; apply Axiom_Scheme in H11.
           destruct H11, H12; apply Axiom_Scheme; repeat split; auto.
           assert (Rrelation x0 le x).
           { unfold Rrelation in H7; unfold Rrelation.
             apply Theorem4' in H7; apply H7. }
           unfold Subclass in H0; apply H0 in H1; apply H0 in H8.
           apply H10 with (v:= x0); auto.
  - destruct H0, H1; unfold Chain; intros; clear H3.
    assert (forall z, z∈A -> (En_Fs X le z) ∈ (En_FF X A le)).
    { intros; unfold En_FF; apply Axiom_Scheme; split.
      - assert (En_Fs X le z ⊂ X).
        { unfold Subclass; intros; apply Axiom_Scheme in H4; apply H4. }
        unfold PartialOrderSet in H; destruct H; clear H5.
        apply Theorem33 in H4; auto.
      - exists z; split; auto. }
    assert (A ⊂ X); try split; auto.
    { unfold Subclass; intros; unfold Subclass in H0.
      apply H3 in H4; apply H0 in H4; double H4; unfold En_FF in H5.
      apply Axiom_Scheme in H5; destruct H5, H6, H6.
      apply Property_FF with (A:=X) in H6; auto; rewrite H6; auto. }
    unfold PartialOrderSet in H; unfold PartialOrder in H; destruct H.
    destruct H5, H6, H7; unfold TotalOrder.
    split; try (apply Theorem33 with (x:=X); auto).
    unfold PartialOrder; repeat split; auto.
    + apply Theorem33 in H4; auto.
    + destruct H5; unfold Relation in H5; unfold Relation; intros.
      apply Theorem4' in H10; destruct H10; apply H5 in H10; auto.
    + unfold Subclass; intros; apply Theorem4' in H9; apply H9.
    + unfold Reflexivity; intros; unfold Rrelation; apply Theorem4'.
      unfold Reflexivity in H6; double H9; unfold Subclass in H4.
      apply H4 in H10; apply H6 in H10; unfold Rrelation in H10.
      split; auto; unfold Cartesian; apply Axiom_SchemeP; Ens.
    + unfold Antisymmetry in H7; unfold Antisymmetry; intros.
      destruct H9, H10; apply H7; auto; unfold Rrelation in H10, H12.
      apply Theorem4' in H10; apply Theorem4' in H12; destruct H10, H12.
      unfold Rrelation; split; auto.
    + unfold Transitivity in H8; unfold Transitivity; intros.
      destruct H9, H10, H9, H12; assert ((u∈X /\ v∈X /\ w∈X) /\
      Rrelation u le v /\ Rrelation v le w).
      { unfold Subclass in H4; apply H4 in H9; apply H4 in H12.
        apply H4 in H13; repeat split; auto; unfold Rrelation.
        - unfold Rrelation in H10; apply Theorem4' in H10; apply H10.
        - unfold Rrelation in H11; apply Theorem4' in H11; apply H11. }
      apply H8 in H14; unfold Rrelation in H14; clear H8.
      unfold Rrelation; apply Theorem4'; split; auto.
      unfold Cartesian; apply Axiom_SchemeP; Ens.
    + intros; destruct H9; unfold Nest in H1.
      assert ((En_Fs X le x) ∈ (En_FF X A le) /\ (En_Fs X le y) ∈
      (En_FF X A le)). { apply H3 in H9; apply H3 in H11; split; auto. }
      apply H1 in H12; clear H1; clear H2; destruct H12.
      * { left; unfold Rrelation; apply Theorem4'; split.
          - apply Property_ProperSubclass in H1; destruct H1.
            + unfold ProperSubclass in H1; destruct H1; clear H2.
              apply Property_Fs in H1; unfold Rrelation in H1; auto.
              unfold PartialOrder; auto.
            + assert ((En_Fs X le x) ∈ (En_FF X A le)).
              { unfold En_FF; apply Axiom_Scheme; double H9.
                apply H3 in H11; split; Ens. }
              apply Property_FF with (A:=A) in H1; auto; contradiction.
          - unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
            apply Theorem49; split; Ens. }
      * { right; unfold Rrelation; apply Theorem4'; split.
          - apply Property_ProperSubclass in H1; destruct H1.
            + unfold ProperSubclass in H1; destruct H1; clear H2.
              apply Property_Fs in H1; unfold Rrelation in H1; auto.
              unfold PartialOrder; auto.
            + assert ((En_Fs X le y) ∈ (En_FF X A le)).
              { unfold En_FF; apply Axiom_Scheme; double H9.
                apply H3 in H11; split; Ens. }
              apply Property_FF with (A:=A) in H1; auto.
              symmetry in H1; contradiction.
          - unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
            apply Theorem49; split; Ens. }
Qed.

Lemma LemmaZ2 : forall A X le y,
  PartialOrderSet X le /\ X ≠ Φ ->
  (BoundU y A X le -> (forall x, x ∈ (En_FF X A le) -> x ⊂ (En_Fs X le y))).
Proof.
  intros; double H.
  unfold BoundU in H0; apply H0 in H2; clear H0; destruct H2, H2.
  unfold En_FF in H1; apply Axiom_Scheme in H1; destruct H1.
  destruct H4 as [a H4], H4; rewrite H4; unfold Subclass; intros.
  unfold En_Fs in H6; unfold En_Fs.
  apply Axiom_Scheme in H6; apply Axiom_Scheme.
  double H5; apply H3 in H5; destruct H6, H8, H; clear H10.
  repeat split; auto; unfold PartialOrderSet, PartialOrder in H.
  destruct H, H10, H11, H12; unfold Transitivity in H13.
  apply H13 with (v:=a); repeat split; auto.
Qed.

Lemma LemmaZ3 : forall X le y,
  PartialOrderSet X le /\ X ≠ Φ ->
  (MaxElement y X le <-> MaxMember (En_Fs X le y) (En_FF X X le)).
Proof.
  intros; destruct H; split; intros.
  - unfold MaxElement in H1; apply H1 in H0; clear H1; destruct H0.
    unfold PartialOrderSet, PartialOrder in H; destruct H.
    unfold MaxMember; intros; clear H3; repeat split; intros.
    + unfold En_FF; apply Axiom_Scheme; split.
      * assert ((En_Fs X le y) ⊂ X).
        { unfold Subclass; intros; apply Axiom_Scheme in H3; apply H3. }
        apply Theorem33 in H3; auto.
      * exists y; split; auto.
    + apply Axiom_Scheme in H3; destruct H3, H4, H4; rewrite H4; intro.
      apply H1 in H5; apply not_and_or in H5; destruct H5.
      * unfold ProperSubclass in H6; destruct H6; clear H7.
        apply Property_Fs in H6; unfold Rrelation in H6; try apply H2; auto.
        unfold PartialOrder; auto.
      * apply NNPP in H5; rewrite H5 in H6; unfold ProperSubclass in H6.
        destruct H6; contradiction.
  - unfold PartialOrderSet, PartialOrder in H; destruct H.
    unfold MaxElement; intros; clear H3.
    unfold MaxMember in H1; assert (En_FF X X le ≠ Φ).
    { apply Property_NotEmpty in H0; destruct H0.
      apply Property_NotEmpty; exists (En_Fs X le x).
      unfold En_FF; apply Axiom_Scheme; split.
      - apply Theorem33 with (x:= X); auto; unfold Subclass; intros.
        unfold En_Fs in H3; apply Axiom_Scheme in H3; apply H3.
      - exists x; split; auto. }
    apply H1 in H3; clear H1; clear H0; destruct H3; double H0.
    unfold En_FF in H3; apply Axiom_Scheme in H3; destruct H3, H4, H4.
    apply Property_FF with (A:= X) in H4; auto; rewrite <- H4 in H5.
    split; intros; auto; assert (En_Fs X le y0 ∈ (En_FF X X le)).
    { unfold En_FF; apply Axiom_Scheme; split.
      - assert (En_Fs X le y0 ⊂ X).
        { unfold Subclass; intros; apply Axiom_Scheme in H7; apply H7. }
        apply Theorem33 in H7; auto.
      - exists y0; split; auto. }
    apply H1 in H7; intro; elim H7; destruct H8.
    unfold ProperSubclass; split.
    + apply Property_Fs; auto; unfold PartialOrder; auto.
    + intro; apply Property_FF with (A:=X) in H10; auto.
Qed.

Theorem Zorn : forall X le,
  PartialOrderSet X le -> (forall A, Chain A X le -> exists y, BoundU y A X le)
  -> exists v, MaxElement v X le.
Proof.
  intros.
  generalize (classic (X = Φ)); intros; destruct H1.
  - exists Φ; rewrite H1; unfold MaxElement; contradiction.
  - assert (Ensemble (En_FF X X le)).
    { unfold PartialOrderSet, PartialOrder in H; destruct H.
      clear H2; assert ((En_FF X X le) ⊂ pow(X)).
      { unfold Subclass; intros; unfold En_FF in H2.
        apply Axiom_Scheme in H2; destruct H2, H3, H3.
        unfold PowerClass; apply Axiom_Scheme; split; auto.
        rewrite H3; unfold Subclass; intros.
        unfold En_Fs in H5; apply Axiom_Scheme in H5; apply H5. }
      apply Theorem38 in H; auto; apply Theorem33 in H2; auto. }
    apply Max.MaxPrinciple in H2.
    + destruct H2 as [M H2]; double H2; unfold MaxMember in H3.
      assert (En_FF X X le ≠ Φ).
      { apply Property_NotEmpty in H1; destruct H1.
        apply Property_NotEmpty; exists (En_Fs X le x).
        unfold En_FF; apply Axiom_Scheme; split.
        - destruct H; apply Theorem33 with (x:= X); auto.
          unfold Subclass; intros; apply Axiom_Scheme in H5; apply H5.
        - exists x; split; auto. }
      apply H3 in H4; clear H3; destruct H4.
      unfold En_FF in H3; apply Axiom_Scheme in H3; destruct H3.
      destruct H5 as [v H5], H5; rewrite H5 in H2; add (X ≠ Φ) H.
      exists v; apply LemmaZ3 with (y:=v) in H; auto; apply H; auto.
    + intro B; intros; destruct H3.
      generalize (classic (B = Φ)); intros; destruct H5.
      { rewrite H5; apply Property_NotEmpty in H1.
        destruct H1 as [z H1]; exists (En_Fs X le z); split.
        - unfold En_FF; apply Axiom_Scheme; split.
          + destruct H; apply Theorem33 with (x:=X); auto.
            unfold Subclass; intros; apply Axiom_Scheme in H7; apply H7.
          + exists z; split; auto.
        - intros; generalize (Theorem16 u); contradiction. }
      assert ( (En_FF X (En_A X B le) le) ⊂ (En_FF X X le) /\
      Nest (En_FF X (En_A X B le) le) /\ (En_A X B le) ≠ Φ).
      { assert ((En_FF X (En_A X B le) le) ⊂ (En_FF X X le)).
        { intros; unfold Subclass; intros.
          apply Axiom_Scheme in H6; destruct H6, H7 as [a H7], H7.
          apply Axiom_Scheme in H8; destruct H8.
          apply Axiom_Scheme; split; auto.
          unfold Subclass in H3; apply H3 in H9; unfold En_FF in H8.
          double H9; apply Axiom_Scheme in H10; destruct H10, H11 as [a1 H11].
          destruct H11; apply Property_FF with (b:= a1) in H9; auto.
          rewrite H9 in H7; exists a1; auto. }
        repeat split; auto; unfold Nest; intros.
        - destruct H7; apply Axiom_Scheme in H7; apply Axiom_Scheme in H8.
          destruct H7, H8, H9 as [a H9], H10 as [b H10], H9, H10.
          apply Axiom_Scheme in H11; apply Axiom_Scheme in H12.
          destruct H11, H12; rewrite H9, H10.
          unfold Nest in H4; add ((En_Fs X le b) ∈ B) H13.
        - apply Property_NotEmpty in H5; destruct H5; double H5.
          apply H3 in H7; apply Axiom_Scheme in H7; destruct H7, H8, H8.
          rewrite H8 in H5; apply Property_NotEmpty; exists x0.
          apply Axiom_Scheme; split; Ens. }
      double H; apply LemmaZ1 with (A:= (En_A X B le)) in H7.
      apply H7 in H6; clear H7; double H6; apply H0 in H6; clear H0.
      destruct H6 as [y H0]; unfold Chain in H7; double H.
      unfold PartialOrderSet in H6; apply H7 in H6; clear H7.
      destruct H6; exists (En_Fs X le y); split; intros.
      * unfold BoundU in H0; double H; add (X≠Φ) H8; apply H0 in H8.
        clear H0; destruct H8, H8 as [H9 H8]; clear H9.
        unfold En_FF; apply Axiom_Scheme; split.
        -- assert (En_Fs X le y ⊂ X).
           { unfold Subclass; intros; apply Axiom_Scheme in H9; apply H9. }
           destruct H; apply Theorem33 in H9; auto.
        -- exists y; split; auto.
      * double H8; unfold Subclass in H3; apply H3 in H9.
        apply Axiom_Scheme in H9; destruct H9, H10, H10; add (X≠Φ) H.
        apply LemmaZ2 with (A:=En_A X B le)(y:=y)(x:=u) in H; auto.
        apply Axiom_Scheme; split; auto; exists x; split; auto.
        apply Axiom_Scheme; split; Ens; rewrite <- H10; auto.
Qed.

Hint Resolve Zorn : Axiom_of_Choice.

End Zorn_Lemma.


(*
 * DATA AND FUNCTIONS
 *)

(* Introduce a new type. *)
Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

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

(* `Compute` evaluates the expression and prints the result. *)
Compute (next_weekday friday).
Compute (next_weekday monday).

(* Makes an assertion and gives it a name. *)
Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

(* Verify the last assertion.
 *
 * Notice that `Example` does not verify if the assertion is valid, it only
 * names it. To verify it, one must use `Proof`.
 *)
Proof. simpl. reflexivity. Qed.

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

From Coq Require Export String.

(*
 * BOOLEANS
 *)

Inductive bool : Type :=
  | true
  | false.

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

Example test_negb1: (negb true) = false.
Proof. simpl. reflexivity. Qed.
Example test_negb2: (negb false) = true.
Proof. simpl. reflexivity. Qed.

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

Example test_andb1: (andb true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb2: (andb true false) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb3: (andb false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb4: (andb false false) = false.
Proof. simpl. reflexivity. Qed.

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

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

Notation "a && b" := (andb a b).
Notation "a || b" := (orb a b).

Example test_andb_notation: true && false = false.
Proof. simpl. reflexivity. Qed.

Example test_orb_notation: false || true = true.
Proof. simpl. reflexivity. Qed.

(* Exercise 1 *)

Definition nandb (b1 : bool) (b2 : bool) : bool :=
  negb (andb b1 b2).

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.

(* Exercise 2 *)

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

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

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

(*
 * TYPES
 *)

(* `Check` prints the given expression's type. *)
Check true.

(* `Check` may also be used to check the type. *)
Check andb: bool -> bool -> bool.
Check negb: bool -> bool.
Check (negb true) : bool.

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

Inductive color : Type :=
  | black
  | white
  (* Constructors may take arguments. Here we say the `color` constructor
   * `primary` takes an argument of type `rgb`.
   *)
  | primary (p : rgb).

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

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

(*
 * MODULES
 *)

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b :bool := true.

Check Playground.b : rgb.
Check b : bool.

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

(*
 * TUPLES
 *)

Module TuplePlayground.

  Inductive bit : Type :=
    | B0
    | B1.

  (* One may declare a tuple-like structure by using an inductively-defined type
   * with only one variant.
   *)
  Inductive nybble : Type :=
    | bits (b0 b1 b2 b3 : bit).

  Check (bits B1 B0 B1 B0) : nybble.

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

  Example test_all_zero1: all_zero (bits B1 B0 B1 B0) = false.
  Proof. simpl. reflexivity. Qed.
  Example test_all_zero2: all_zero (bits B0 B0 B0 B0) = true.
  Proof. simpl. reflexivity. Qed.

End TuplePlayground.

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

(*
 * NUMBERS
 *)

Module NatPlayground1.

  (* Up until this point, all types defined here compose a finite set. Natural
   * numbers, however, comprehend an infinite set. Hence, how one might
   * represent them?
   *
   * Just like computers use a binary representation to facilitate circuitry, a
   * person who's trying to prove something must pick a representation that
   * eases such proofs.
   *
   * Unary representation?
   *)
  Inductive nat : Type :=
    | O                    (* zero *)
    | S (n : nat).         (* successor of another nat *)

  (* That's indeed a powerful definition.
   *
   * The constructor `O` belongs to the set `nat`.
   * For all `n` that belongs to `nat`, `S n` will also belong to `nat`.
   *
   * So:
   *     - Zero may be encoded as `O`,
   *     - One as `S O`,
   *     - Two as `S (S O)`,
   *     - (...)
   *)

  Check O: nat.
  Check S: nat -> nat.

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

  Example test_pred1: pred O = O.
  Proof. simpl. reflexivity. Qed.
  Example test_pred2: pred (S O) = O.
  Proof. simpl. reflexivity. Qed.
  Example test_pred3: pred (S (S O)) = S O.
  Proof. simpl. reflexivity. Qed.

  (* Notice that, since the previous `nat` definition is inside a module, all
   * other scopes do not use it. Rather, they use `nat` defined in the std lib.
   *)

End NatPlayground1.

Check (S (S (S (O)))). (* Will print 3, built-in Coq magic notation. *)

Example coq_nat_magic: (S (S (S (O)))) = 3.
Proof. simpl. reflexivity. Qed.

  Definition suc (n : nat) : nat := S (n).

  Example test_suc1: suc O = 1.
  Proof. simpl. reflexivity. Qed.
  Example test_suc2: suc (S O) = 2.
  Proof. simpl. reflexivity. Qed.

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

Example test_minustwo1: minustwo O = 0.
Proof. simpl. reflexivity. Qed.
Example test_minustwo2: minustwo (S O) = 0.
Proof. simpl. reflexivity. Qed.
Example test_minustwo3: minustwo (S (S O)) = 0.
Proof. simpl. reflexivity. Qed.
Example test_minustwo4: minustwo (S (S (S O))) = 1.
Proof. simpl. reflexivity. Qed.

(* Notice that, while the terms `S` and `pred` have the same type, they do not
 * represent the same concept.
 *
 * `S` is a constructor. It just creates a value an does nothing with it.
 * `pred` is a _computation_ rule (i.e., a function). It takes a value and
 * does something with it.
 *)
Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

(* Use `Fixpoint` to define a recursive function. *)
Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1: odd 0 = false.
Proof. simpl. reflexivity. Qed.
Example test_odd2: odd 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_odd3: odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

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

  Example test_plus1: plus 2 3 = 5.
  Proof. simpl. reflexivity. Qed.

  (* What's even happening above??
   *
   *   plus [(S (S O)) (S (S (S O)))] = plus [2 3]
   *                   ^^^^^^^^^^^^^
   *
   * = S (plus [(S (S O)) (S (S O))])
   *   ^                  ^^^^^^^^^
   *
   * = S (S (plus [(S (S O)) (S O)]))
   *   ^  ^                  ^^^^^
   *
   * = S (S (S (plus [(S (S O)) O])))
   *   ^  ^  ^        ----2---- *
   *
   * = S (S (S (S (S O))))
   *   ^  ^  ^  ---2---
   *
   * = 5
   *)

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

  Example test_minus1: minus 2 0 = 2.
  Proof. simpl. reflexivity. Qed.
  Example test_minus2: minus 0 2 = 0.
  Proof. simpl. reflexivity. Qed.
  Example test_minus3: minus 5 3 = 2.
  Proof. simpl. reflexivity. Qed.
  Example test_minus4: minus 3 5 = 0.
  Proof. simpl. reflexivity. Qed.

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

  Example test_mult1: mult 3 0 = 0.
  Proof. simpl. reflexivity. Qed.
  Example test_mult2: mult 3 1 = 3.
  Proof. simpl. reflexivity. Qed.
  Example test_mult3: mult 3 2 = 6.
  Proof. simpl. reflexivity. Qed.

End NatPlayground2.

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

Example test_exp1: exp 3 0 = 1.
Proof. simpl. reflexivity. Qed.
Example test_exp2: exp 3 1 = 3.
Proof. simpl. reflexivity. Qed.
Example test_exp3: exp 3 2 = 9.
Proof. simpl. reflexivity. Qed.

(* Exercise 3 *)

Fixpoint factorial (n : nat) : nat :=
  match n with
  | O => 1
  | 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.

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

Check ((0 + 1) + 1) : nat.

(* Checks if both arguments are equal. *)
Fixpoint eqb (m n : nat) : bool :=
  match m, n with
  | O, O => true
  | O, _ => false
  | _, O => false
  | S m', S n' => eqb m' n'
  end.

Example test_eqb1: eqb 0 5 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb2: eqb 5 0 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb3: eqb 4 5 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb4: eqb 5 4 = false.
Proof. simpl. reflexivity. Qed.
Example test_eqb5: eqb 5 5 = true.
Proof. simpl. reflexivity. Qed.

(* Checks if the first argument is less than or equal to the first. *)
Fixpoint leb (m n : nat) : bool :=
  match m, n with
  | O, _       => true
  | S _, O     => false
  | S m', S n' => leb m' n'
  end.

Example test_leb1: leb 4 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 3 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 3 = false.
Proof. simpl. reflexivity. Qed.

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

Example test_leb4: (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

(* Notice the difference between `=` and `=?`.
 *
 * The former, built into Coq, is used to define a proposition (i.e. a logical
 * claim which may be proved later). The latter, however, may be seen as a
 * simple function (a notation for `eqb`), which may be used to compute a
 * value.
 *)

(* Exercise 4 *)

(* Checks if the first argument is less than the second. *)
Definition ltb (m n : nat) : bool :=
  if eqb m n
    then false
    else leb m n.

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

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

(*
 * PROOF BY SIMPLIFICATION
 *)

(* Notice that the previous proofs used `simpl` to simplify both sides of the
 * equation while `reflexivity` was used to check that both sides contain
 * identical values.
 *
 * In such examples, however, `simpl` was not needed at all since `reflexivity`
 * can perform simplifications when checking that two sides are equal.
 * Indeed, `reflexivity` is a little bit more powerful since it can also
 * _unfold_ defined terms.
 *)

(* `intros`, `simpl` and `reflexivity` are called tactics. A tactic is a command
 * used between `Prof` and `Qed` to guide the process of checking some claim.
 *
 * `Theorem`, `Example`, `Lemma`, `Fact` and `Remark` are almost analogous.
 *)

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

(* Theorem plus 1 on the left. *)
Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

(* Theorem mult 0 on the left. *)
Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof.
  intros n. simpl. reflexivity. Qed.

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

(*
 * PROOF BY REWRITING
 *)

Theorem plus_id_example : forall m n : nat,
  m = n ->
  m + m = n + n.
Proof.
  (* Move both quantifiers, `m` and `n`, into the context. *)
  intros m n.
  (* Move the hypothesis, `m = n`, into the context. *)
  intros Hyp.
  (* Rewrite the goal, `m + m = n + n`, using the hypothesis,
   * so we get `n + n = n + n`.
   *
   * The arrow below tells Coq to rewrite from left to right. *)
  rewrite -> Hyp.
  reflexivity.
Qed.

(* The `rewrite` tactic may be used with a previously proved theorem instead
 * of an hypothesis from the context.
 *)

(* Exercise 5 *)

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite <- H2.
  rewrite -> H1.
  reflexivity.
Qed.

(* Provided by the standard library: *)
Check mult_n_O:
  forall n : nat, 0 = n * 0.
Check mult_n_Sm:
  forall n m : nat, n * m + n = n * S m.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  (* Notice the `<-`. I want to go from `n * 0` to `0`,
   * and not from `0` to `n * 0`. *)
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.

(* Exercise 6 *)

(* Use those two lemmas about multiplication that we just checked to prove the
 * following theorem. Hint: recall that 1 is S O. *)
Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.

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

(*
 * PROOF BY CASE ANALYSIS
 *)

(* Not everything can be proved by simple calculation and rewriting.
 * In general, unknown and hypothetical values can block simplification.
 *)

Theorem plus_1_neq_0_first_try : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  simpl.
Abort.

(* The `simpl` tactic cannot do anything meaningful above since both `+` and
 * `=?` perform a `match` in the first argument (here, `n` and `n + 1`,
 * respectively). Since those are expressions with unknown values,
 * simplification becomes impossible.
 *
 * To make progress, one must consider the possible forms of the given unknown
 * value separately. Given `n: nat`, we must consider the constructors `O` and
 * `S`. The tactic `destruct` can be used here.
 *)

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
  - simpl plus. (* May be elided. `reflexivity` already does that. *)
    simpl eqb.  (* May be elided. *)
    reflexivity.
  - simpl plus. (* `simpl` again won't do anything since `n'` is unknown. *)
    simpl eqb.  (* See `eqb` definition. *)
    reflexivity.
Qed.

(* The tactic `destruct` will generate two sub goals from the original goal.
 * Each of then will have to be proven separately.
 *
 * ` as [| n'] ` is an **intro pattern**. It tells what variable names should be
 * introduced in each sub goal. In general, it is a list of list of names,
 * separated by `|`.
 * In this case, the first element is empty since the `O` constructor is
 * nullary. The second element gives a single name, ` n' ` to `S`'s element.
 *
 * `eqn:E` tells `destruct` to give the name `E` to the equation. Since the
 * sub goal's equation is named, their assumptions (e.g. `n: nat`, introduced by
 * `intros n`) are not elided (the default behavior without `eqn:E`).
 *
 * `-` signs a bullet. For each sub goal generated by `destruct`, one must
 * handle the respective bullet. Other allowed signals are `-`, `+`, `*`, or a
 * repetition of them, such as `--` or `***`. Useful in nested `destruct`s.
 *)

(* Involutive means that negation is its own inverse. *)
Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative : forall b c : bool,
  andb b c = andb c b.
Proof.
  intros b c.
  destruct b eqn:EqnB.
  - destruct c eqn:EqnC.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:EqnC.
    + reflexivity.
    + reflexivity.
Qed.

(* The pattern `intros n. destruct n as [| n'] eqn:E.` is so common that
 * exists a shorthand for it. One may perform case analysis on a variable
 * when introducing it by using an intro pattern instead of a variable name.
 *)
Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

(* If there aren't any constructors that need names, `[]` may be used. *)
Theorem andb_commutative' : forall b c : bool,
  andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(* Exercise 7 *)

(* Prove the following claim, marking cases (and sub cases) with bullets when
 * you use destruct. Hint: delay introducing the hypothesis until after you
 * have an opportunity to simplify it. *)
 Theorem andb_true_elim2 : forall b c : bool,
 andb b c = true -> c = true.
Proof.
 intros b c.
 destruct c eqn:EqnC.
 - reflexivity.
 - intros H. rewrite <- H. destruct b eqn:EqnB.
   + reflexivity.
   + reflexivity.
Qed.

(* Exercise 8 *)

Theorem zero_nbeq_plus_1 : forall n : nat,
  eqb 0 (n + 1) = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

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

(*
 * FIXPOINTS AND STRUCTURAL RECURSION
 *)

(* A fixpoint definition operates on structural recursion. In order to guarantee
 * that every function that can be defined in Coq will terminate on all inputs,
 * Coq demands that at least one argument of every `Fixpoint` is _decreasing_.
 *)

 (* Fixpoint factorial' (n i acc : nat) : nat :=
  if i =? n
    then i * acc
    else (factorial' n (i + 1) (acc * i)). *)

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

(*
 * MORE EXERCISES
 *)

(* Exercise 9 *)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool),
  f (f b) = b.
Proof.
  intros hyp1 hyp2 b.
  rewrite -> hyp2. rewrite -> hyp2.
  reflexivity.
Qed.

(* Exercise 10 *)

Definition manual_grade_for_negation_fn_applied_twice :
  option (nat * string) := None.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool),
  f (f b) = b.
Proof.
  intros hyp1 hyp2 b.
  rewrite -> hyp2. rewrite -> hyp2.
  destruct b.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(* Exercise 11 *)

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b.
  - simpl. intros hyp. rewrite <- hyp. reflexivity.
  - simpl. intros hyp. rewrite <- hyp. reflexivity.
Qed.

(* Exercise 12 *)

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

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

Fixpoint decr (m : bin) : bin :=
  match m with
  | Z => Z
  | B0 m' => B1 (decr m')
  | B1 Z => Z
  | B1 m' => B0 m'
  end.

Fixpoint bin_to_nat (m : bin) : nat :=
  match m with
  | Z => 0
  | B0 m' => 2 * (bin_to_nat m')
  | B1 m' => 1 + 2 * (bin_to_nat m')
  end.

Example test_bin_decr1 : (decr Z) = Z.
Proof. simpl. reflexivity. Qed.
Example test_bin_decr2 : (decr (B1 Z)) = Z.
Proof. simpl. reflexivity. Qed.
Example test_bin_decr3 : (decr (B0 (B1 Z))) = B1 Z.
Proof. simpl. reflexivity. Qed.
Example test_bin_decr4 : (decr (B1 (B1 Z))) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_decr5 : (decr (B0 (B0 (B1 Z)))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
Proof. simpl. reflexivity. Qed.
Example test_bin_incr5 :
        bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr6 :
        bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. simpl incr. simpl bin_to_nat. simpl. reflexivity. Qed.