Sunday 12 October 2008

Implementing tactics in Coq


Require Import List.

Section propr.
Variable Sym : Set.
Variable lookup : Sym -> Prop.
Variable eq_Sym_dec : forall s s' : Sym, {s = s'} + {s <> s'}.

Inductive prop : Set :=
| var : Sym -> prop
| imp : prop -> prop -> prop.

Fixpoint interpret (p : prop) : Prop :=
match p with
| var i => lookup i
| imp p q => interpret p -> interpret q
end.

Fixpoint assume (context : list Sym) :=
match context with
| nil => True
| i :: is => lookup i /\ assume is
end.

Fixpoint contextLookup (i : Sym) (context : list Sym) :=
match context as context' return option (assume context' -> interpret (var i)) with
| nil => None
| j::js =>
match eq_Sym_dec i j with
| left eql =>
match eql with
| refl_equal =>
Some (fun hypotheses =>
match hypotheses with
| conj J _ => J
end)
end
| right _ =>
match contextLookup i js with
| Some Prf =>
Some (fun hypotheses =>
match hypotheses with
| conj _ Js => Prf Js
end)
| None => None
end
end
end.

Fixpoint proveable' (p : prop) (context : list Sym) : option (assume context -> interpret p) :=
match p as p' return option (assume context -> interpret p') with
| var i => contextLookup i context
| imp (var i) q =>
match proveable' q (i :: context) with
| Some Hypo'X => Some (fun Hyp o => Hypo'X (conj o Hyp))
| None => None
end
| imp _ x => None
end.

Definition some X (x : option X) :=
match x with
| Some _ => True
| None => False
end.
Implicit Arguments some [X].

Theorem proveable'_proveable p : some (proveable' p nil) -> interpret p.
intro p; destruct (proveable' p nil); [ exact i | simpl; tauto ].
Qed.

End propr.


Require Import Arith.

Theorem test (X Y Z W : Prop) : X -> Y -> Z -> X -> Y -> Z.
intros X Y Z W.
exact
(proveable'_proveable
nat
(fun i =>
match i with
| 0 => X
| 1 => Y
| 2 => Z
| 3 => W
| _ => False
end)
eq_nat_dec
(imp _ (var _ 0)
(imp _ (var _ 1)
(imp _ (var _ 2)
(imp _ (var _ 0)
(imp _ (var _ 1) (var _ 2))))))
I).
Qed.

Print test.
(**************

test =
fun X Y Z W : Prop =>
proveable'_proveable nat
(fun i : nat =>
match i with
| 0 => X
| 1 => Y
| 2 => Z
| 3 => W
| S (S (S (S _))) => False
end) eq_nat_dec
(imp nat (var nat 0)
(imp nat (var nat 1)
(imp nat (var nat 2)
(imp nat (var nat 0) (imp nat (var nat 1) (var nat 2)))))) I
: forall X Y Z : Prop, Prop -> X -> Y -> Z -> X -> Y -> Z

**************
*)

No comments: