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).
(* Extensional equality to extract similar functions without unsopported features (e.g. informative deciders) instead *)
Fixpoint extEq t {tt:TT t} : t -> t -> Prop:=
match tt with
TyB _ _ => eq
| @TyArr t1 t2 tt1 tt2 => fun f f' => forall (x : t1), extEq (f x) (f' x)
end.
Instance extEq_refl t (tt:TT t): Reflexive (extEq (tt:=tt)).

Lemma computesExt X (tt : TT X) (x x' : X) s:
extEq x x' -> computes tt x s -> computes tt x' s.