X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=310f3793fe943458490b3f29016c0c548713e599;hb=806ecbdd749ecf2a1cabff52b41cf748fe022401;hp=d0d58a6fe50dc83f770ee010bdbb4c8695ef81e9;hpb=cf4a3f9226194e0f6dc9572dea1090e2bfa55219;p=helm.git

diff --git a/helm/software/components/grafite_engine/grafiteEngine.ml b/helm/software/components/grafite_engine/grafiteEngine.ml
index d0d58a6fe..310f3793f 100644
--- a/helm/software/components/grafite_engine/grafiteEngine.ml
+++ b/helm/software/components/grafite_engine/grafiteEngine.ml
@@ -41,6 +41,11 @@ type options = {
   do_heavy_checks: bool ; 
 }
 
+let concat_nuris uris nuris =
+   match uris,nuris with
+   | `New uris, `New nuris -> `New (nuris@uris)
+   | _ -> assert false
+;;
 (** create a ProofEngineTypes.mk_fresh_name_type function which uses given
   * names as long as they are available, then it fallbacks to name generation
   * using FreshNamesGenerator module *)
@@ -482,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 = 
@@ -496,25 +504,67 @@ let eval_unification_hint status t n =
   status,`New []
 ;;
 
-let basic_eval_add_constraint (s,u1,u2) status =
- NCicLibrary.add_constraint status s u1 u2
+let basic_index_obj l status =
+  status#set_auto_cache 
+    (List.fold_left
+      (fun t (k,v) -> 
+         NDiscriminationTree.DiscriminationTree.index t k v) 
+    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 k,v -> refresh_uri_in_term k, refresh_uri_in_term v) 
+      l)
+ in
+  NCicLibrary.Serializer.register#run "index_obj"
+   object(_ : 'a NCicLibrary.register_type)
+     method run = aux
+   end
+;;
+
+let index_obj_for_auto status (uri, height, _, _, kind) = 
+ let data = 
+  match kind with
+  | NCic.Fixpoint _ -> []
+  | NCic.Inductive _ -> []
+  | NCic.Constant (_,_,_, ty, _) ->
+      let ty = (* saturare *) ty in
+      [ty,NCic.Const(NReference.reference_of_spec uri (NReference.Def height))]
+ in
+ 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
 ;;
 
 let inject_constraint =
- let basic_eval_add_constraint (s,u1,u2) 
+ let basic_eval_add_constraint (u1,u2) 
        ~refresh_uri_in_universe 
        ~refresh_uri_in_term
  =
   let u1 = refresh_uri_in_universe u1 in 
   let u2 = refresh_uri_in_universe u2 in 
-  basic_eval_add_constraint (s,u1,u2)
+  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 s u1 u2 = 
- let status = basic_eval_add_constraint (s,u1,u2) status in
- let dump = inject_constraint (s,u1,u2)::status#dump in
+let eval_add_constraint status u1 u2 = 
+ let status = basic_eval_add_constraint (u1,u2) status in
+ let dump = inject_constraint (u1,u2)::status#dump in
  let status = status#set_dump dump in
   status,`Old []
 ;;
@@ -642,7 +692,7 @@ let eval_ng_tac tac =
           (text,prefix_len,concl))
        ) seqs)
   | GrafiteAst.NAuto (_loc, (l,a)) ->
-      NTactics.auto_tac
+      NAuto.auto_tac
 	~params:(List.map (fun x -> "",0,x) l,a)
   | GrafiteAst.NBranch _ -> NTactics.branch_tac 
   | GrafiteAst.NCases (_loc, what, where) ->
@@ -653,6 +703,10 @@ let eval_ng_tac tac =
   | GrafiteAst.NChange (_loc, pat, ww) -> 
       NTactics.change_tac 
        ~where:(text,prefix_len,pat) ~with_what:(text,prefix_len,ww) 
+  | GrafiteAst.NConstructor (_loc,num,args) -> 
+     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.NDot _ -> NTactics.dot_tac 
   | GrafiteAst.NElim (_loc, what, where) ->
       NTactics.elim_tac 
@@ -663,6 +717,7 @@ 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.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
@@ -698,6 +753,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
@@ -737,6 +793,8 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
         let obj = uri,height,[],[],obj_kind in
         let old_status = status in
         let status = NCicLibrary.add_obj status obj 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
        (*prerr_endline (NCicPp.ppobj obj);*)
@@ -762,15 +820,35 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
                  eval_ncommand opts status
                   ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml))
                 in
-                 match uris,nuris with
-                    `New uris, `New nuris -> status,`New (nuris@uris)
-                  | _ -> assert false
+                status, concat_nuris uris nuris
                with
-                NCicTypeChecker.TypeCheckerFailure msg
-                 when Lazy.force msg =
-                 "Sort elimination not allowed" ->
+               | MultiPassDisambiguator.DisambiguationError _ 
+               | NCicTypeChecker.TypeCheckerFailure _ ->
+                  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 (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))) 
+                                      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 []))
+                      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
@@ -780,16 +858,25 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
                  (fun (name,is_coercion,arity) ->
                    if is_coercion then Some(name,leftno,arity) else None) fields
             | _ -> [] in
-           let status =
+           let status,uris =
             List.fold_left
-             (fun status (name,cpos,arity) ->
-               let metasenv,subst,status,t =
-                GrafiteDisambiguate.disambiguate_nterm None status [] [] []
-                 ("",0,CicNotationPt.Ident (name,None)) in
-               assert (metasenv = [] && subst = []);
-               NCicCoercDeclaration.basic_eval_and_inject_ncoercion_from_t_cpos_arity 
-                 status (name,t,cpos,arity)
-             ) status coercions
+             (fun (status,uris) (name,cpos,arity) ->
+               try
+                 let metasenv,subst,status,t =
+                  GrafiteDisambiguate.disambiguate_nterm None status [] [] []
+                   ("",0,CicNotationPt.Ident (name,None)) in
+                 assert (metasenv = [] && subst = []);
+                 let status, nuris = 
+                   NCicCoercDeclaration.
+                     basic_eval_and_record_ncoercion_from_t_cpos_arity 
+                      status (name,t,cpos,arity)
+                 in
+                 let uris = concat_nuris nuris uris in
+                 status, uris
+               with MultiPassDisambiguator.DisambiguationError _-> 
+                 HLog.warn ("error in generating coercion: "^name);
+                 status, uris) 
+             (status,uris) coercions
            in
             status,uris
           with
@@ -844,8 +931,39 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
           [] ->
            eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc)
         | _ -> status,`New [])
-  | GrafiteAst.NUnivConstraint (loc,strict,u1,u2) ->
-      eval_add_constraint status strict [false,u1] [false,u2]
+  | 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 [] [] 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 it leftno ?selection sort 
+                        status status#baseuri in
+     let _,_,menv,_,_ = obj in
+     (match menv with
+        [] ->
+          eval_ncommand opts status ("",0,GrafiteAst.NQed Stdpp.dummy_loc)
+      | _ -> assert false)
+  | GrafiteAst.NUnivConstraint (loc,u1,u2) ->
+      eval_add_constraint status [`Type,u1] [`Type,u2]
 ;;
 
 let rec eval_command = {ec_go = fun ~disambiguate_command opts status
@@ -931,7 +1049,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