| NotationEnv.DisambiguationValue _ as v -> v
in
let ast_env_of_env env =
- prerr_endline ("### pp_env: " ^ NotationPp.pp_env status env);
+ (* prerr_endline ("### pp_env: " ^ NotationPp.pp_env status env); *)
List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env
in
(* prerr_endline ("### pattern matching from 2 to 1 on term " ^
let path = String.sub uri 4 (String.length uri - 4) in
let path = match user with
| Some u -> "/" ^ u ^ path
- | _ -> path
+ | _ -> prerr_endline "WARNING: ng_path_of_baseuri called without a uid"; path
in
let path = Helm_registry.get "matita.basedir" ^ path in
let dirname = Filename.dirname path in
(fun (_,name',nref) -> if name'=name then Some nref else None)
(!(st#lib_db.local_aliases) @ get_global_aliases ())
with
- Not_found -> raise (NCicEnvironment.ObjectNotFound (lazy name))
+ Not_found ->
+ (prerr_endline ("can't resolve object " ^ name);
+ raise (NCicEnvironment.ObjectNotFound (lazy name)))
;;
let aliases_of st uri =
with Not_found ->*)
try fetch_obj (status#user) status u
with Sys_error _ ->
- raise (NCicEnvironment.ObjectNotFound (lazy (NUri.string_of_uri u)))
+ (prerr_endline ("can't fetch object " ^ NUri.string_of_uri u);
+ raise (NCicEnvironment.ObjectNotFound (lazy (NUri.string_of_uri u))))
;;
NCicEnvironment.set_get_obj
(* $Id: terms.mli 9822 2009-06-03 15:37:06Z tassi $ *)
-let eqPref = ref (fun _ -> assert false);;
-let set_eqP t = eqPref := fun _ -> t;;
-
-let default_eqP() =
+let default_eqP =
let uri = NUri.uri_of_string "cic:/matita/basics/logic/eq.ind" in
let ref = NReference.reference_of_spec uri (NReference.Ind(true,0,2)) in
NCic.Const ref
;;
+let eqPref = ref default_eqP;;
+let set_eqP t = eqPref := t;;
+
let equivalence_relation =
let uri = NUri.uri_of_string "cic:/matita/ng/properties/relations/eq_rel.con"
in
;;
- let compare x y =
+ (* let compare x y =
(* CSC: NCicPp.status is the best I can put here *)
(* WR: and I can't guess a user id, so I must put None *)
if NCicReduction.alpha_eq (new NCicPp.status None) [] [] [] x y then 0
(* if x = y then 0 *)
else compare x y
- ;;
+ ;; *)
- let eqP = (!eqPref)()
+ let eqP = fun () -> !eqPref
;;
let is_eq = function
- | Terms.Node [ Terms.Leaf eqt ; ty; l; r ] when eq eqP eqt ->
+ | Terms.Node [ Terms.Leaf eqt ; ty; l; r ] when eq (eqP()) eqt ->
Some (ty,l,r)
+ | Terms.Node [ Terms.Leaf eqt ; ty; l; r ] ->
+ None
(*
| Terms.Node [ Terms.Leaf eqt ; _; Terms.Node [Terms.Leaf eqt2 ; ty]; l; r]
when eq equivalence_relation eqt && eq setoid_eq eqt2 ->
type state = P.state
let empty_state = P.empty_state
+let size_of_state = P.size_of_state
+
let forward_infer_step status metasenv subst context s t ty =
let bag = P.bag_of_state s in
let saturate (t,ty) =
NCicBlob.saturate status metasenv subst context t ty in
- let bag,clause = P.mk_passive bag (t,ty) in
+ let bag,clause = P.mk_passive bag (saturate (t,ty)) in
if Terms.is_eq_clause clause then
- P.forward_infer_step (P.replace_bag s bag) clause 0
- else (debug (lazy "not eq"); s)
+ ((*prerr_endline "is eq";*)
+ P.forward_infer_step (P.replace_bag s bag) clause 0)
+ else ((*print (lazy "not eq");*) s)
;;
let index_obj status s uri =
NCicMetaSubst.saturate status ~delta:0 metasenv subst context
ty 0
in match hty with
- | NCic.Appl (eq ::tl) when eq = CB.eqP -> true
+ | NCic.Appl (eq ::tl) when eq = CB.eqP() -> true
| _ -> false
;;
type state
val empty_state: state
+val size_of_state: state -> int * int
val forward_infer_step:
#NCicCoercion.status ->
NCic.metasenv ->
type bag = t Terms.bag * int
type state
val empty_state : state
+ val size_of_state : state -> int*int
val bag_of_state : state -> bag
val replace_bag: state -> bag -> state
val mk_passive : bag -> input * input -> bag * t Terms.unit_clause
add_passive_goals g_passives new_goals
;;
+ let size_of_state (_,_,(a,_),p,_,_) = List.length a, passive_set_cardinal p;;
+
let debug_status (_,_,actives,passives,g_actives,g_passives) =
lazy
((Printf.sprintf "Number of active goals : %d\n"
| Timeout of int * t Terms.bag
type bag = t Terms.bag * int
val empty_state : state
+ val size_of_state : state -> int * int
val bag_of_state :state -> bag
val replace_bag : state -> bag -> state
(* we suppose input has been already saturated *)
in
aux []
(match goal with
- | _,Terms.Equation (l,r,ty,_),_,_ -> Terms.Node [ Terms.Leaf B.eqP; ty; l; r ]
+ | _,Terms.Equation (l,r,ty,_),_,_ -> Terms.Node [ Terms.Leaf (B.eqP()); ty; l; r ]
| _,Terms.Predicate p,_,_ -> p)
;;
* B.t Terms.substitution
let print s = prerr_endline (Lazy.force s);;
- let debug _ = ();;
+ let debug _ = ();;
+ (* let debug = print;; *)
let enable = true;;
let rec list_first f = function
if filter subst then
let literal =
match t with
- | Terms.Node [ Terms.Leaf eq ; ty; l; r ] when B.eq B.eqP eq ->
+ | Terms.Node [ Terms.Leaf eq ; ty; l; r ] when B.eq (B.eqP()) eq ->
let o = Order.compare_terms l r in
Terms.Equation (l, r, ty, o)
| t -> Terms.Predicate t
| Terms.Equation (l,r,ty,_) ->
let bag,l,id1 =
visit bag [2]
- (fun x -> Terms.Node [ Terms.Leaf B.eqP; ty; x; r ]) id l
+ (fun x -> Terms.Node [ Terms.Leaf (B.eqP()); ty; x; r ]) id l
(ctx_demod table vl)
in
let bag,_,id2 =
visit bag [3]
- (fun x -> Terms.Node [ Terms.Leaf B.eqP; ty; l; x ]) id1 r
+ (fun x -> Terms.Node [ Terms.Leaf (B.eqP()); ty; l; x ]) id1 r
(ctx_demod table vl)
in
let cl,_,_ = Terms.get_from_bag id2 bag in
match lit with
| Terms.Predicate _ -> assert false
| Terms.Equation (l,r,ty,_) ->
- Terms.Node [Terms.Leaf B.eqP; ty; l ; r]
+ Terms.Node [Terms.Leaf (B.eqP()); ty; l ; r]
in
try ignore(Unif.alpha_eq (get_term cl1) (get_term cl2)) ; true
with FoUnif.UnificationFailure _ -> false
let reverse = (dir = Terms.Left2Right) = b in
let l, r, proof_rewrite_dir = if reverse then l,r,Terms.Left2Right
else r,l, Terms.Right2Left in
- (id,proof_rewrite_dir,Terms.Node [ Terms.Leaf B.eqP; ty; l; r ], vl)
+ (id,proof_rewrite_dir,Terms.Node [ Terms.Leaf (B.eqP()); ty; l; r ], vl)
in
let cands1 = List.map (f true) (IDX.ClauseSet.elements lcands) in
let cands2 = List.map (f false) (IDX.ClauseSet.elements rcands) in
- let t = Terms.Node [ Terms.Leaf B.eqP; ty; l; r ] in
+ let t = Terms.Node [ Terms.Leaf (B.eqP()); ty; l; r ] in
let locked_vars = if unify then [] else vl in
let rec aux = function
| [] -> None
match rewrite_eq ~unify l r ty vl table with
| None -> None
| Some (id2, dir, subst) ->
- let id_t = Terms.Node [ Terms.Leaf B.eqP; ty; r; r ] in
+ let id_t = Terms.Node [ Terms.Leaf (B.eqP()); ty; r; r ] in
build_new_clause bag maxvar (fun _ -> true)
Terms.Superposition id_t subst id id2 [2] dir
;;
let newsubst = Subst.concat subst1 subst in
let id_t =
FoSubst.apply_subst newsubst
- (Terms.Node[Terms.Leaf B.eqP;ty;contextl r;contextr r])
+ (Terms.Node[Terms.Leaf (B.eqP());ty;contextl r;contextr r])
in
(match
build_new_clause_reloc bag maxvar (fun _ -> true)
fold_build_new_clause bag maxvar id Terms.Superposition
(fun _ -> true)
(all_positions [3]
- (fun x -> Terms.Node [ Terms.Leaf B.eqP; ty; l; x ])
+ (fun x -> Terms.Node [ Terms.Leaf (B.eqP()); ty; l; x ])
r (superposition table vl))
| Terms.Equation (l,r,ty,Terms.Invertible)
| Terms.Equation (l,r,ty,Terms.Gt) ->
fold_build_new_clause bag maxvar id Terms.Superposition
(fun _ -> true)
(all_positions [2]
- (fun x -> Terms.Node [ Terms.Leaf B.eqP; ty; x; r ])
+ (fun x -> Terms.Node [ Terms.Leaf (B.eqP()); ty; x; r ])
l (superposition table vl))
| Terms.Equation (l,r,ty,Terms.Incomparable) ->
let filtering avoid subst = (* Riazanov: p.33 condition (iv) *)
fold_build_new_clause bag maxvar id Terms.Superposition
(filtering Terms.Gt)
(all_positions [3]
- (fun x -> Terms.Node [ Terms.Leaf B.eqP; ty; l; x ])
+ (fun x -> Terms.Node [ Terms.Leaf (B.eqP()); ty; l; x ])
r (superposition table vl))
in
let bag, maxvar, l_terms =
fold_build_new_clause bag maxvar id Terms.Superposition
(filtering Terms.Lt)
(all_positions [2]
- (fun x -> Terms.Node [ Terms.Leaf B.eqP; ty; x; r ])
+ (fun x -> Terms.Node [ Terms.Leaf (B.eqP()); ty; x; r ])
l (superposition table vl))
in
bag, maxvar, r_terms @ l_terms
type t
val eq : t -> t -> bool
val compare : t -> t -> int
- val eqP : t
+ val eqP : unit -> t
val is_eq: t foterm -> (t foterm* t foterm *t foterm) option
val pp : t -> string
type input
type t
val eq : t -> t -> bool
val compare : t -> t -> int
- val eqP : t
+ val eqP : unit -> t
(* TODO: consider taking in input an imperative buffer for Format
* val pp : Format.formatter -> t -> unit
* *)
let pp_tac_status (status: #tac_status) =
prerr_endline (status#ppobj status#obj);
+ (* let a,p = NCicParamod.size_of_state status#eq_cache in
+ prerr_endline ("number of actives: " ^ string_of_int a ^ "and number of passives: " ^ string_of_int p) *)
prerr_endline ("STACK:\n" ^ Continuationals.Stack.pp status#stack)
;;
<A href="javascript:retract()"><IMG class="topimg" src="icons/retract.png"
id="retract" alt="Retract"
title="Undo execution of one step of the script."></A>
+ <A href="javascript:gotoTop()"><IMG class="topimg" src="icons/top.png"
+ id="top" alt="Top" title="Undo execution of the whole script."></A>
<A href="javascript:gotoPos()"><IMG class="topimg" src="icons/position.png"
id="cursor" alt="Play"
title="Execute the script until the current position of the cursor."></A>
"<meta number=\"" ^ (string_of_int metano) ^ "\">" ^ markup ^
txt0 ^ "</meta>" ^ acc
in
- let res = "<metasenv>" ^
+ "<metasenv>" ^
(Stack.fold
~env:(render_sequent true) ~cont:(render_sequent false)
~todo:(render_sequent false) "" s#stack) ^
"</metasenv>"
- in
(* prerr_endline ("sending metasenv:\n" ^ res); res *)
;;
cgi#out_channel#commit_work()
;;
+let gotoTop (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
+ let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
+ let env = cgi#environment in
+ prerr_endline "executing goto Top";
+ (try
+ let sid = Uuidm.of_string (Netcgi.Cookie.value (env#cookie "session")) in
+ let sid = HExtlib.unopt sid in
+ (*
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ *)
+ let status = MatitaAuthentication.get_status sid in
+ let uid = MatitaAuthentication.user_of_session sid in
+ let baseuri = status#baseuri in
+ let new_status = new MatitaEngine.status (Some uid) baseuri in
+ NCicLibrary.time_travel new_status;
+ let new_history = [new_status] in
+ MatitaAuthentication.set_history sid new_history;
+ MatitaAuthentication.set_status sid new_status;
+ NCicLibrary.time_travel new_status;
+ cgi # set_header
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\""
+ ();
+ cgi#out_channel#output_string "<response>ok</response>"
+ with _ ->
+ (cgi#set_header ~status:`Internal_server_error
+ ~cache:`No_cache
+ ~content_type:"text/xml; charset=\"utf-8\"" ();
+ cgi#out_channel#output_string "<response>ok</response>");
+ cgi#out_channel#commit_work())
+;;
+
let retract (cgi : Netcgi1_compat.Netcgi_types.cgi_activation) =
let cgi = Netcgi1_compat.Netcgi_types.of_compat_activation cgi in
let env = cgi#environment in
dyn_translator = (fun _ -> ""); (* not needed *)
dyn_accept_all_conditionals = false;
} in
+ let goto_top =
+ { Nethttpd_services.dyn_handler = (fun _ -> gotoTop);
+ dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
+ dyn_uri = None; (* not needed *)
+ dyn_translator = (fun _ -> ""); (* not needed *)
+ dyn_accept_all_conditionals = false;
+ } in
let retrieve =
{ Nethttpd_services.dyn_handler = (fun _ -> retrieve);
dyn_activation = Nethttpd_services.std_activation `Std_activation_buffered;
~handlers:[ "advance", do_advance
; "retract", do_retract
; "bottom", goto_bottom
+ ; "top", goto_top
; "open", retrieve
; "register", do_register
; "login", do_login
margin-left: auto;
margin-right: auto;
height:100%;
- width:33%;
+ width:370px;
float:left;
}
margin-left: auto;
margin-right: auto;
height:100%;
- width:33%;
+ width:300px;
float:left;
}
margin-left: auto;
margin-right: auto;
height:100%;
- width:34%;
+ width:220px;
text-align: center;
float:right;
}
}
+function gotoTop()
+{
+ processor = function(xml) {
+ if (is_defined(xml)) {
+ if (xml.childNodes[0].textContent != "ok") {
+ debug("goto top failed");
+ }
+ else
+ unlocked.innerHTML = locked.innerHTML + unlocked.innerHTML
+ locked.innerHTML = ""
+ hideSequent();
+ unlocked.scrollIntoView(true);
+ } else {
+ debug("goto top failed");
+ }
+ resume();
+ };
+ pause();
+ callServer("top",processor,"body=" + (unlocked.innerHTML.html_to_matita()).sescape());
+
+}
function gotoPos(offset)
{
if (!is_defined(offset)) {
handler = "bottom";
}
};
+ uri {
+ path = "/top";
+ service {
+ type = "dynamic";
+ handler = "top";
+ }
+ };
uri {
path = "/register";
service {