实施SKI转换-证明返回值已承诺类型

Question

我正在尝试实现一个函数extract，该函数需要一个像(f (g x y))这样的表达式以及一个变量，例如y并使用SKI组合器产生函数y --> (f (g x y))。在这种情况下，结果应为(S (K f) (g x))。

从某种意义上说，我正在做一个conversion，从lambda术语到其SKI版本。

我正在尝试对此进行打字，但遇到困难。

---

设置

这些表达式中的类型由以下归纳类型表示

Inductive type : Type :=
| base_type    : forall (n : nat), type
| arrow_type   : type -> type -> type.

基本上，我有一些用整数索引的基本类型（base_type），也可以在它们之间创建函数类型（arrow_type）

介绍函数类型的表示法

Notation "A --> B" := (arrow_type A B) (at level 30, right associativity).

表达由以下归纳类型表示

Inductive term : type -> Type :=

| var    : forall (n : nat) (A : type), term A
| eval   : forall {A B : type}, term (A-->B) -> term A -> term B

| I      : forall (A : type)    , term (A --> A)
| K      : forall (A B : type)  , term (A --> (B --> A))
| S      : forall (A X Y : type), term ((A --> X --> Y) --> (A --> X) --> A --> Y).

在这里，我又有了一组由整数n : nat和类型A : type（不是Type组成的索引的基本变量）

因此，变量x : term X是带有type X的表达式。

为减轻眼神，让我们介绍一下功能评估的表示法

Notation "f [ x ]" := (eval f x) (at level 25, left associativity).

---

简介示例

原始问题可以更精确地陈述如下。

让我们开始定义一些类型

Notation X := (base_type 0).
Notation Y := (base_type 1).

定义变量x y和函数f g（它们都可以用0索引，因为它们都具有不同的type）

Notation x := (var 0 X).
Notation y := (var 0 Y).
Notation g := (var 0 (X --> Y --> X)).
Notation f := (var 0 (X --> Y)).

结果表达式的type是Y。

Check f[g[x][y]].

我的目标是产生一个函数extract使得

extract f[g[x][y]] y

产生

S[K[f]][g[x]]

已填写类型

(S Y X Y)[(K (X-->Y) Y)[f]][g[x]]

---

type和term上的平等

要尝试定义extract，我需要在type和term上定义相等性。

Require Import Arith.EqNat.
Open Scope bool_scope.

Fixpoint eq_type (A B : type) : bool :=
  match A, B with
  | base_type n,    base_type m      => beq_nat n m
  | arrow_type X Y, arrow_type X' Y' => (eq_type X X') && (eq_type Y Y')
  | _, _  => false                                                      
  end.

Fixpoint eq_term {A B : type} (a : term A) (b : term B) : bool :=
  match a, b with
  | var n X      , var n' X'        => (beq_nat n n') && (eq_type X X')
  | eval X Y f x , eval X' Y' f' x' => (eq_type X X') && (eq_type Y Y') && (eq_term f f') && (eq_term x x')
  | I  X         , I X'             => (eq_type X X')
  | K X Y        , K X' Y'          => (eq_type X X') && (eq_type Y Y')
  | S Z X Y      , S Z' X' Y'       => (eq_type X X') && (eq_type Y Y') && (eq_type Z Z')
  | _            , _                => false                                   
  end.

---

尝试实施extract

“实现”非常简单

Fixpoint extract {A B : type} (expr : term B) (val : term A) : term (A-->B) :=
  if (eq_term expr val)
  then (I A)
  else 
    match expr with
    | eval X Y f x => (S A X Y)[extract f val][extract x val]
    | _            => (K B A)[expr]
    end.

有两个问题

