X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=248c02fa50facd4ee613d89dd9e392e7bb5af269;hb=a90c31c1b53222bd6d57360c5ba5c2d0fe7d5207;hp=ca02263b01e6de6aceeff38012aa5e98be2e573a;hpb=4377e950998c9c63937582952a79975947aa9a45;p=helm.git diff --git a/helm/software/components/grafite_engine/grafiteEngine.ml b/helm/software/components/grafite_engine/grafiteEngine.ml index ca02263b0..248c02fa5 100644 --- a/helm/software/components/grafite_engine/grafiteEngine.ml +++ b/helm/software/components/grafite_engine/grafiteEngine.ml @@ -530,15 +530,17 @@ let record_index_obj = end ;; -let compute_keys status uri height kind = - let mk_item ty spec = - let orig_ty = NTacStatus.mk_cic_term [] ty in - let status,keys = NnAuto.keys_of_type status orig_ty in - let keys = - List.map - (fun t -> - snd (NTacStatus.term_of_cic_term status t (NTacStatus.ctx_of t))) - keys +let index_obj_for_auto status (uri, height, _, _, kind) = + let mk_item orig_ty spec = + let ty,_,_ = NCicMetaSubst.saturate ~delta:max_int [] [] [] orig_ty 0 in + let keys = + match ty with + | NCic.Const (NReference.Ref (_,NReference.Def h)) + | NCic.Appl (NCic.Const (NReference.Ref (_,NReference.Def h))::_) + when h > 0 -> + let ty',_,_= NCicMetaSubst.saturate ~delta:(h-1) [] [] [] orig_ty 0 in + [ty;ty'] + | _ -> [ty] in keys,NCic.Const(NReference.reference_of_spec uri spec) in @@ -562,7 +564,7 @@ let compute_keys status uri height kind = | NCic.Constant (_,_,None, ty, _) -> [ mk_item ty NReference.Decl ] in - HExtlib.filter_map + let data = HExtlib.filter_map (fun (keys, t) -> let keys = List.filter (function @@ -585,48 +587,14 @@ let compute_keys status uri height kind = NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t); None end) - data -;; - -let index_obj_for_auto status (uri, height, _, _, kind) = - (*prerr_endline (string_of_int height);*) - let data = compute_keys status uri height kind in - let status = basic_index_obj data status in - let dump = record_index_obj data :: status#dump in - status#set_dump dump -;; - -let index_eq uri status = - let eq_status = status#eq_cache in - let eq_status1 = NCicParamod.index_obj eq_status uri in - status#set_eq_cache eq_status1 -;; - -let record_index_eq = - let basic_index_eq uri - ~refresh_uri_in_universe - ~refresh_uri_in_term - = index_eq (NCicLibrary.refresh_uri uri) + data in - NCicLibrary.Serializer.register#run "index_eq" - object(_ : 'a NCicLibrary.register_type) - method run = basic_index_eq - end -;; - -let index_eq_for_auto status uri = - if NnAuto.is_a_fact_obj status uri then - let newstatus = index_eq uri status in - if newstatus#eq_cache == status#eq_cache then status - else - ((*prerr_endline ("recording " ^ (NUri.string_of_uri uri));*) - let dump = record_index_eq uri :: newstatus#dump - in newstatus#set_dump dump) - else - ((*prerr_endline "Not a fact";*) - status) + let status = basic_index_obj data status in + let dump = record_index_obj data :: status#dump in + status#set_dump dump ;; + let basic_eval_add_constraint (u1,u2) status = NCicLibrary.add_constraint status u1 u2 ;; @@ -753,7 +721,7 @@ let eval_ng_punct (_text, _prefix_len, punct) = match punct with | GrafiteAst.Dot _ -> NTactics.dot_tac | GrafiteAst.Semicolon _ -> fun x -> x - | GrafiteAst.Branch _ -> NTactics.branch_tac ~force:false + | GrafiteAst.Branch _ -> NTactics.branch_tac | GrafiteAst.Shift _ -> NTactics.shift_tac | GrafiteAst.Pos (_,l) -> NTactics.pos_tac l | GrafiteAst.Wildcard _ -> NTactics.wildcard_tac @@ -764,8 +732,6 @@ let eval_ng_tac tac = let rec aux f (text, prefix_len, tac) = match tac with | GrafiteAst.NApply (_loc, t) -> NTactics.apply_tac (text,prefix_len,t) - | GrafiteAst.NSmartApply (_loc, t) -> - NnAuto.smart_apply_tac (text,prefix_len,t) | GrafiteAst.NAssert (_loc, seqs) -> NTactics.assert_tac ((List.map @@ -777,12 +743,10 @@ let eval_ng_tac tac = ) hyps, (text,prefix_len,concl)) ) seqs) - | GrafiteAst.NAuto (_loc, (None,a)) -> - NAuto.auto_tac ~params:(None,a) ?trace_ref:None - | GrafiteAst.NAuto (_loc, (Some l,a)) -> + | GrafiteAst.NAuto (_loc, (l,a)) -> NAuto.auto_tac - ~params:(Some List.map (fun x -> "",0,x) l,a) ?trace_ref:None - | GrafiteAst.NBranch _ -> NTactics.branch_tac ~force:false + ~params:(List.map (fun x -> "",0,x) l,a) + | GrafiteAst.NBranch _ -> NTactics.branch_tac | GrafiteAst.NCases (_loc, what, where) -> NTactics.cases_tac ~what:(text,prefix_len,what) @@ -797,7 +761,7 @@ let eval_ng_tac tac = | GrafiteAst.NCut (_loc, t) -> NTactics.cut_tac (text,prefix_len,t) (*| GrafiteAst.NDiscriminate (_,what) -> NDestructTac.discriminate_tac ~what:(text,prefix_len,what) | GrafiteAst.NSubst (_,what) -> NDestructTac.subst_tac ~what:(text,prefix_len,what)*) - | GrafiteAst.NDestruct (_,dom,skip) -> NDestructTac.destruct_tac dom skip + | GrafiteAst.NDestruct _ -> NDestructTac.destruct_tac | GrafiteAst.NDot _ -> NTactics.dot_tac | GrafiteAst.NElim (_loc, what, where) -> NTactics.elim_tac @@ -808,11 +772,6 @@ let eval_ng_tac tac = NTactics.generalize_tac ~where:(text,prefix_len,where) | GrafiteAst.NId _ -> (fun x -> x) | GrafiteAst.NIntro (_loc,n) -> NTactics.intro_tac n - | GrafiteAst.NIntros (_loc,ns) -> NTactics.intros_tac ns - | GrafiteAst.NInversion (_loc, what, where) -> - NTactics.inversion_tac - ~what:(text,prefix_len,what) - ~where:(text,prefix_len,where) | GrafiteAst.NLApply (_loc, t) -> NTactics.lapply_tac (text,prefix_len,t) | GrafiteAst.NLetIn (_loc,where,what,name) -> NTactics.letin_tac ~where:(text,prefix_len,where) @@ -831,7 +790,7 @@ let eval_ng_tac tac = | GrafiteAst.NUnfocus _ -> NTactics.unfocus_tac | GrafiteAst.NWildcard _ -> NTactics.wildcard_tac | GrafiteAst.NTry (_,tac) -> NTactics.try_tac - (f f (text, prefix_len, tac)) + (aux f (text, prefix_len, tac)) | GrafiteAst.NAssumption _ -> NTactics.assumption_tac | GrafiteAst.NBlock (_,l) -> NTactics.block_tac (List.map (fun x -> aux f (text,prefix_len,x)) l) @@ -888,27 +847,9 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = | _ -> obj_kind in let obj = uri,height,[],[],obj_kind in - (*prerr_endline ("pp new obj \n"^NCicPp.ppobj obj);*) let old_status = status in let status = NCicLibrary.add_obj status obj in - let index_obj = - match obj_kind with - NCic.Constant (_,_,_,_,(_,`Example,_)) - | NCic.Fixpoint (_,_,(_,`Example,_)) -> false - | _ -> true - in - let status = - if index_obj then - let status = index_obj_for_auto status obj in - (try index_eq_for_auto status uri - with _ -> status) - else - status in -(* - try - index_eq uri status - with _ -> prerr_endline "got an exception"; status - in *) + let status = index_obj_for_auto status obj in (* prerr_endline (NCicPp.ppobj obj); *) HLog.message ("New object: " ^ NUri.string_of_uri uri); (try @@ -937,36 +878,35 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = in if nstatus#ng_mode <> `CommandMode then begin - (*HLog.warn "error in generating projection/eliminator";*) - status, uris + HLog.error "error in generating projection/eliminator"; + prerr_endline (NCicPp.ppobj nstatus#obj); + nstatus, uris end else nstatus, concat_nuris uris nuris with - | MultiPassDisambiguator.DisambiguationError _ + | MultiPassDisambiguator.DisambiguationError _ | NCicTypeChecker.TypeCheckerFailure _ -> - (*HLog.warn "error in generating projection/eliminator";*) + HLog.warn "error in generating projection/eliminator"; status,uris ) (status,`New [] (* uris *)) boxml in let _,_,_,_,nobj = obj in let status = match nobj with - NCic.Inductive (is_ind,leftno,[it],_) -> + NCic.Inductive (true,leftno,[it],_) -> let _,ind_name,ty,cl = it in List.fold_left (fun status outsort -> let status = status#set_ng_mode `ProofMode in try - (let status,invobj = - NInversion.mk_inverter - (ind_name ^ "_inv_" ^ - (snd (NCicElim.ast_of_sort outsort))) - is_ind it leftno outsort status status#baseuri in + (let status,invobj = NInversion.mk_inverter + (ind_name ^ "_inv_" ^ (snd (NCicElim.ast_of_sort outsort))) + it leftno outsort status status#baseuri in let _,_,menv,_,_ = invobj in fst (match menv with [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) | _ -> status,`New [])) (* XXX *) - with _ -> (*HLog.warn "error in generating inversion principle"; *) + with _ -> HLog.warn "error in generating inversion principle"; let status = status#set_ng_mode `CommandMode in status) status (NCic.Prop:: @@ -1097,7 +1037,7 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = indtyno, NCicEnvironment.get_checked_indtys r | _ -> prerr_endline ("engine: indty =" ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] indty) ; assert false in let it = List.nth tys indtyno in - let status,obj = NInversion.mk_inverter name true it leftno ?selection sort + let status,obj = NInversion.mk_inverter name it leftno ?selection sort status status#baseuri in let _,_,menv,_,_ = obj in (match menv with