From Undecidability.L Require Export Tactics.Computable.
(* ** Time bounds *)
Fixpoint timeComplexity t (tt: TT t) : Type :=
match tt with
! _ => unit
| @TyArr t1 t2 tt1 tt2 => t1 -> timeComplexity tt1 -> (nat*timeComplexity tt2)
end.
Arguments timeComplexity : clear implicits.
Arguments timeComplexity _ {_}.
Fixpoint computesTime {t} (ty : TT t) :  forall (x:t) (xInt :term) (xTime :timeComplexity t), Type :=
match ty with
!_ => fun x xInt _=> xInt = enc x
| @TyArr t1 t2 tt1 tt2 =>
fun f fInt fTime =>
proc fInt *
forall (y : t1) yInt (yTime:timeComplexity t1),
computesTime y yInt yTime
-> let fyTime := fTime y yTime in
{v : term & (redLe (fst fyTime) (app fInt yInt) v) * computesTime (f y) v (snd fyTime)}
end%type.
Arguments computesTime {_} _ _ _ _.
Class computableTime {X : Type} (ty : TT X) (x : X) evalTime: Type :=
{
extT : extracted x;
extTCorrect : computesTime ty x extT evalTime
}.
Global Arguments computableTime {X} {ty} x.
Global Arguments extT {X} {ty} x {_ computableTime} : simpl never.
Global Arguments extTCorrect {X} ty x {_ computableTime} : simpl never.
Definition evalTime X ty x evalTime (computableTime : @computableTime X ty x evalTime):=evalTime.
Global Arguments evalTime {X} {ty} x {evalTime computableTime}.
Hint Extern 3 (@extracted ?t ?f) => let ty := constr:(_ : TT t) in notypeclasses refine (extT (ty:=ty) f) : typeclass_instances.
Hint Mode computableTime + - + -: typeclass_instances. (* treat argument as input and force evar-freeness*)
(* A Notation to allow inference of the TT parameter for function types. Coq checks that functions only appear at positions where functions are allowed before it inferes holes, so t complains that f "is a product while it is expected to be '@timeComplexity (forall _ : _, _) ?ty'". *)
Notation "'computableTime'' f" := (@computableTime _ ltac:(let t:=type of f in refine (_ : TT t);exact _) f) (at level 0,only parsing).
(* TODO in 8.11: use bidirectional hints Arguments computableTime _ _ _ & _. *)
Local Fixpoint notHigherOrder t (ty : TT t) :=
match ty with
TyArr _ _ (TyB _ _) ty2 => notHigherOrder ty2
| TyB _ _ => True
| _ => False
end.
Local Lemma computesTime_computes_intern s t (ty: TT t) f evalTime:
notHigherOrder ty -> computesTime ty f s evalTime -> computes ty f s.
Instance reg_is_extT ty (R : registered ty) (x : ty): computableTime x tt.
Instance extTApp' t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) fT xT (Hf : computableTime f fT) (Hx : computableTime x xT) : computableTime (f x) (snd (fT x xT)).

Lemma extT_is_enc t1 (R:registered t1) (x: t1) xT (Hf : computableTime x xT) :
@extT _ _ x xT Hf = enc x.