1. 返回I A时：type的{​​{1}}是I A而不是承诺的A --> A，但是在这种情况下，我应该能够证明{ {1}}和A --> B相同。
2. 返回B时：返回值为A而不是(S A X Y)[...，但是我应该再次证明A --> Y等于A --> B 。

在那些特殊情况下如何证明Y和B以便接受函数定义？

Answer 1

您可以做的是将eq_type和eq_term从布尔函数转换为相等的决策程序。目前，据我所知，您的平等完全是句法。因此，您可以简单地使用Coq的平等概念来谈论术语和类型的平等。然后，您可以编写：

Definition eq_type_dec (A B : type) : { A = B } + { A <> B }. 

您几乎在A和B上进行了模式匹配，然后在相等的情况下返回left eq_refl，在其他情况下返回right ...，其中{{ 1}}是证明不平等所要做的一切。

执行相同的操作并定义...。在这里，您有两种选择，要么使内部类型相等，要么使内部类型相等：

eq_term_dec

或：

Definition eq_term_dec (A B : type) (a : A) (b : B) :
  { (A = B) * (existT (fun t => t) A a = existT (fun t => t) B b) }
  +
  { (A <> B) + (existT (fun t => t) A a <> existT (fun t => t) B b) }. 

第一个似乎很难写，但是给了您更大的灵活性。我可能更喜欢后者，并在处理可能不相等的类型时在Definition eq_term_dec (A : type) (a b : term A) : { a = b } + { a <> b }. 下使用它。

一旦有了这些，就可以将eq_type_check变成从属if：

match

我遗忘的分支中可能仍有很多工作。您可能会研究执行这种依赖类型编程的不同方法，可以像我在此处所示的那样手动进行，或者使用依赖消除策略，或者使用这些类型的递归。

---

编辑

要回答您的评论，以下是我所知道的写Fixpoint extract {A B : type} (expr : term B) (val : term A) : term (A-->B) := match eq_type_dec A B with | left eqAB => match eqAB in eq _ B1 return term B1 -> term (A --> B1) with | eq_refl => fun expr1 => (* now expr1 : A *) match eq_expr_dec _ _ expr1 val with | left eqab => I A | right neqab => (* ... *) end end expr (* note here we pass the values that must change type *) | right neqAB => (* ... *) end. 的两种方式。一种方法是使用Coq的eq_term_dec扩展名，该扩展名增加了一个公理，并且更加能够处理依赖类型：

Program

另一种方法是实际找出您需要的依赖类型的术语。必须有一种使用战术的方法，但是我不确定如何进行，但是我知道该术语的写法。这不是出于胆小，我不希望您了解所发生的事情，直到您熟悉从属模式匹配和“车队模式”。如果您想查看它的外观，就在这里：

Require Import Program.Equality.

Fixpoint eq_term_dec (A : type) (a b : term A) : { a = b } + { a <> b }.
  dependent induction a; dependent induction b; try (right ; congruence).
  - destruct (PeanoNat.Nat.eq_dec n n0); [ left | right ]; congruence.

Answer 2

我有一个解决方案，它虽然不漂亮，但似乎可行。特别是eq_term_dec的证明非常冗长和丑陋。

如果有人感兴趣，我的解决方案：

Inductive type : Type :=
| base_type    : forall (n : nat), type
| arrow_type   : type -> type -> type.

Notation "A --> B" := (arrow_type A B) (at level 30, right associativity).
Inductive term : type -> Type :=

| var    : forall (n : nat) (A : type), term A
| eval   : forall {A B : type}, term (A-->B) -> term A -> term B

| I      : forall {A : type}    , term (A --> A)
| K      : forall {A B : type}  , term (A --> (B --> A))
| S      : forall {A X Y : type}, term ((A --> X --> Y) --> ((A --> X) --> (A --> Y))).

(* Coercion term : type >-> Sortclass. *)

Notation "n :: A" := (var n A).
Notation "f [ x ]" := (eval f x) (at level 25, left associativity).

Fixpoint eq_type_dec (A B : type) : {A = B} + {A <> B}.
Proof.
  decide equality.
  decide equality.
Defined.

Require Import Coq.Logic.Eqdep.

Fixpoint eq_term_dec {A B : type} (a : term A) (b : term B) :
  ( (A = B) * (existT (fun T : type => term T) A a = existT (fun T : type => term T) B b) )
  +
  ( (A <> B) + (existT (fun T : type => term T) A a <> existT (fun T : type => term T) B b) ).
Proof.
  case a as [n X| X Y f x | X | X Y | Z X Y], b as [n' X'| X' Y' f' x' | X' | X' Y' | Z' X' Y'].

  (* var n X ? var n' X'*)
  - assert (ndec : {n=n'} + {n<>n'}) by decide equality.
    pose (Xdec := eq_type_dec X X').

    destruct ndec as [eqn | neqn], Xdec as [eqX | neqX].
    left.
    rewrite eqn.
    rewrite eqX.
    split; reflexivity.

    right; left.  apply neqX.
    right; right. 
    intro H; inversion H as [H1]. auto.
    right; left. apply neqX.

  - right; right; intro H; inversion H. (* n ?  f[x] *)
  - right; right; intro H; inversion H. (* n ? I *)
  - right; right; intro H; inversion H. (* n ? K *)
  - right; right; intro H; inversion H. (* n ? S *)
  - right; right; intro H; inversion H. (* f[x] ? n *)

  - pose (xdec := eq_term_dec _ _ x x').
    pose (fdec := eq_term_dec _ _ f f').

    destruct xdec, fdec.

    (* x = x' && f = f' *)
    left.
    split.
    apply fst in p0.
    inversion p0.
    auto.

    apply snd in p0.
    inversion p0.

    revert dependent x.
    revert dependent f.
    rewrite H0.
    rewrite H1.
    intros.
    apply snd in p.
    assert (x=x'). apply inj_pair2; apply p.
    assert (f=f'). apply inj_pair2; apply p0.
    rewrite H, H3. auto.

    right.
    destruct s.
    left. intro.
    apply fst in p.
    assert (X-->Y = X' --> Y').
    rewrite H, p.
    auto. auto.

    right. intro.
    inversion H.
    apply n.
    revert dependent x.
    revert dependent f.
    rewrite H1.
    rewrite H2.
    intros.
    apply inj_pair2 in H4.
    apply inj_pair2 in H4.
    rewrite H4.
    auto.

    right.
    destruct s.
    inversion p.
    inversion H.
    auto.
    inversion p.
    inversion H0.
    revert dependent x.
    revert dependent f.
    rewrite H2.
    rewrite H3.
    intros.
    apply inj_pair2 in H0.
    rewrite H0.
    right.
    intro.
    apply inj_pair2 in H1.
    inversion H1. auto.

    destruct s, s0.
    right. right.
    intro. inversion H. auto.
    right. right.
    intro. inversion H. auto.
    right. right.
    intro. inversion H. auto.
    right. right.
    intro. inversion H. auto.

  - right; right; intro H; inversion H. (* f[x] ? I *)
  - right; right; intro H; inversion H. (* f[x] ? K *)
  - right; right; intro H; inversion H. (* f[x] ? S *)
  - right; right; intro H; inversion H. (* I ? n *)
  - right; right; intro H; inversion H. (* I ? f[x] *)

  - pose (Xdec := eq_type_dec X X'). (* I ? I *)

    destruct Xdec.

    left; split; rewrite e; auto.
    right; left. intro. inversion H. auto.

  - right; right; intro H; inversion H. (* I ? K *)
  - right; right; intro H; inversion H. (* I ? S *)
  - right; right; intro H; inversion H. (* K ? n *)
  - right; right; intro H; inversion H. (* K ? f[x] *)
  - right; right; intro H; inversion H. (* K ? I *)

  - pose (Xdec := eq_type_dec X X').
    pose (Ydec := eq_type_dec Y Y').

    destruct Xdec, Ydec.

    left; split; rewrite e; rewrite e0; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.

  - right; right; intro H; inversion H. (* K ? S *)
  - right; right; intro H; inversion H. (* S ? n *)
  - right; right; intro H; inversion H. (* S ? f[x] *)
  - right; right; intro H; inversion H. (* S ? I *)
  - right; right; intro H; inversion H. (* S ? K *)

  - pose (Xdec := eq_type_dec X X').
    pose (Ydec := eq_type_dec Y Y').
    pose (Zdec := eq_type_dec Z Z').

    destruct Xdec, Ydec, Zdec.

    left; split; rewrite e; rewrite e0; rewrite e1; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
    right; left; intro; inversion H; auto.
Defined.

Fixpoint extract {A B : type} (expr : term B) (val : term A) : term (A-->B).
Proof.
  pose (ab_dec := eq_term_dec expr val).
  destruct ab_dec.

  (* expr is equal to val *)
  apply fst in p; rewrite p; apply I.

  (* expr is not equal to val *)
  inversion expr as [n X | X Y f x | X | X Y | Z X Y].

  (* expr is just a constant, i.e. expr = var n X *)
  apply (K[expr]).

  (* expr is a function evaluation, i.e. expr = f[x]*)
  apply (S[extract _ _ f val][extract _ _ x val]).

  (* expr is identity, i.e. expr = I *)
  rewrite H; apply (K[expr]).

  (* expr is constant function, i.e. expr = K *)
  rewrite H; apply (K[expr]).

  (* expr is constant function, i.e. expr = S *)
  rewrite H; apply (K[expr]).
Defined.

Notation X := (base_type 0).
Notation Y := (base_type 1).

Notation x := (var 0 X).
Notation y := (var 0 Y).
Notation f := (var 0 (X --> Y --> X)).

Compute extract (f[x]) x.    (* => S [K [f]] [I] *)
Compute extract (f[x][y]) x. (* => S [S [K [f]] [I]] [K [y]] *)