X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=ca02263b01e6de6aceeff38012aa5e98be2e573a;hb=f9abd21eb0d26cf9b632af4df819225be4d091e3;hp=0806057ec14ab1d67189dba4832028c6509576db;hpb=ddd6560f4e70ec3306d223738a441d5f1dd3eac9;p=helm.git diff --git a/helm/software/components/grafite_engine/grafiteEngine.ml b/helm/software/components/grafite_engine/grafiteEngine.ml index 0806057ec..ca02263b0 100644 --- a/helm/software/components/grafite_engine/grafiteEngine.ml +++ b/helm/software/components/grafite_engine/grafiteEngine.ml @@ -487,7 +487,10 @@ let inject_unification_hint = = let t = refresh_uri_in_term t in basic_eval_unification_hint (t,n) in - NRstatus.Serializer.register "unification_hints" basic_eval_unification_hint + NCicLibrary.Serializer.register#run "unification_hints" + object(_ : 'a NCicLibrary.register_type) + method run = basic_eval_unification_hint + end ;; let eval_unification_hint status t n = @@ -501,6 +504,129 @@ let eval_unification_hint status t n = status,`New [] ;; +let basic_index_obj l status = + status#set_auto_cache + (List.fold_left + (fun t (ks,v) -> + List.fold_left (fun t k -> + NDiscriminationTree.DiscriminationTree.index t k v) + t ks) + status#auto_cache l) +;; + +let record_index_obj = + let aux l + ~refresh_uri_in_universe + ~refresh_uri_in_term + = + basic_index_obj + (List.map + (fun ks,v -> List.map refresh_uri_in_term ks, refresh_uri_in_term v) + l) + in + NCicLibrary.Serializer.register#run "index_obj" + object(_ : 'a NCicLibrary.register_type) + method run = aux + 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 + in + keys,NCic.Const(NReference.reference_of_spec uri spec) + in + let data = + match kind with + | NCic.Fixpoint (ind,ifl,_) -> + HExtlib.list_mapi + (fun (_,_,rno,ty,_) i -> + if ind then mk_item ty (NReference.Fix (i,rno,height)) + else mk_item ty (NReference.CoFix height)) ifl + | NCic.Inductive (b,lno,itl,_) -> + HExtlib.list_mapi + (fun (_,_,ty,_) i -> mk_item ty (NReference.Ind (b,i,lno))) itl + @ + List.map (fun ((_,_,ty),i,j) -> mk_item ty (NReference.Con (i,j+1,lno))) + (List.flatten (HExtlib.list_mapi + (fun (_,_,_,cl) i -> HExtlib.list_mapi (fun x j-> x,i,j) cl) + itl)) + | NCic.Constant (_,_,Some _, ty, _) -> + [ mk_item ty (NReference.Def height) ] + | NCic.Constant (_,_,None, ty, _) -> + [ mk_item ty NReference.Decl ] + in + HExtlib.filter_map + (fun (keys, t) -> + let keys = List.filter + (function + | (NCic.Meta _) + | (NCic.Appl (NCic.Meta _::_)) -> false + | _ -> true) + keys + in + if keys <> [] then + begin + HLog.debug ("Indexing:" ^ + NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t); + HLog.debug ("With keys:" ^ String.concat "\n" (List.map (fun t -> + NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t) keys)); + Some (keys,t) + end + else + begin + HLog.debug ("Not indexing:" ^ + 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) + 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 basic_eval_add_constraint (u1,u2) status = NCicLibrary.add_constraint status u1 u2 ;; @@ -514,7 +640,10 @@ let inject_constraint = let u2 = refresh_uri_in_universe u2 in basic_eval_add_constraint (u1,u2) in - NRstatus.Serializer.register "constraints" basic_eval_add_constraint + NCicLibrary.Serializer.register#run "constraints" + object(_:'a NCicLibrary.register_type) + method run = basic_eval_add_constraint + end ;; let eval_add_constraint status u1 u2 = @@ -624,7 +753,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 + | GrafiteAst.Branch _ -> NTactics.branch_tac ~force:false | GrafiteAst.Shift _ -> NTactics.shift_tac | GrafiteAst.Pos (_,l) -> NTactics.pos_tac l | GrafiteAst.Wildcard _ -> NTactics.wildcard_tac @@ -635,6 +764,8 @@ 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 @@ -646,10 +777,12 @@ let eval_ng_tac tac = ) hyps, (text,prefix_len,concl)) ) seqs) - | GrafiteAst.NAuto (_loc, (l,a)) -> - NTactics.auto_tac - ~params:(List.map (fun x -> "",0,x) l,a) - | GrafiteAst.NBranch _ -> NTactics.branch_tac + | GrafiteAst.NAuto (_loc, (None,a)) -> + NAuto.auto_tac ~params:(None,a) ?trace_ref:None + | GrafiteAst.NAuto (_loc, (Some 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 | GrafiteAst.NCases (_loc, what, where) -> NTactics.cases_tac ~what:(text,prefix_len,what) @@ -662,6 +795,9 @@ let eval_ng_tac tac = NTactics.constructor_tac ?num ~args:(List.map (fun x -> text,prefix_len,x) args) | 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.NDot _ -> NTactics.dot_tac | GrafiteAst.NElim (_loc, what, where) -> NTactics.elim_tac @@ -672,12 +808,18 @@ 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) ~what:(text,prefix_len,what) name | GrafiteAst.NMerge _ -> NTactics.merge_tac | GrafiteAst.NPos (_,l) -> NTactics.pos_tac l + | GrafiteAst.NPosbyname (_,s) -> NTactics.case_tac s | GrafiteAst.NReduce (_loc, reduction, where) -> NTactics.reduce_tac ~reduction ~where:(text,prefix_len,where) | GrafiteAst.NRewrite (_loc,dir,what,where) -> @@ -689,7 +831,7 @@ let eval_ng_tac tac = | GrafiteAst.NUnfocus _ -> NTactics.unfocus_tac | GrafiteAst.NWildcard _ -> NTactics.wildcard_tac | GrafiteAst.NTry (_,tac) -> NTactics.try_tac - (aux f (text, prefix_len, tac)) + (f 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) @@ -708,6 +850,7 @@ let subst_metasenv_and_fix_names status = status#set_obj(u,h,NCicUntrusted.apply_subst_metasenv subst metasenv,subst,o) ;; + let rec eval_ncommand opts status (text,prefix_len,cmd) = match cmd with | GrafiteAst.UnificationHint (loc, t, n) -> eval_unification_hint status t n @@ -745,8 +888,28 @@ 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 *) +(* prerr_endline (NCicPp.ppobj obj); *) HLog.message ("New object: " ^ NUri.string_of_uri uri); (try (*prerr_endline (NCicPp.ppobj obj);*) @@ -768,17 +931,48 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = List.fold_left (fun (status,uris) boxml -> try - let status,nuris = + let nstatus,nuris = eval_ncommand opts status ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml)) in - status, concat_nuris uris nuris + if nstatus#ng_mode <> `CommandMode then + begin + (*HLog.warn "error in generating projection/eliminator";*) + status, 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 + ) (status,`New [] (* uris *)) boxml in + let _,_,_,_,nobj = obj in + let status = match nobj with + NCic.Inductive (is_ind,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 _,_,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"; *) + let status = status#set_ng_mode `CommandMode in status) + status + (NCic.Prop:: + List.map (fun s -> NCic.Type s) (NCicEnvironment.get_universes ())) + | _ -> status + in let coercions = match obj with _,_,_,_,NCic.Inductive @@ -861,22 +1055,50 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) = [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) | _ -> status,`New []) - | GrafiteAst.NInverter (loc, name, indty) -> + | GrafiteAst.NDiscriminator (_,_) -> assert false (*(loc, indty) -> + if status#ng_mode <> `CommandMode then + raise (GrafiteTypes.Command_error "Not in command mode") + else + let status = status#set_ng_mode `ProofMode in + let metasenv,subst,status,indty = + GrafiteDisambiguate.disambiguate_nterm None status [] [] [] (text,prefix_len,indty) in + let indtyno, (_,_,tys,_,_) = match indty with + NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,_))) as r) -> + indtyno, NCicEnvironment.get_checked_indtys r + | _ -> prerr_endline ("engine: indty expected... (fix this error message)"); assert false in + let it = List.nth tys indtyno in + let status,obj = NDestructTac.mk_discriminator it status in + let _,_,menv,_,_ = obj in + (match menv with + [] -> eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc) + | _ -> prerr_endline ("Discriminator: non empty metasenv"); + status, `New []) *) + | GrafiteAst.NInverter (loc, name, indty, selection, sort) -> if status#ng_mode <> `CommandMode then raise (GrafiteTypes.Command_error "Not in command mode") else + let metasenv,subst,status,sort = match sort with + | None -> [],[],status,NCic.Sort NCic.Prop + | Some s -> GrafiteDisambiguate.disambiguate_nterm None status [] [] [] + (text,prefix_len,s) + in + assert (metasenv = []); + let sort = NCicReduction.whd ~subst [] sort in + let sort = match sort with + NCic.Sort s -> s + | _ -> raise (Invalid_argument (Printf.sprintf "ninverter: found target %s, which is not a sort" + (NCicPp.ppterm ~metasenv ~subst ~context:[] sort))) + in let status = status#set_ng_mode `ProofMode in let metasenv,subst,status,indty = - GrafiteDisambiguate.disambiguate_nterm None status [] [] [] (text,prefix_len,indty) in - let _,leftno,tys,_,_ = match indty with - NCic.Const r -> NCicEnvironment.get_checked_indtys r - | _ -> assert false in - let it = match tys with - hd::tl -> hd - | _ -> assert false - in - let status,obj = - NInversion.mk_inverter name it leftno status status#baseuri in + GrafiteDisambiguate.disambiguate_nterm None status [] [] subst (text,prefix_len,indty) in + let indtyno,(_,leftno,tys,_,_) = match indty with + NCic.Const ((NReference.Ref (_,NReference.Ind (_,indtyno,_))) as r) -> + 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 + status status#baseuri in let _,_,menv,_,_ = obj in (match menv with [] -> @@ -969,7 +1191,7 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status status in let status = - NRstatus.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) + NCicLibrary.Serializer.require ~baseuri:(NUri.uri_of_string baseuri) status in let status = GrafiteTypes.add_moo_content