Coq 实现SKI转换-证明返回值具有承诺类型_Coq

Coq 实现SKI转换-证明返回值具有承诺类型

coq

Coq 实现SKI转换-证明返回值具有承诺类型,coq,Coq,我正在尝试实现一个函数extract，它将一个类似（f（gxy））的表达式与一个变量（例如y）结合在一起，并使用组合键生成一个函数y-->（f（gxy））。在这种情况下，结果应该是（S（kf）（gx））从某种意义上说，我正在做一个从lambda术语到它的滑雪版本我正试着做一个打字版，但我的日子不好过设置这些表达式中的类型由以下归纳类型表示 Inductive type : Type := | base_type : forall (n : nat), type | arrow_t

我正在尝试实现一个函数

extract

，它将一个类似

（f（gxy））

的表达式与一个变量（例如

）结合在一起，并使用组合键生成一个函数

y-->（f（gxy））

。在这种情况下，结果应该是

（S（kf）（gx））

从某种意义上说，我正在做一个从lambda术语到它的滑雪版本

我正试着做一个打字版，但我的日子不好过

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

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

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

基本上，我有一些用整数索引的基本类型（

base\u type

），我还可以在它们之间创建函数类型（

arrow\u type

）

介绍函数类型的符号

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

表达式由以下归纳类型表示

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

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

是类型为

的表达式
为了减少麻烦，让我们引入函数求值的符号
Notation "f [ x ]" := (eval f x) (at level 25, left associativity).


介绍性示例
原来的问题可以更准确地表述如下
让我们从定义一些类型开始
Notation X := (base_type 0).
Notation Y := (base_type 1).

定义变量xy
和函数fg
（它们都可以用0索引，因为它们都有不同的类型
）
结果表达式的类型为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]]


在类型
和术语
要继续尝试定义提取
，我需要在类型
和术语
上定义相等
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.


尝试实现提取
“实施”相当简单
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.

