Norm: STLCの正規化


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Hint Constructors multi.


このオプションの章は、Pierceによる Types and Programming Languages (和訳:型システム入門)の12章に基づいています。 ここでは説明しない非形式的な証明がその章には載っているので、同時に読むと良いでしょう。
この章では、単純型付きラムダ計算の別の基本的な理論的性質を検討します。 型付けされるプログラムの評価は有限回のステップで停止することが保証されるという事実です。 つまり、すべての型付けされた項は正規化可能(normalizable)です。
ここまで考えてきた型安全性とは異なり、正規化性は本格的なプログラミング言語には拡張されません。 なぜなら、本格的な言語ではほとんどの場合、単純型付きラムダ計算に、(MoreStlc章で議論したような)一般再帰や再帰型が拡張され、停止しないプログラムが書けるようになっているからです。 しかし、正規化性の問題は、System F-omegaのように多相なラムダ計算のメタ理論を考える際に、「型のレベル」で再度現れます。 System F-omegaでは、型の表現に事実上単純型付きラムダ計算を含んでおり、型チェックアルゴリズムの停止性は、型の式の「正規化」操作が停止することが保証されていることに依拠しています。
正規化の証明を学習する別の理由は、それが、(ここでやっているように)論理的関係の基本的証明テクニックを含むような型理論の文献において、とても美しく、そして刺激的な数学だからです。
ここで考える計算は、基本型boolと対を持つ単純型付きラムダ計算です。 ここではboolを未解釈基本型として扱う基本ラムダ計算項の処理を細部まで示します。 ブール演算と対の拡張は読者に残しておきます。 この基礎部分でさえ、正規化性は証明が完全に自明ということはありません。 なぜなら、項の各簡約は部分項のリデックスを複製することがあるからです。

練習問題: ★★, standard (norm_fail)

型付けされた項のサイズについての素直な帰納法で正規化性を証明しようとしたとき、どこで失敗するでしょうか?

Exercise: 5 stars, standard, recommended (norm)

The best ways to understand an intricate proof like this is are (1) to help fill it in and (2) to extend it. We've left out some parts of the following development, including some proofs of lemmas and the all the cases involving products and conditionals. Fill them in.

言語


関係する言語の定義から始めます。 MoreStlc章のものと同様です。 そして、型の保存とステップの決定性を含む結果も成立します。 (進行は使いません。) 正規化の節まで飛ばしても構いません...

構文と操作的意味


Inductive ty : Type :=
  | Bool : ty
  | Arrow : ty -> ty -> ty
  | Prod : ty -> ty -> ty
.

Inductive tm : Type :=
    
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
    
  | pair : tm -> tm -> tm
  | fst : tm -> tm
  | snd : tm -> tm
    
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

