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)).
Definition computesTimeIf {t} (ty : TT t) (f:t) (fInt : term) (P:timeComplexity t-> Prop) : Type :=
forall fT, P fT -> computesTime ty f fInt fT.
Arguments computesTimeIf {_} _ _ _ _.
Definition computesTimeExp {t} (ty : TT t) (f:t) (s:term) (i:nat) (fInt : term) (fT:timeComplexity t) : Type :=
evalLe i s fInt * computesTime ty f fInt fT.
Arguments computesTimeExp {_} _ _ _ _ _ _.
intros ? [s ?]. eexists. eauto using computesTimeExt.
Defined.
Fixpoint changeResType_TimeComplexity t1 (tt1 : TT t1) Y {R: registered Y} {struct tt1}:
forall (fT: timeComplexity t1) , @timeComplexity _ (projT2 (changeResType tt1 (TyB Y))):= (
match tt1 with
@TyB t1 tt1 => fun fT => fT
| TyArr _ _ tt11 tt12 => fun fT x xT => (fst (fT x xT),changeResType_TimeComplexity (snd (fT x xT)))
end).

Lemma cast_registeredAs_TimeComplexity t1 (tt1 : TT t1) Y (R: registered Y) fT (cast : projT1 (resType tt1) -> Y) (f:t1)
(Hc : injective cast) :
projT2 (resType tt1) = registerAs cast Hc ->
computableTime (ty:=projT2 (changeResType tt1 (TyB Y))) (insertCast R cast f) (changeResType_TimeComplexity fT)->
computableTime f fT.