有两个问题
当返回ia
时：ia
的type
是A-->A
不是承诺的A-->B
，但在这种特殊情况下，我应该能够证明B
和A
是相同的
当返回（sa X Y）[…
：返回值是A-->Y
，而不是A-->B
，但我应该能够再次证明Y
等于B
在这些特殊情况下，我如何证明B=A
和Y=B
函数定义是可以接受的？
你能做的就是将eq_类型
和eq_项
从布尔函数转化为等式的判定过程。目前，据我所知，你的等式完全是语法上的。所以你可以uld仅使用Coq的相等概念来讨论术语和类型的相等。然后，您可以编写：
Definition eq_type_dec (A B : type) : { A = B } + { A <> B }. 

或：
在我省略的分支中可能还有很多工作要做。您可能会看到执行这种依赖类型编程的不同方法，或者像我在这里展示的那样手动执行，或者使用依赖消除策略，或者使用这些类型的递归器

编辑
为了回答您的评论，以下是我知道的编写eq\u term\u dec
的twp方法。其中一种方法是使用Coq的程序扩展，它增加了一个公理，并且能够更有效地处理依赖类型：
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.

需要导入程序.Equality。
不动点方程（A:type）（ab:term A）：{A=b}+{ab}。
从属归纳法a；从属归纳法b；try（右；同余）。
-自毁（peanat.Nat.eq_dec n n 0）；[左|右]；同余。

另一种方法是找出你需要的依赖类型的术语。必须有一种方法使用策略来实现这一点，但我不太确定如何继续，然而，我知道如何编写术语。这不是为胆小的人准备的，我不希望你在熟悉依赖类型的术语之前理解发生了什么模式匹配和“护航模式”。如果您想看看这是什么样子，请看这里：

Fixpoint eq_term_dec (A : type) (a b : term A) : { a = b } + { a <> b }.
  revert b.
  destruct a.
  {
    destruct b; try (right ; congruence).
    destruct (PeanoNat.Nat.eq_dec n n0) ; [ left | right ] ; congruence.
  }
  { destruct b; admit. (* skipping this, it's easy *) }
  {
    (* Here is the complication:                                                  *)
    (* `b` has type `term (A -> A)`                                               *)
    (* If you abstract over its type, the goal is ill-typed, because the equality *)
    (* `I A = b` is at type `A -> A`.                                             *)
    intros b.

    refine (
        (fun (T : type) (ia : term T) (b : term T) =>
           match b
                 as b1
                 in term T1
                 return forall (ia0 : term T1),
                          match T1 as T2 return term T2 -> term T2 -> Type with
                          | arrow_type Foo Bar => fun ia1 b2 => {ia1 = b2} + {ia1 <> b2}
                          | _ => fun _ _ => True
                          end ia0 b1
           with
           | var n a  => fun b => _
           | eval h a => fun b => _
           | I A      => fun b => _
           | K A B    => fun b => _
           | S A B C  => fun b => _
           end ia
        ) (A --> A) (I A) b
      ).

    (* from now on it's easy to proceed *)
    destruct a.
    easy.
    destruct b; try ( right ; congruence ).
    destruct (PeanoNat.Nat.eq_dec n n0) ; [ left | right ] ; congruence.

    (* one more to show it's easy *)
    destruct t0.
    easy.
    destruct b; try ( right ; congruence ).

    (* etc... *)



不动点方程（A:type）（ab:term A）：{A=b}+{ab}。
回复b。
破坏a。
{
析构函数b；try（右；同余）。
自毁（peanat.Nat.eq_dec n n 0）；[左|右]；同余。
}
{析构函数b；承认。（*跳过这个，很容易*）}
{
（*以下是复杂情况：）
（*`b`具有`term（A->A）`*类型）
（*如果对其类型进行抽象，则目标类型错误，因为等式*）
（*`IA=b`位于类型`A->A`.*
介绍b。
精炼(
（乐趣（T:类型）（ia:术语T）（b:术语T）=>
比赛b
as b1
术语T1
所有回报（ia0：期限T1），
将T1匹配为T2返回项T2->T2->键入
|arrow_type Foo Bar=>fun ia1 b2=>{ia1=b2}+{ia1 b2}
|_=>fun=>True
完ia0 b1
具有
|变量n a=>fun b=>_
|评估h a=>乐趣b=>_
|I A=>乐趣b=>_
|kab=>funb=>_
|sabc=>funb=>_
结束ia
)(A)(I A)b
).
（*从现在开始很容易继续*）
破坏a。
容易的。
析构函数b；try（右；同余）。
自毁（peanat.Nat.eq_dec n n 0）；[左|右]；同余。
（*再来一次，说明这很简单*）
破坏t0。
容易的。
析构函数b；try（右；同余）。
（*等…）
我有一个解决方案，虽然不漂亮，但似乎有效。特别是，eq\u term\u dec的证明非常长
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.


Fixpoint eq_term_dec (A : type) (a b : term A) : { a = b } + { a <> b }.
  revert b.
  destruct a.
  {
    destruct b; try (right ; congruence).
    destruct (PeanoNat.Nat.eq_dec n n0) ; [ left | right ] ; congruence.
  }
  { destruct b; admit. (* skipping this, it's easy *) }
  {
    (* Here is the complication:                                                  *)
    (* `b` has type `term (A -> A)`                                               *)
    (* If you abstract over its type, the goal is ill-typed, because the equality *)
    (* `I A = b` is at type `A -> A`.                                             *)
    intros b.

    refine (
        (fun (T : type) (ia : term T) (b : term T) =>
           match b
                 as b1
                 in term T1
                 return forall (ia0 : term T1),
                          match T1 as T2 return term T2 -> term T2 -> Type with
                          | arrow_type Foo Bar => fun ia1 b2 => {ia1 = b2} + {ia1 <> b2}
                          | _ => fun _ _ => True
                          end ia0 b1
           with
           | var n a  => fun b => _
           | eval h a => fun b => _
           | I A      => fun b => _
           | K A B    => fun b => _
           | S A B C  => fun b => _
           end ia
        ) (A --> A) (I A) b
      ).

    (* from now on it's easy to proceed *)
    destruct a.
    easy.
    destruct b; try ( right ; congruence ).
    destruct (PeanoNat.Nat.eq_dec n n0) ; [ left | right ] ; congruence.

    (* one more to show it's easy *)
    destruct t0.
    easy.
    destruct b; try ( right ; congruence ).

    (* etc... *)


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]] *)