置換


Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 =>
      abs y T (if eqb_string x y then t1 else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | pair t1 t2 => pair (subst x s t1) (subst x s t2)
  | fst t1 => fst (subst x s t1)
  | snd t1 => snd (subst x s t1)
  | tru => tru
  | fls => fls
  | test t0 t1 t2 =>
      test (subst x s t0) (subst x s t1) (subst x s t2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

簡約


Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (pair v1 v2)
  | v_tru : value tru
  | v_fls : value fls
.

Hint Constructors value.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')
  
  | ST_Pair1 : forall t1 t1' t2,
        t1 --> t1' ->
        (pair t1 t2) --> (pair t1' t2)
  | ST_Pair2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        (pair v1 t2) --> (pair v1 t2')
  | ST_Fst : forall t1 t1',
        t1 --> t1' ->
        (fst t1) --> (fst t1')
  | ST_FstPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (fst (pair v1 v2)) --> v1
  | ST_Snd : forall t1 t1',
        t1 --> t1' ->
        (snd t1) --> (snd t1')
  | ST_SndPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (snd (pair v1 v2)) --> v2
  
  | ST_TestTrue : forall t1 t2,
        (test tru t1 t2) --> t1
  | ST_TestFalse : forall t1 t2,
        (test fls t1 t2) --> t2
  | ST_Test : forall t0 t0' t1 t2,
        t0 --> t0' ->
        (test t0 t1 t2) --> (test t0' t1 t2)

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

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep 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.

型付け


Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=
  
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (update Gamma x T11) t12 T12 ->
      has_type Gamma (abs x T11 t12) (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (Arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (app t1 t2) T2
  
  | T_Pair : forall Gamma t1 t2 T1 T2,
      has_type Gamma t1 T1 ->
      has_type Gamma t2 T2 ->
      has_type Gamma (pair t1 t2) (Prod T1 T2)
  | T_Fst : forall Gamma t T1 T2,
      has_type Gamma t (Prod T1 T2) ->
      has_type Gamma (fst t) T1
  | T_Snd : forall Gamma t T1 T2,
      has_type Gamma t (Prod T1 T2) ->
      has_type Gamma (snd t) T2
  
  | T_True : forall Gamma,
      has_type Gamma tru Bool
  | T_False : forall Gamma,
      has_type Gamma fls Bool
  | T_Test : forall Gamma t0 t1 t2 T,
      has_type Gamma t0 Bool ->
      has_type Gamma t1 T ->
      has_type Gamma t2 T ->
      has_type Gamma (test t0 t1 t2) T
.

Hint Constructors has_type.

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

コンテキスト不変性


Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  
  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (pair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (pair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (fst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (snd t)
  
  | afi_test0 : forall x t0 t1 t2,
      appears_free_in x t0 ->
      appears_free_in x (test t0 t1 t2)
  | afi_test1 : forall x t0 t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (test t0 t1 t2)
  | afi_test2 : forall x t0 t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (test 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'.
  induction H;
    intros Gamma' Heqv...
  -
    apply T_Var... rewrite <- Heqv...
  -
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (eqb_stringP x y)...
  -
    apply T_Pair...
  -
    eapply T_Test...
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.
  induction Htyp; inversion Hafi; subst...
  -
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string 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.

保存


Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S ->
     has_type empty v U ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  induction t;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  -
    simpl. rename s into y.
    unfold update, t_update in H1.
    destruct (eqb_stringP x y).
    +
    
      subst.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    +
      
      apply T_Var...
  -
    rename s into y. rename t into T11.
    apply T_Abs...
    destruct (eqb_stringP x y).
    +
    
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    +
    
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst. rewrite false_eqb_string...
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.
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  -
    
    inversion HE; subst...
    +
      
      apply substitution_preserves_typing with T1...
      inversion HT1...
  -
    inversion HT...
  -
    inversion HT...
Qed.

決定性


Lemma step_deterministic :
   deterministic step.
Proof with eauto.
   unfold deterministic.
   intros t t' t'' E1 E2.
   generalize dependent t''.
   induction E1; intros t'' E2; inversion E2; subst; clear E2...
   - inversion H3.
   - exfalso; apply value__normal in H...
   - inversion E1.
   - f_equal...
   - exfalso; apply value__normal in H1...
   - exfalso; apply value__normal in H3...
   - exfalso; apply value__normal in H...
   - f_equal...
   - f_equal...
   - exfalso; apply value__normal in H1...
   - exfalso; apply value__normal in H...
   - f_equal...
   - f_equal...
   - exfalso.
     inversion E1; subst.
     + apply value__normal in H0...
     + apply value__normal in H1...
   - exfalso.
     inversion H2; subst.
     + apply value__normal in H...
     + apply value__normal in H0...
   - f_equal...
   - exfalso.
     inversion E1; subst.
     + apply value__normal in H0...
     + apply value__normal in H1...
   - exfalso.
     inversion H2; subst.
     + apply value__normal in H...
     + apply value__normal in H0...
   -
       inversion H3.
   -
       inversion H3.
   - inversion E1.
   - inversion E1.
   - f_equal...
Qed.

正規化


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

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

あたりまえの事実:

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

正規化の証明のキーとなる問題は、(多くの帰納法による証明と同様に)十分な強さの帰納法の仮定を見つけることです。 このために、それぞれの型Tに対して型Tの閉じた項の集合R_Tを定義することから始めます。 これらの集合を関係Rを使って定め、tR_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) となることである。

この定義は必要な強化された帰納法の仮定を与えます。 最初のゴールはすべてのプログラム(つまり、基本型のすべての閉じた項)が停止することを示すことです。 しかし、基本型の閉じた項は関数型の部分項を含むこともできるので、これらについても性質を知ることが必要です。 さらに、これらの部分項が停止することを知るだけでは不十分です。 なぜなら、正規化された関数を正規化された引数へ適用すると置換が行われるため、さらに簡約ステップが発生する可能性があるからです。 これから関数型の項についてより強い条件が必要です。 つまり、自分自身が停止するだけでなく、停止する引数に適用されると停止する結果にならなければならないという条件です。
Rの形は論理的関係(logical relations)証明テクニックの特徴です。 (ここで扱うのは単項関係のみなので、おそらく論理的性質(logical properties)という方がより適切でしょう。) 型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 Bool ->
                      halts t ->
                      R Bool t
      | R_arrow : forall T1 T2 t, has_type empty t (Arrow T1 T2) ->
                      halts t ->
                      (forall s, R T1 s -> R T2 (app t s)) ->
                      R (Arrow T1 T2) t.
残念ながらCoqはこの定義を受け付けません。 なぜなら帰納的定義のstrict positivity requirementを満たさないからです。 strict positivity requirementとは、定義される型がコンストラクタ引数の型の矢印の左に現れてはいけないというものです。 ここで、この規則を破っているのは、R_arrowの第3引数、すなわち、(forall s, R T1 s -> R TS (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
   | Bool => True
   | Arrow T1 T2 => (forall s, R T1 s -> R T2 (app t s))

   
   | Prod T1 T2 => False
   end).

この定義からすぐに導かれることとして、すべての集合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.

さて、メインの結果に進みます。 すべての型Tの項がR_Tの要素であることを示すことです。 R_haltsと組み合わせると、すべての型付けされる項は停止して値になることが示されます。

R_T の要素であるか否かは簡約によって変化しない


一種の強保存性を示す予備的補題から始めます。 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.
 -
  intros [t'' [STM V]].
  inversion STM; subst.
   exfalso. apply value__normal in V. unfold normal_form in V. apply V. exists t'. auto.
   rewrite (step_deterministic _ _ _ ST H). exists t''. split; assumption.
 -
  intros [t'0 [STM V]].
  exists t'0. split; eauto.
Qed.

さてメインの補題ですが、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]].
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  auto.
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  intros.
  eapply IHT2.
  apply ST_App1. apply E.
  apply RRt; auto.
Admitted.

複数ステップへの一般化については自明です:

Lemma multistep_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.

逆向き方向については、 tがステップ前に型Tを持つという事実を追加の仮定として加える必要があります。

Lemma step_preserves_R' : forall T t t',
  has_type empty t T -> (t --> t') -> R T t' -> R T t.
Proof.
Admitted.

Lemma multistep_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.

Tの項の閉じたインスタンスがR_Tに含まれる


これから、型Tのすべての項がR_Tに含まれることを示すことに取りかかります。 ここで使う帰納法は型付け導出についてのものです(もし、型付け導出の帰納法と全く関係がない型付けされた項についての証明があったら驚くでしょう!)。 ここで技術的に難しいのは、関数抽象の場合だけです。 帰納法で議論していることから、項 abs x T1 t2R_(T1->T2)に属していることを示すことにはt2R_(T2)に属するという帰納法の仮定を含みます。 しかしR_(T2)は「閉じた」項の集合である一方、t2xを自由変数として含む可能性があるので、これは筋が通りません。
この問題は帰納法の仮定を適度に一般化するという標準的なトリックを使うことで解決されます。 閉じた項を含む主張を証明する代わりに、開いた項tのすべての閉じたインスタンス(instances)をカバーするように一般化します。 非形式的には、補題の主張は次のようになります:
もし x1:T1,..xn:Tn |- t : T かつ、 v1,...,vnR T1 v1, R T2 v2, ..., R Tn vn となる値ならば、 R T ([x1:=v1][x2:=v2]...[xn:=vn]t) である。
証明は、型付け x1:T1,..xn:Tn |- t : T の導出についての帰納法で進みます。 一番興味深いのは、関数抽象の場合です。

多重置換、多重拡張、インスタンス化


しかしながら、主張と補題の証明の形式化に進む前に、項tの多重置換(multiple substitutions)と型付けコンテキストの多重拡張(multiple extensions)についての事実を扱う、ある(かなり退屈な)機構を構築する必要があります。 特に、置換が現れる順序とそれらの相互関係を正確にする必要があります。 これらの詳細は非形式的な紙の証明では単に省略されるのが通常です。 しかしもちろん、Coqはそうはしません。 ここでは閉じた項を置換していることから、1つの置換が他の置換によってできた項に影響するかどうかを心配する必要はありません。 しかしそれでも置換の順序については考慮する必要があります。 なぜなら、x1,...xnに同じ識別子が複数回出現しそれらが違うviTiと関連付けされている可能性があるからです。
すべてを正確にするために、環境は左から右へ拡張されることとし、多重置換は右から左へ実行されることとします。 これが整合的であることを見るために、...,y:bool,...,y:nat,... と書かれる環境と、対応する ...[y:=(tbool true)]...[y:=(const 3)]...t と書かれる項の置換があるとします。 環境は左から右に拡張されることから、y:naty:boolを隠します。 置換は右から左に実行されることから、y:=(const 3) が最初に実行され、y:=(tbool true) は何の作用もしません。 これから置換は項の型を正しく保存します。
このポイントを覚えておくと、次の定義が理解できます。
多重置換(multisubstitution)は置換のリストの適用結果です。 置換のリストは環境と呼ばれます(environment)。

Definition env := list (string * tm).

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

(識別子、型)の対のリストを使った型付けコンテキストの継続的拡張についても同様の機構が必要です。 この型付けコンテキストを「型割当て」(type assignment)と呼びます。

Definition tass := list (string * ty).

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

環境と型割当てに同様にはたらくいくつかの簡単な操作が必要です。

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

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

インスタンス化(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).

これから、これらの定義についてのいろいろな性質を証明します。

置換についてのさらなる事実


最初に(もともとの)置換について、ある追加の補題が必要です。

Lemma vacuous_substitution : forall t x,
     ~ appears_free_in x t ->
     forall t', [x:=t']t = t.
Proof with eauto.
Admitted.

Lemma subst_closed: forall t,
     closed t ->
     forall x t', [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 ([x:=v]t).
Proof with eauto.   unfold closed, not.
  induction t; intros x v P A; simpl in A.
    -
     destruct (eqb_stringP x s)...
     inversion A; subst. auto.
    -
     inversion A; subst...
    -
     destruct (eqb_stringP x s)...
     + inversion A; subst...
     + inversion A; subst...
    -
     inversion A; subst...
    -
     inversion A; subst...
    -
     inversion A; subst...
    -
     inversion A.
    -
     inversion A.
    -
     inversion A; subst...
Qed.

Lemma duplicate_subst : forall t' x t v,
  closed v -> [x:=t]([x:=v]t') = [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 ->
    [x1:=v1]([x:=v]t) = [x:=v]([x1:=v1]t).
Proof with eauto.
 induction t; intros; simpl.
  -
   destruct (eqb_stringP x s); destruct (eqb_stringP x1 s).
   + subst. exfalso...
   + subst. simpl. rewrite <- eqb_string_refl. apply subst_closed...
   + subst. simpl. rewrite <- eqb_string_refl. rewrite subst_closed...
   + simpl. rewrite false_eqb_string... rewrite false_eqb_string...
Admitted.

多重置換の性質


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.

閉じた環境とは、閉じた項のみを含む環境です。

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

次は、閉じた項についてのmsubstがどのようにsubst や各項の形に分配されるかを特徴づける一連の補題です。

Lemma subst_msubst: forall env x v t, closed v -> closed_env env ->
    msubst env ([x:=v]t) = [x:=v](msubst (drop x env) t).
Proof.
  induction env0; intros; auto.
  destruct a. simpl.
  inversion H0. fold closed_env in H2.
  destruct (eqb_stringP s x).
  - subst. rewrite duplicate_subst; auto.
  - simpl. rewrite swap_subst; eauto.
Qed.

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

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

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

他の項コンストラクタに対しても同様の関数が必要になるでしょう。


多重拡張の性質


型割当てのふるまいを、対応するコンテキストのふるまいと結合する必要があります。

Lemma mupdate_lookup : forall (c : tass) (x:string),
    lookup x c = (mupdate empty c) x.
Proof.
  induction c; intros.
    auto.
    destruct a. unfold lookup, mupdate, update, t_update. destruct (eqb_string s x); auto.
Qed.

Lemma mupdate_drop : forall (c: tass) Gamma x x',
      mupdate Gamma (drop x c) x'
    = if eqb_string x x' then Gamma x' else mupdate Gamma c x'.
Proof.
  induction c; intros.
  - destruct (eqb_stringP x x'); auto.
  - destruct a. simpl.
    destruct (eqb_stringP s x).
    + subst. rewrite IHc.
      unfold update, t_update. destruct (eqb_stringP x x'); auto.
    + simpl. unfold update, t_update. destruct (eqb_stringP s x'); auto.
      subst. rewrite false_eqb_string; congruence.
Qed.

インスタンス化の性質


以下は簡単です。

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_invert.
    simpl in *.
    destruct (eqb_string 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_invert.
    unfold lookup in *. destruct (eqb_string 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 (eqb_string x x0); auto. constructor; eauto.
Qed.

multistep(==>*)についての合同補題


これらのいくつかだけが必要になります。必要が生じた時点で追加しなさい。

Lemma multistep_App2 : forall v t t',
  value v -> (t -->* t') -> (app v t) -->* (app v t').
Proof.
  intros v t t' V STM. induction STM.
   apply multi_refl.
   eapply multi_step.
     apply ST_App2; eauto. auto.
Qed.


R補題


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

Lemma msubst_preserves_typing : forall c e,
     instantiation c e ->
     forall Gamma t S, has_type (mupdate 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.

そして一番最後に、メインの補題です。

Lemma msubst_R : forall c env t T,
    has_type (mupdate empty c) t T ->
    instantiation c env ->
    R T (msubst env t).
Proof.
  intros c env0 t T HT V.
  generalize dependent env0.
  remember (mupdate empty c) as Gamma.
  assert (forall x, Gamma x = lookup x c).
    intros. rewrite HeqGamma. rewrite mupdate_lookup. auto.
  clear HeqGamma.
  generalize dependent c.
  induction HT; intros.

  -
   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.

  -
    rewrite msubst_abs.
    assert (WT: has_type empty (abs x T11 (msubst (drop x env0) t12)) (Arrow T11 T12)).
    { eapply T_Abs. eapply msubst_preserves_typing.
      { eapply instantiation_drop; eauto. }
      eapply context_invariance.
      { apply HT. }
      intros.
      unfold update, t_update. rewrite mupdate_drop. destruct (eqb_stringP x x0).
      + auto.
      + rewrite H.
        clear - c n. induction c.
        simpl. rewrite false_eqb_string; auto.
        simpl. destruct a. unfold update, t_update.
        destruct (eqb_string s 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 (multistep_preserves_R _ _ _ P H0).
     apply multistep_preserves_R' with (msubst ((x,v)::env0) t12).
       eapply T_App. eauto.
       apply R_typable_empty; auto.
       eapply multi_trans. eapply multistep_App2; eauto.
       eapply multi_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 update, t_update, lookup. destruct (eqb_string x x0); auto.
       constructor; auto.

  -
    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.

Admitted.

正規化定理


そして最後の定理です。

Theorem normalization : forall t T, has_type empty t T -> halts t.
Proof.
  intros.
  replace t with (msubst nil t) by reflexivity.
  apply (@R_halts T).
  apply (msubst_R nil); eauto.
  eapply V_nil.
Qed.