Math Coq中可计算性理论的形式化

我试图通过形式化一个我熟悉的数学定理来自学Coq：停止问题的不可判定性可计算性理论中的各种定理

由于我对计算模型的细节形式化不感兴趣（例如，图灵机、注册机、lambda计算器等），因此我试图通过“教授Coq Church Turing论文”来实现这一点，即，假设

Axiom

s表示Coq认为可计算的函数的状态属性（即，

nat->nat

类型的可定义函数）

例如，若我想告诉Coq，有一个有效的部分可计算函数枚举，我可以说

Definition partial := nat -> nat -> option nat.
Axiom Phi : nat -> partial.

在这里，部分可计算函数被认为是（总计）可计算函数，给定第一个参数

s

，模拟

s

许多步骤的原始部分可计算函数的计算。我还可以添加其他

公理

s，如填充引理，我可能能够证明停止问题的不可判定性，以及可计算性中的其他一些定理奥里

我的第一个问题是，到目前为止，我是否在正确的轨道上。对于不完全现象或Coq类型系统的性质，我试图做的事情显然是不可能的，不是吗

我的第二个问题是关于相对论的。如果我试图证明可计算性理论中更严肃的东西，我想在神谕中考虑计算。因为通常情况下，神谕被构造成部分二值函数的极限，看起来（至少是天真的）。很自然地，使oracle具有类型

nat->bool

。同时，为了使oracle不平凡，它们必须是不可计算的。考虑到这一点，具有类型

nat->bool

的oracle有意义吗

关于oracle还有一个问题：如果每个oracle都有与特定oracle相关的部分可计算函数的类型，那就太好了。我可以通过利用Coq中的依赖类型系统来做到这一点吗？这种可能性是否取决于上面段落中讨论的一些形式化oracle的选择

编辑：上述方法肯定不能按原样工作，因为我需要一个额外的公理：

Axiom Phi_inverse: partial -> nat.

对于预言家来说，这应该是正确的。有没有像我上面描述的那样的方法（我的意思是，不涉及计算模型的形式化）呢

编辑：为了澄清我的意图，我编辑了上面的问题陈述。此外，为了展示我心目中的形式化风格，我在这里提供了一个不完整的证明，证明停止问题无法解决：

Require Import Arith.
Require Import Classical.
Definition ext_eq (A B : Set) (f g : A -> B) := forall (x : A), f x = g x.
Definition partial := nat -> nat -> option nat.
Axiom Phi : nat -> partial.
Axiom Phi_inverse : partial -> nat.
Axiom effective_enumeration :
  forall (f : partial) (e : nat),
    Phi e = f <-> Phi_inverse f = e.
Axiom modulus : partial -> nat -> nat.
Axiom persistence :
  forall (f : partial) n s,
    s >= modulus f n -> f s n = f (modulus f n) n.
Definition limit (f : partial) n := f (modulus f n) n.
Definition total (f : partial)
  := forall n, exists s, exists m, f s n = Some m.
Definition flip n := match n with O => 1 | S _ => 0 end.
Definition K e := exists n, limit (Phi e) e = Some n.
Theorem K_is_undecidable :
  ~ exists e,
      total (Phi e)
      /\ forall e', limit (Phi e) e' = Some 0 <-> ~K e'. 
