From Undecidability.L Require Export Util.L_facts Tactics.Extract.
(* * Correctness and time bounds *)
(* Typeclass for registering types *)
Class registered (X : Type) := mk_registered
{
enc :> encodable X ; (* the encoding function for X *)
proc_enc : forall x, proc (enc x) ; (* encodings need to be a procedure *)
inj_enc : injective enc (* encoding is injective *)
}.
Hint Mode registered + : typeclass_instances. (* treat argument as input and force evar-freeness*)
Arguments enc : simpl never.  (* Never unfold with cbn/simpl *)
(* ** Correctness *)
(* Definition of the valid types for extraction *)
Inductive TT : Type -> Type :=
TyB t (R : registered t) : TT t
| TyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2)
: TT (t1 -> t2).
Existing Class TT.
Existing Instance TyB.
Existing Instance TyArr.
Arguments TyB _ {_}.
Arguments TyArr {_} {_} _ _.
Hint Mode TT + : typeclass_instances. (* treat argument as input and force evar-freeness*)
Notation "! X" := (TyB X) (at level 69).
Notation "X ~> Y" := (TyArr X Y) (right associativity, at level 70).
Fixpoint computes {A} (tau : TT A) {struct tau}: A -> L.term -> Type :=
match tau with
!_ => fun x xInt => (xInt = enc x)
| @TyArr A B tau1 tau2 =>
fun f t_f  =>
proc t_f * forall (a : A) t_a,
computes tau1 a t_a
->  {v : term & (app t_f t_a >* v) * computes tau2 (f a) v}
end%type.
(* This is for a user to give an definition *)
Class computable X {ty : TT X} (x : X) : Type :=
{
ext : extracted x;
extCorrect : computes ty x ext;
}.
Global Arguments computable {X} {ty} x.
Global Arguments extCorrect {X} ty x {computable} : simpl never.
Global Arguments ext {X} {ty} x {computable} : simpl never.
Hint Mode computable + - +: typeclass_instances. (* treat argument as input and force evar-freeness*)
Hint Extern 4 (@extracted ?t ?f) => let ty := constr:(_ : TT t) in notypeclasses refine (ext (ty:=ty) f) : typeclass_instances.
Typeclasses Opaque ext.
Instance reg_is_ext ty (R : registered ty) (x : ty) : computable x.
Instance extApp' t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) : computable (f x).

Lemma computesTyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2) f fExt :
proc fExt
-> (forall (y : t1) (yExt : term),
computes tt1 y yExt
-> {v : term & eval (app fExt yExt) v * (proc v -> computes tt2 (f y) v)}%type)
-> computes (tt1 ~> tt2) f fExt.