Proof.
  intro.
  destruct H as [e].
  destruct H.
  pose proof (H0 (Phi_inverse (fun s e' =>
                                match (Phi e s e') with
                                  | Some n => Some (flip n)
                                  | None => None end))).
(* to be continued *)

需要导入算术。
需要进口古典音乐。
定义ext_eq（ab:Set）（fg:A->B）：=forall（x:A），fx=gx。
部分定义：=nat->nat->option nat。
公理Phi:nat->partial。
公理Phi_逆：部分->nat。
Axiom有效枚举：
forall（f:partial）（e:nat），
φe=fφu逆f=e。
公理模数：部分->nat->nat。
Axiom持久性：
对于所有（f:partial）n s，
s>=模数Fn->Fsn=f（模数Fn）n。
定义极限（f：部分）n:=f（模数fn）n。
定义总计（f:部分）
：=对于所有n，存在s，存在m，f s n=一些m。
定义翻转n:=用O=>1 | S=>0结束匹配n。
定义ke:=存在n，极限（φe）e=一些n。
定理K_是不可判定的：
~e，
总计（菲律宾）
/\对于所有e'，极限（φe）e'=一些0~K e'。
证明。
简介。
将H分解为[e]。
破坏H。
姿势证明（H0（Phi_）逆（fun s e'=>
与（φe）匹配
|Some n=>Some（翻转n）
|None=>None end）））。
（*待续*）

以下是如何介绍一个有意义的公理（我自己还在学习Coq，希望如果我做错了，有人会纠正我）

使用

参数

我们规定了一个名为

计算

的函数的存在性，但没有给出定义。使用

公理

我们修复了它的一些属性（希望没有引入矛盾）。据称，参数和公理在内部做同样的事情

与

compute

的声明类似，您的公理Phi规定了函数Phi从

nat

到

partial

的存在性，但是在

Coq

中您还不能对它做任何事情，因为它没有已知的属性。请注意，Phi的存在并不意味着类似的任何事情“存在部分可计算函数的有效枚举”

这里的公理表明，当使用更多允许的计算步骤调用时，

compute

不会将接受更改为拒绝，反之亦然，也不会备份到NOTYET。通过这些定义，我检查了是否有可能证明微不足道的引理

test

作为起点

显然，我并没有进行这项研究，看看你是否能证明停止问题的不可判定性，但通过添加一个公理，断言存在一个

nat

，表示一个程序，该程序的计算相当于证明停止问题所需的构造，这应该是可能的。当然，主要是整个要点这样做会失去很多证据，但还有一点需要证明

Inductive result :=
| ACCEPT : result
| REJECT : result
| NOTYET : result.

Definition narrowing a b : Prop :=
(match a with
| ACCEPT => b = ACCEPT
| REJECT => b = REJECT
| NOTYET => True
end).

Parameter compute : nat (* program *) -> nat (* argument *) -> nat (* steps *) -> result.

Axiom compute_narrowing:
forall program input steps steps',
(steps' >= steps) ->
(narrowing (compute program input steps) (compute program input steps')).

Lemma test: ~ exists program input steps, (compute program input steps) = ACCEPT /\ (compute program input (steps + 1)) = NOTYET

编辑：这里还有一点。在仔细考虑了这个问题之后，我意识到这样的证明必然会将有趣的结构公理化，这是完全错误的。可以插入只允许简单低级结构的公理，然后在其上构建高级结构。我假设目标是w Minsky的证明，因为形式化似乎更简单：

这里，附加的公理断言1）程序的存在

Require Import List.
Require Import Arith.
Require Import Omega.

Ltac mp_cancel :=
  repeat match goal with
  | [ H2 : ?P -> ?Q , H1 : ?P |- _ ] => specialize (H2 H1)
  end.

Ltac mp_cancel_reflexivity :=
  repeat match goal with
  | [ H1 : ?P = ?P -> ?Q |- _ ] => assert (H_mp_cancel_reflexivity : P = P) by reflexivity; specialize (H1 H_mp_cancel_reflexivity); clear H_mp_cancel_reflexivity
  end.

Inductive result :=
| ACCEPT : result
| REJECT : result
| NOTYET : result
.

Definition narrowing a b : Prop :=
  (match a with
  | ACCEPT => b = ACCEPT
  | REJECT => b = REJECT
  | NOTYET => True
  end)
.

Parameter encode_pair : (nat * nat) -> nat.
Parameter decode_pair : nat -> (nat * nat).

Axiom codec:
  forall a b,
  (decode_pair (encode_pair (a, b))) = (a, b).

Parameter compute : nat (* program *) -> nat (* input *) -> nat (* steps *) -> result.

Axiom compute_narrowing:
  forall program input steps steps',
  (steps' >= steps) -> (narrowing (compute program input steps) (compute program input steps')).

Axiom exists_always_accept:
  exists program_always_accept,
  forall input,
  exists steps,
  (compute program_always_accept input steps) = ACCEPT.

Axiom exists_always_reject:
  exists program_always_reject,
  forall input,
  exists steps,
  (compute program_always_reject input steps) = REJECT.

Definition result_compose_conditional (result_conditional : result) (result_when_accept : result) (result_when_reject : result) : result :=
  (match result_conditional with
  | ACCEPT => result_when_accept
  | REJECT => result_when_reject
  | NOTYET => NOTYET
  end).

Axiom exists_compose_conditional:
  forall program_conditional program_when_accept program_when_reject,
  exists program_composition,
  forall input steps_control steps_when result_conditional result_when_accept result_when_reject,
  (
    ((compute program_conditional input steps_control) = result_conditional) ->
    ((compute program_when_accept input steps_when) = result_when_accept) ->
    ((compute program_when_reject input steps_when) = result_when_reject) ->
    (exists steps_composition, (compute program_composition input steps_composition) = (result_compose_conditional result_conditional result_when_accept result_when_reject))
  ).

Definition result_negation (result_target : result) : result :=
  (match result_target with
  | ACCEPT => REJECT
  | REJECT => ACCEPT
  | NOTYET => NOTYET
  end).

Lemma exists_negation:
  forall program_target,
  exists program_negation,
  forall input steps_target result_target,
  (
    ((compute program_target input steps_target) = result_target) ->
    (exists steps_negation, (compute program_negation input steps_negation) = (result_negation result_target))
  ).
intros.
elim exists_always_accept; intros program_always_accept H_always_accept.
elim exists_always_reject; intros program_always_reject H_always_reject.
elim exists_compose_conditional with (program_conditional := program_target) (program_when_accept := program_always_reject) (program_when_reject := program_always_accept); intros program_negation H_program_negation.
exists program_negation.
intros.
specialize H_always_accept with input. elim H_always_accept; clear H_always_accept; intros steps_accept H_always_accept.
specialize H_always_reject with input. elim H_always_reject; clear H_always_reject; intros steps_reject H_always_reject.
pose (steps_when := (steps_accept + steps_reject)).
specialize H_program_negation with input steps_target steps_when result_target (compute program_always_reject input steps_when) (compute program_always_accept input steps_when).
mp_cancel.
mp_cancel_reflexivity.
elim H_program_negation; clear H_program_negation; intros steps_negation H_program_negation.
exists (steps_negation).
rewrite H_program_negation; clear H_program_negation.
replace (compute program_always_reject input steps_when) with REJECT; symmetry.
replace (compute program_always_accept input steps_when) with ACCEPT; symmetry.
unfold result_compose_conditional.
unfold result_negation.
reflexivity.
assert (T := (compute_narrowing program_always_accept input steps_accept steps_when)).
assert (steps_when >= steps_accept).
unfold steps_when.
omega.
mp_cancel.
unfold narrowing in T.
rewrite H_always_accept in T.
assumption.
assert (T := (compute_narrowing program_always_reject input steps_reject steps_when)).
assert (steps_when >= steps_reject).
unfold steps_when.
omega.
mp_cancel.
unfold narrowing in T.
rewrite H_always_reject in T.
assumption.
Qed.

Require Import List.
Require Import Arith.
Require Import Omega.

Ltac mp_cancel :=
  repeat match goal with
  | [ H2 : ?P -> ?Q , H1 : ?P |- _ ] => specialize (H2 H1)
  end.

Ltac mp_cancel_reflexivity :=
  repeat match goal with
  | [ H1 : ?P = ?P -> ?Q |- _ ] => assert (H_mp_cancel_reflexivity : P = P) by reflexivity; specialize (H1 H_mp_cancel_reflexivity); clear H_mp_cancel_reflexivity
  end.

Parameter encode_pair: (nat * nat) -> nat.
Parameter decode_pair: nat -> (nat * nat).

Axiom decode_encode: forall a b, (decode_pair (encode_pair (a, b))) = (a, b).

Inductive result :=
| ACCEPT : result
| REJECT : result
| NOTYET : result.

Definition result_narrowing (a : result) (b : result) : Prop :=
  (match a with
  | ACCEPT => b = ACCEPT
  | REJECT => b = REJECT
  | NOTYET => True
  end).

Lemma result_narrowing_trans: forall a b c, result_narrowing a b -> result_narrowing b c -> result_narrowing a c.
intros until 0.
destruct a; destruct b; destruct c;
  unfold result_narrowing;
  intros;
  try discriminate;
  reflexivity.
Qed.

Parameter compute: nat (* program *) -> nat (* input *) -> nat (* steps *) -> result.

Axiom compute_narrowing:
  forall program input steps steps',
  (steps' >= steps) -> (result_narrowing (compute program input steps) (compute program input steps')).

Require Import Classical.

Lemma compute_non_divergent:
  forall program input steps steps',
  (compute program input steps) = ACCEPT ->
  (compute program input steps') = REJECT ->
  False.
intros.
assert (T := (classic (steps' >= steps))).
destruct T.
assert (T := (compute_narrowing program input steps steps')).
mp_cancel.
rewrite H, H0 in T.
unfold result_narrowing in T.
discriminate T.
unfold not in H1.
assert (T := (classic (steps' = steps))).
destruct T.
rewrite H2 in H0.
rewrite H in H0.
discriminate.
assert (steps >= steps').
omega.
assert (T := (compute_narrowing program input steps' steps)).
mp_cancel.
rewrite H, H0 in T.
unfold result_narrowing in T.
discriminate.
Qed.

Definition procedure_type := nat (* input *) -> nat (* depth *) -> result.

Definition procedure_narrowing (procedure : procedure_type) : Prop :=
  forall input depth depth',
  (depth' >= depth) -> (result_narrowing (procedure input depth) (procedure input depth')).

Axiom exists_program_of_procedure:
  forall procedure : procedure_type,
  (procedure_narrowing procedure) ->
  exists program,
  forall input,
  (
    forall depth,
    exists steps,
    (result_narrowing (procedure input depth) (compute program input steps))
  ) /\
  (
    forall steps,
    exists depth,
    (result_narrowing (compute program input steps) (procedure input depth))
  ).

Definition program_halts_on_input (program : nat) (input : nat) : Prop :=
  (exists steps, (compute program input steps) <> NOTYET).

Definition program_is_decider (program : nat) : Prop :=
  forall input,
  exists steps,
  (compute program input steps) <> NOTYET.

Definition program_solves_halting_problem_partially (program : nat) : Prop :=
  forall input,
  forall steps,
  (
       ((compute program input steps) = ACCEPT)
    -> (match (decode_pair input) with | (target_program, target_input) => (  (program_halts_on_input target_program target_input)) end)
  ) /\
  (
       ((compute program input steps) = REJECT)
    -> (match (decode_pair input) with | (target_program, target_input) => (~ (program_halts_on_input target_program target_input)) end)
  ).

Lemma minsky: (~ (exists halts, (program_is_decider halts) /\ (program_solves_halting_problem_partially halts))).
unfold not.
intros H_ph.
elim H_ph; clear H_ph; intros invocation_halts [H_ph_d H_ph_b].
pose
  (procedure_modified := (fun (input : nat) (depth : nat) =>
    (match (compute invocation_halts input depth) with
    | ACCEPT => NOTYET
    | REJECT => REJECT
    | NOTYET => NOTYET
    end))).
pose
  (procedure_wrapper := (fun (input : nat) (depth : nat) =>
    (procedure_modified (encode_pair (input, input)) depth))).
unfold procedure_modified in procedure_wrapper.
clear procedure_modified.
assert (T1 := (exists_program_of_procedure procedure_wrapper)).
assert (T2 : (procedure_narrowing procedure_wrapper)).
{
  clear T1.
  unfold procedure_narrowing, procedure_wrapper.
  intros.
  unfold result_narrowing.
  case_eq (compute invocation_halts (encode_pair (input, input)) depth); try intuition.
  assert (T := (compute_narrowing invocation_halts (encode_pair (input, input)) depth depth')).
  mp_cancel.
  rewrite H0 in T.
  unfold result_narrowing in T.
  rewrite T.
  reflexivity.
}
mp_cancel.
clear T2.
elim T1; clear T1; intros program_wrapper H_pw.
unfold procedure_wrapper in H_pw.
clear procedure_wrapper.
specialize (H_pw program_wrapper).
destruct H_pw as [H_pw_fwd H_pw_rev].
unfold program_is_decider in H_ph_d.
specialize (H_ph_d (encode_pair (program_wrapper, program_wrapper))).
elim H_ph_d; clear H_ph_d; intros steps_inner H_ph_d.
unfold program_solves_halting_problem_partially in H_ph_b.
specialize (H_ph_b (encode_pair (program_wrapper, program_wrapper)) steps_inner).
destruct H_ph_b as [H_ph_b_1 H_ph_b_2].
case_eq (compute invocation_halts (encode_pair (program_wrapper, program_wrapper)) steps_inner).
{
  intros.
  rewrite H in *.
  mp_cancel_reflexivity.
  unfold program_halts_on_input in H_ph_b_1.
  rewrite decode_encode in H_ph_b_1.
  elim H_ph_b_1; clear H_ph_b_1; intros steps_outer H_ph_b_1.
  specialize (H_pw_rev steps_outer).
  case_eq (compute program_wrapper program_wrapper steps_outer).
  {
    intros.
    rewrite H0 in *.
    unfold result_narrowing in H_pw_rev.
    elim H_pw_rev; clear H_pw_rev; intros depth H_pw_rev.
    case_eq (compute invocation_halts (encode_pair (program_wrapper, program_wrapper)) depth); intros Hx; rewrite Hx in *; try discriminate.
  }
  {
    intros.
    rewrite H0 in *.
    unfold result_narrowing in H_pw_rev.
    elim H_pw_rev; clear H_pw_rev; intros depth H_pw_rev.
    case_eq (compute invocation_halts (encode_pair (program_wrapper, program_wrapper)) depth); intros Hx; rewrite Hx in *; try discriminate.
    assert (T := (compute_non_divergent invocation_halts (encode_pair (program_wrapper, program_wrapper)) steps_inner depth)).
    mp_cancel.
    assumption.
  }
  {
    intros.
    intuition.
  }
}
{
  intros.
  rewrite H in *.
  mp_cancel_reflexivity.
  unfold not, program_halts_on_input in H_ph_b_2.
  specialize (H_pw_fwd steps_inner).
  rewrite H in H_pw_fwd.
  unfold result_narrowing in H_pw_fwd.
  elim H_pw_fwd; intros.
  rewrite decode_encode in H_ph_b_2.
  contradict H_ph_b_2.
  exists x.
  unfold not.
  intros.
  rewrite H0 in H1.
  discriminate.
}
{
  intros.
  unfold not in H_ph_d.
  mp_cancel.
  assumption.
}
Qed.

Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool.
Require Import Ssreflect.ssrnat Ssreflect.choice.

Section Halting.

(* [code f c] holds if [f] is representable by some
   Turing machine code [c]. Notice that we don't assume that
   [code] is computable, nor do we assume that all functions 
   [nat -> nat -> option bool] can be represented by some code, 
   which means that we don't rule out the existence of
   non-computable functions. *)
Variable code : (nat -> nat -> option bool) -> nat -> Prop.

(* We assume that we have a [decider] for the halting problem, with
   its specification given by [deciderP]. Specifically, when running
   on a number [m] that represents a pair [(c, n)], where [c] is the
   code for some Turing machine [f] and [n] some input for [f], we
   know that [decider m] will halt at some point, producing [true] iff
   [f] halts on input [n].

   This definition uses a few convenience features from Ssreflect to
   make our lives simpler, namely, the [pickle] function, that
   converts from [nat * nat] to [nat], and the implicit coercion from
   [option] to [bool] ([Some] is mapped to [true], [None] to [false]) *)
Variable decider : nat -> nat -> option bool.
Hypothesis deciderP :
  forall f c, code f c ->
  forall (n : nat),
     (forall s,
        match decider (pickle (c, n)) s with
        | Some true  => exists s', f n s'
        | Some false => forall s', negb (f n s')
        | None => True
        end) /\
     exists s, decider (pickle (c, n)) s.

(* Finally, we define the usual diagonal function, and postulate that
   it is representable by some code [f_code]. *)
Definition f (n : nat) s :=
  match decider (pickle (n, n)) s with
  | Some false => Some false
  | _ => None
  end.
Variable f_code : nat.
Hypothesis f_codeP : code f f_code.

(* The actual proof is straightforward (8 lines long). 
   I'm omitting it to avoid spoiling the fun. *)
Lemma pandora : False.
Proof. (* ... *) Qed.

End Halting.

Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool.
Require Import Ssreflect.ssrnat Ssreflect.choice.

Definition partial := nat -> nat -> option nat.
Axiom Phi : nat -> partial.
Axiom Phi_inverse : partial -> nat.
Axiom effective_enumeration :
  forall (f : partial) (e : nat),
    Phi e = f <-> Phi_inverse f = e.

Lemma pandora : False.
Proof.
pose f n (m : nat) :=
  if Phi n n n is Some p then None
  else Some 0.
pose f_code := Phi_inverse f.
move/effective_enumeration: (erefl f_code) => P.
move: (erefl (f f_code f_code)).
rewrite {1}/f P.
by case: (f _ _).
Qed.

Definition foo (oracle : nat -> bool) (n : nat) : bool :=
  (* some definition ... *).

Definition oracle_spec (oracle : nat -> bool) : Prop :=
  (* some definition ... *).

Lemma fooP oracle :
  oracle_spec oracle ->
  (* some property of [foo oracle]. *)

Require Import List.
Require Import Arith.
Require Import Omega.

Ltac mp_cancel :=
  repeat match goal with
  | [ H2 : ?P -> ?Q , H1 : ?P |- _ ] => specialize (H2 H1)
  end.

Ltac mp_cancel_reflexivity :=
  repeat match goal with
  | [ H1 : ?P = ?P -> ?Q |- _ ] => assert (H_mp_cancel_reflexivity : P = P) by reflexivity; specialize (H1 H_mp_cancel_reflexivity); clear H_mp_cancel_reflexivity
  end.

Parameter encode_pair: (nat * nat) -> nat.
Parameter decode_pair: nat -> (nat * nat).

Axiom decode_encode: forall a b, (decode_pair (encode_pair (a, b))) = (a, b).
Axiom encode_decode: forall x,   (encode_pair (decode_pair x)) = x.

Inductive result :=
| ACCEPT : result
| REJECT : result
| NOTYET : result.

Definition result_narrowing (a : result) (b : result) : Prop :=
  (match a with
  | ACCEPT => b = ACCEPT
  | REJECT => b = REJECT
  | NOTYET => True
  end).

Lemma result_narrowing_trans: forall a b c, result_narrowing a b -> result_narrowing b c -> result_narrowing a c.
intros until 0.
destruct a; destruct b; destruct c;
  unfold result_narrowing;
  intros;
  try discriminate;
  reflexivity.
Qed.

Lemma result_push_accept: forall x, result_narrowing ACCEPT x -> x = ACCEPT.
unfold result_narrowing.
intuition.
Qed.

Lemma result_push_reject: forall x, result_narrowing REJECT x -> x = REJECT.
unfold result_narrowing.
intuition.
Qed.

Parameter compute: nat (* program *) -> nat (* input *) -> nat (* steps *) -> result.

Axiom compute_narrowing:
  forall program input steps steps',
  (steps' >= steps) -> (result_narrowing (compute program input steps) (compute program input steps')).

Require Import Classical.

Lemma compute_non_divergent:
  forall program input steps steps',
  (compute program input steps) = ACCEPT ->
  (compute program input steps') = REJECT ->
  False.
intros.
assert (T := (classic (steps' >= steps))).
destruct T.
assert (T := (compute_narrowing program input steps steps')).
mp_cancel.
rewrite H, H0 in T.
unfold result_narrowing in T.
discriminate T.
unfold not in H1.
assert (T := (classic (steps' = steps))).
destruct T.
rewrite H2 in H0.
rewrite H in H0.
discriminate.
assert (steps >= steps').
omega.
assert (T := (compute_narrowing program input steps' steps)).
mp_cancel.
rewrite H, H0 in T.
unfold result_narrowing in T.
discriminate.
Qed.

Definition procedure_type := nat (* input *) -> nat (* depth *) -> result.

Definition procedure_narrowing (procedure : procedure_type) : Prop :=
  forall input depth depth',
  (depth' >= depth) -> (result_narrowing (procedure input depth) (procedure input depth')).

Parameter program_of_procedure: procedure_type (* procedure *) -> nat (* program *).

Axiom program_of_procedure_behavior:
  forall procedure : procedure_type,
  (procedure_narrowing procedure) ->
  forall input,
  (
    forall depth,
    exists steps,
    (result_narrowing (procedure input depth) (compute (program_of_procedure procedure) input steps))
  ) /\
  (
    forall steps,
    exists depth,
    (result_narrowing (compute (program_of_procedure procedure) input steps) (procedure input depth))
  ).

Definition program_halts_on_input (program : nat) (input : nat) : Prop :=
  (exists steps, (compute program input steps) <> NOTYET).

(* orv = oracle verifier *)

Definition orv_type := nat (* query *) -> nat (* wisdom *) -> bool (* advice *).

Definition oracle_accepts (oracle : orv_type) (query : nat) :=
  exists wisdom, (oracle query wisdom) = true.

Definition oracle_rejects (orv : orv_type) (inp : nat) := (~ (oracle_accepts orv inp)).

(* pwo = procedure with oracle *)

Inductive pwo_out :=
| PWO_RESULT : bool (* result *) -> pwo_out
| PWO_ORACLE : nat (* state *) -> nat (* query *) -> pwo_out
.

Definition pwo_type := nat (* input *) -> nat (* state *) -> bool (* advice *) -> pwo_out.

Inductive pwo_entails: orv_type (* oracle *) -> pwo_type (* procedure *) -> nat (* input *) -> nat (* state *) -> bool (* advice *) -> bool (* result *) -> Prop :=
| PwoEntailsResult:
forall oracle procedure input state advice result,
(procedure input state advice) = (PWO_RESULT result) ->
(pwo_entails oracle procedure input state advice result)
| PwoEntailsOracleAccept:
forall oracle procedure input state advice result state' query,
(procedure input state advice) = (PWO_ORACLE state' query) ->
(oracle_accepts oracle query) ->
(pwo_entails oracle procedure input state' true   result) ->
(pwo_entails oracle procedure input state  advice result)
| PwoEntailsOracleReject:
forall oracle procedure input state advice result state' query,
(procedure input state advice) = (PWO_ORACLE state' query) ->
(oracle_rejects oracle query) ->
(pwo_entails oracle procedure input state' false  result) ->
(pwo_entails oracle procedure input state  advice result)
.

Definition pwo_decider_relative (orv : orv_type) (pwo : pwo_type) :=
  forall input,
  (pwo_entails orv pwo input 0 false false) \/
  (pwo_entails orv pwo input 0 false true).

(* define oracle for A_TM (turing machine accepts a particular input) *)

Definition orv_atm (pair_program_input : nat) (wisdom : nat) : bool :=
  (match (decode_pair pair_program_input) with
  | (target_program, target_input) =>
      (match (compute target_program target_input wisdom) with
      | ACCEPT => true
      | _ => false
      end)
  end).

(* define procedure for H_TM (turing machine halts on a particular input) relative to an oracle for A_TM *)

Definition pwo_hfa_construction (target_program : nat) :=
  (fun input depth =>
    (match (compute target_program input depth) with
    | ACCEPT => REJECT
    | REJECT => ACCEPT
    | NOTYET => NOTYET
  end)).

Lemma pwo_hfa_construction_narrowing: forall target_program, (procedure_narrowing (pwo_hfa_construction target_program)).
intros.
unfold procedure_narrowing, result_narrowing, pwo_hfa_construction.
intros.
case_eq (compute target_program input depth); intro; try
(
case_eq (compute target_program input depth'); intro; try reflexivity; try
(
assert (T := (compute_narrowing target_program input depth depth'));
mp_cancel;
unfold result_narrowing in T;
rewrite H0 in T;
rewrite H1 in T;
discriminate
)
).
Qed.

Definition pwo_hfa (input : nat) (state : nat) (advice : bool) : pwo_out :=
  (match (decode_pair input) with
  | (target_program, target_input) =>
      (match state with
      | O =>
        (PWO_ORACLE 1 (encode_pair (target_program, target_input)))
      | (S O) =>
        (if advice
         then (PWO_RESULT true)
         else (PWO_ORACLE 2 (encode_pair ((program_of_procedure (pwo_hfa_construction target_program)), target_input))))
      | _ =>
        (PWO_RESULT advice)
      end)
  end).

Lemma H_from_A:
  exists pwo_hfa,
  (pwo_decider_relative orv_atm pwo_hfa) /\
  (
    forall input,
      (pwo_entails orv_atm pwo_hfa input 0 false true  ->
        (match (decode_pair input) with | (target_program, target_input) => (  (program_halts_on_input target_program target_input)) end)) /\
      (pwo_entails orv_atm pwo_hfa input 0 false false ->
        (match (decode_pair input) with | (target_program, target_input) => (~ (program_halts_on_input target_program target_input)) end))
  )
.
exists pwo_hfa.
split.
{
  unfold pwo_decider_relative.
  intros.
  pose (pair := (decode_pair input)).
  case_eq (pair); intros target_program target_input H_pair.
  replace input with (encode_pair (target_program, target_input)).
  Focus 2.
  {
    rewrite <- H_pair.
    unfold pair.
    apply encode_decode.
  }
  Unfocus.
  assert (T1 := (classic (oracle_accepts orv_atm (encode_pair (target_program, target_input))))).
  destruct T1 as [T1 | T1].
  {
    right.
    eapply PwoEntailsOracleAccept.
    Focus 2.
    eexact T1.
    unfold pwo_hfa.
    rewrite decode_encode.
    instantiate (1 := 1).
    reflexivity.
    apply PwoEntailsResult.
    unfold pwo_hfa.
    rewrite decode_encode.
    reflexivity.
  }
  {
    assert (T2 := (classic (oracle_accepts orv_atm (encode_pair ((program_of_procedure (pwo_hfa_construction target_program)), target_input))))).
    destruct T2 as [T2 | T2].
    {
      right.
      eapply PwoEntailsOracleReject.
      Focus 2.
      unfold oracle_rejects.
      eexact T1.
      unfold pwo_hfa.
      rewrite decode_encode.
      instantiate (1 := 1).
      reflexivity.
      eapply PwoEntailsOracleAccept.
      Focus 2.
      eexact T2.
      unfold pwo_hfa.
      rewrite decode_encode.
      instantiate (1 := 2).
      reflexivity.
      apply PwoEntailsResult.
      unfold pwo_hfa.
      rewrite decode_encode.
      reflexivity.
    }
    {
      left.
      eapply PwoEntailsOracleReject.
      Focus 2.
      unfold oracle_rejects.
      eexact T1.
      unfold pwo_hfa.
      rewrite decode_encode.
      instantiate (1 := 1).
      reflexivity.
      eapply PwoEntailsOracleReject.
      Focus 2.
      eexact T2.
      unfold pwo_hfa.
      rewrite decode_encode.
      instantiate (1 := 2).
      reflexivity.
      apply PwoEntailsResult.
      unfold pwo_hfa.
      rewrite decode_encode.
      reflexivity.
    }
  }
}
{
  intros.
  case_eq (decode_pair input); intros target_program target_input H_input.
  replace input with (encode_pair (target_program, target_input)).
  Focus 2.
  {
    rewrite <- H_input.
    rewrite encode_decode.
    reflexivity.
  }
  Unfocus.
  clear H_input.
  split.
  {
    intros.
    inversion H; subst.
    {
      unfold pwo_hfa in H0.
      rewrite decode_encode in H0.
      discriminate H0.
    }
    {
      unfold pwo_hfa in H0.
      rewrite decode_encode in H0.
      injection H0.
      intros.
      rewrite <- H3 in H1.
      unfold oracle_accepts in H1.
      unfold program_halts_on_input.
      elim H1; intros.
      exists x.
      unfold orv_atm in H5.
      rewrite decode_encode in H5.
      destruct (compute target_program target_input x); try intuition; try discriminate.
    }
    {
      unfold pwo_hfa in H0.
      rewrite decode_encode in H0.
      injection H0.
      intros.
      rewrite <- H4 in *.
      inversion H2; subst.
      {
        unfold pwo_hfa in H5.
        rewrite decode_encode in H5.
        discriminate.
      }
      {
        unfold pwo_hfa in H5.
        rewrite decode_encode in H5.
        injection H5; intros.
        subst.
        unfold oracle_accepts in H6.
        unfold program_halts_on_input.
        elim H6; intros.
        unfold orv_atm in H3.
        rewrite decode_encode in H3.
        case_eq (compute (program_of_procedure (pwo_hfa_construction target_program)) target_input x); intros; rewrite H4 in H3; try discriminate.
        assert
          (T :=
            (program_of_procedure_behavior
              (pwo_hfa_construction target_program)
              (pwo_hfa_construction_narrowing target_program)
              target_input
            )).
        destruct T.
        specialize H9 with x.
        elim H9; intros.
        assert ((pwo_hfa_construction target_program target_input x0) = ACCEPT).
        eapply result_push_accept.
        rewrite <- H4.
        assumption.
        unfold pwo_hfa_construction in H11.
        case_eq (compute target_program target_input x0); intros; rewrite H12 in H11; try discriminate.
        exists x0.
        unfold not.
        intros.
        rewrite H12 in H13.
        discriminate.
      }
      {
        unfold pwo_hfa in H5.
        rewrite decode_encode in H5.
        injection H5; intros.
        subst.
        inversion H7.
        unfold pwo_hfa in H3.
        rewrite decode_encode in H3.
        discriminate H3.
        unfold pwo_hfa in H3.
        rewrite decode_encode in H3.
        discriminate H3.
        unfold pwo_hfa in H3.
        rewrite decode_encode in H3.
        discriminate H3.
      }
    }
  }
  {
    intros.
    unfold not.
    intros.
    inversion H; subst; unfold pwo_hfa in H1; rewrite decode_encode in H1; try discriminate; injection H1; intros; subst.
    {
      inversion H3; subst; unfold pwo_hfa in H4; rewrite decode_encode in H4; try discriminate; injection H4; intros; subst.
    }
    {
      inversion H3; subst; unfold pwo_hfa in H4; rewrite decode_encode in H4; try discriminate; injection H4; intros; subst.
      {
        inversion H6; subst; unfold pwo_hfa in H7; rewrite decode_encode in H7; try discriminate.
      }
      {
        (* oracle rejected both on a program that halts *)
        clear H H3 H1 H6 H4.
        unfold program_halts_on_input in H0.
        elim H0; clear H0; intros.
        unfold not in H.
        case_eq (compute target_program target_input x); intros; try ( solve [ intuition ] ).
        {
          rename H2 into HH.
          unfold oracle_rejects, not in HH.
          apply HH.
          clear HH.
          unfold oracle_accepts.
          exists x.
          unfold orv_atm.
          rewrite decode_encode.
          rewrite H0.
          reflexivity.
        }
        {
          rename H5 into HH.
          unfold oracle_rejects, not in HH.
          apply HH.
          clear HH.
          unfold oracle_accepts.
          assert
          (T :=
            (program_of_procedure_behavior
              (pwo_hfa_construction target_program)
              (pwo_hfa_construction_narrowing target_program)
              target_input
            )).
          destruct T.
          assert ((pwo_hfa_construction target_program target_input x) = ACCEPT).
          unfold pwo_hfa_construction.
          rewrite H0.
          reflexivity.
          specialize H1 with x.
          elim H1; intros.
          rewrite H4 in H5.
          unfold result_narrowing in H5.
          exists x0.
          unfold orv_atm.
          rewrite decode_encode.
          rewrite H5.
          reflexivity.
        }
      }
    }
  }
}
Qed.