eliminate use of Thy_Info 12: prep.arg. ctxt in TermC, UnparseC
1 (* Title: the calctree, which holds a calculation
2 Author: Walther Neuper 1999
3 (c) due to copyright terms
5 Definitions required for Ctree, renamed later appropriately
8 signature BASIC_CALC_TREE =
11 (** the basic datatype **)
18 datatype branch = AndB | CollectB | IntersectB | MapB | NoBranch | OrB | SequenceB | TransitiveB
19 datatype ostate = Complete | Incomplete | Inconsistent
22 datatype ppobj = PblObj of specify_data | PrfObj of solve_data
23 datatype ctree = EmptyPtree | Nd of ppobj * ctree list
25 val rep_solve_data: ppobj -> solve_data
26 val rep_specify_data: ppobj -> specify_data
28 (** basic functions **)
29 val e_ctree : ctree (* TODO: replace by EmptyPtree*)
30 val existpt' : Pos.pos' -> ctree -> bool
31 val is_interpos : Pos.pos' -> bool
32 val lev_pred' : ctree -> Pos.pos' -> Pos.pos'
33 val ins_chn : ctree list -> ctree -> Pos.pos -> ctree
34 val children : ctree -> ctree list
35 val get_nd : ctree -> Pos.pos -> ctree
36 val just_created_ : ppobj -> bool
37 val just_created : state -> bool
38 val e_origin : Model_Def.o_model * References_Def.T * term
40 val is_pblobj : ppobj -> bool
41 val is_pblobj' : ctree -> Pos.pos -> bool
42 val is_pblnd : ctree -> bool
44 val g_spec : ppobj -> References_Def.T
45 val g_loc : ppobj -> (Istate_Def.T * Proof.context) option * (Istate_Def.T * Proof.context) option
46 val g_form : ppobj -> term
47 val g_pbl : ppobj -> Model_Def.i_model
48 val g_met : ppobj -> Model_Def.i_model
49 val g_metID : ppobj -> MethodC.id
50 val g_result : ppobj -> Celem.result
51 val g_tac : ppobj -> Tactic.input
52 val g_domID : ppobj -> ThyC.id
54 val g_origin : ppobj -> Model_Def.o_model * References_Def.T * term
55 val get_loc : ctree -> Pos.pos' -> Istate_Def.T * Proof.context
56 val get_istate_LI : ctree -> Pos.pos' -> Istate_Def.T
57 val get_ctxt_LI: ctree -> Pos.pos' -> Proof.context
58 val get_ctxt : ctree -> Pos.pos' -> Proof.context (*DEPRECATED*)
59 val get_obj : (ppobj -> 'a) -> ctree -> Pos.pos -> 'a
60 val get_curr_formula : state -> term
61 val get_assumptions : ctree -> Pos.pos' -> term list
63 val new_val : term -> Istate_Def.T -> Istate_Def.T
65 type cid = cellID list
66 datatype ptform = Form of term | ModSpec of Specification_Def.T
67 val get_somespec' : References_Def.T -> References_Def.T -> References_Def.T
68 exception PTREE of string;
70 val root_thy : ctree -> theory
71 (* ---- made visible ONLY for structure CTaccess : CALC_TREE_ACCESS --------------------------- *)
72 val appl_obj : (ppobj -> ppobj) -> ctree -> Pos.pos -> ctree
73 val existpt : Pos.pos -> ctree -> bool
74 val cut_tree : ctree -> Pos.pos * 'a -> ctree * Pos.pos' list
75 val insert_pt : ppobj -> ctree -> int list -> ctree
76 (* ---- made visible ONLY for structure CTnavi : CALC_TREE_NAVIGATION ------------------------- *)
77 val g_branch : ppobj -> branch
78 val g_form' : ctree -> term
79 val g_ostate : ppobj -> ostate
80 val g_ostate' : ctree -> ostate
81 val g_res : ppobj -> term
82 val g_res' : ctree -> term
83 (*/---- duplicates in CTnavi, reconsider structs -----------------------------------------------
84 val lev_dn : CTbasic.Pos.pos -> Pos.pos (* duplicate in ctree-navi.sml *)
85 val par_pblobj : CTbasic.ctree -> Pos.pos -> Pos.pos (* duplicate in ctree-navi.sml *)
86 ---- duplicates in CTnavi, reconsider structs ----------------------------------------------/*)
87 (*from isac_test for Minisubpbl*)
88 val pr_ctree: Proof.context -> (Proof.context -> int list -> ppobj -> string) -> ctree -> string
89 val pr_short: Proof.context -> Pos.pos -> ppobj -> string
92 val g_ctxt : ppobj -> Proof.context
93 val g_fmz : ppobj -> Model_Def.form_T
94 val get_allp : Pos.pos' list -> Pos.pos * (int list * Pos.pos_) -> ctree -> Pos.pos' list
95 val get_allps : (Pos.pos * Pos.pos_) list -> Pos.posel list -> ctree list -> Pos.pos' list
96 val get_allpos' : Pos.pos * Pos.posel -> ctree -> Pos.pos' list
97 val get_allpos's : Pos.pos * Pos.posel -> ctree list -> (Pos.pos * Pos.pos_) list
98 val cut_bottom : Pos.pos * Pos.posel -> ctree -> (ctree * Pos.pos' list) * bool
99 val cut_level : Pos.pos' list -> Pos.pos -> ctree -> int list * Pos.pos_ -> ctree * Pos.pos' list
100 val cut_level__ : Pos.pos' list -> Pos.pos -> ctree -> int list * Pos.pos_ -> ctree * Pos.pos' list
101 val get_trace : ctree -> int list -> int list -> int list list
102 val branch2str : branch -> string
107 structure CTbasic(**): BASIC_CALC_TREE(**) =
114 (*** general types* **)
117 NoBranch | AndB | OrB
118 | TransitiveB (* FIXXXME.0308: set branch from met in Apply_Method
119 FIXXXME.0402: -"- in Begin_Trans'*)
120 | SequenceB | IntersectB | CollectB | MapB;
123 fun branch2str NoBranch = "NoBranch"
124 | branch2str AndB = "AndB"
125 | branch2str OrB = "OrB"
126 | branch2str TransitiveB = "TransitiveB"
127 | branch2str SequenceB = "SequenceB"
128 | branch2str IntersectB = "IntersectB"
129 | branch2str CollectB = "CollectB"
130 | branch2str MapB = "MapB";
134 Incomplete | Complete | Inconsistent (* WN041020 latter still unused *);
136 fun ostate2str Incomplete = "Incomplete"
137 | ostate2str Complete = "Complete"
138 | ostate2str Inconsistent = "Inconsistent";
142 type cid = cellID list;
145 type iist = Istate_Def.T option * Istate_Def.T option;
146 (*val e_iist = (empty, empty); --- sinnlos f"ur NICHT-equality-type*)
149 fun new_val v (Istate_Def.Pstate pst) =
150 (Istate_Def.Pstate (Istate_Def.set_act v pst))
151 | new_val _ _ = raise ERROR "new_val: only for Pstate";
153 datatype con = land | lor;
155 (* executed tactics (tac_s) with local environment etc.;
156 used for continuing eval script + for generate *)
158 (TermC.path *(* of tactic in program, tactic (weakly) associated with tac_ *)
159 (Tactic.T * (* (for generate) *)
160 Env.T * (* with 'tactic=result' as rule, tactic ev. _not_ ready for 'parallel let' *)
161 Env.T * (* with results of (ready) tacs *)
162 term * (* itr_arg of tactic, for upd. env at Repeat, Try *)
163 term * (* result value of the tac *)
168 fun ets2s (l,(m,eno,env,iar,res,s)) =
169 "\n(" ^ TermC.string_of_path l ^ ",(" ^ Tactic.string_of m ^
170 ",\n ens= " ^ Env.subst2str eno ^
171 ",\n env= " ^ Env.subst2str env ^
172 ",\n iar= " ^ UnparseC.term iar ^
173 ",\n res= " ^ UnparseC.term res ^
174 ",\n " ^ Celem.safe2str s ^ "))";
175 fun ets2str (ets: ets) = (strs2str o (map ets2s)) ets;
178 type envp =(*9.5.03: unused, delete with field in ctree.PblObj FIXXXME*)
179 (int * term list) list * (* assoc-list: args of met*)
180 (int * Rule_Set.T) list * (* assoc-list: tacs already done ///15.9.00*)
181 (int * ets) list * (* assoc-list: tacs etc. already done*)
182 (string * pos) list; (* asms * from where*)
188 {fmz : Model_Def.form_T, (* from init:FIXME never use this spec;-drop *)
189 origin: (Model_Def.o_model) *(* = O_Model.T for efficiently checking input to I_Model *)
190 References_Def.T * (* updated by Refine_Tacitly *)
191 term, (* headline of calc-head, as calculated initially(!) *)
192 spec : References_Def.T, (* explicitly input *)
193 probl : Model_Def.i_model,(* = I_Model.T for interactive input to a Problem *)
194 meth : Model_Def.i_model,(* = I_Model.T for interactive input to a MethodC *)
195 ctxt : Proof.context, (* used while specifying this (Sub-)Problem and MethodC *)
196 loc : (Istate_Def.T * Proof.context) option (* like in PrfObj, calling this SubProblem *)
197 * (Istate_Def.T * Proof.context) option, (* like in PrfObj, finishing the SubProblem *)
198 branch: branch, (* like PrfObj *)
199 result: Celem.result, (* like PrfObj *)
200 ostate: ostate}; (* like PrfObj *)
201 type solve_data = (* TODO: arrange according to signature *)
202 {form : term, (* where tactic is applied to *)
203 tac : Tactic.input, (* tactic as presented to users *)
204 loc : (Istate_Def.T * (* program interpreter state *)
205 Proof.context) (* context for provers, type inference *)
206 option * (* both for interpreter location on Frm, Pbl, Met *)
207 (Istate_Def.T * (* script interpreter state *)
208 Proof.context) (* context for provers, type inference *)
209 option, (* both for interpreter location on Res, (NONE,NONE) == empty *)
210 branch: branch, (* only rudimentary *)
211 result: Celem.result, (* result and assumptions *)
212 ostate: ostate} (* Complete <=> result is OK *)
215 PblObj of specify_data (* data serving a whole specification-phase *)
216 | PrfObj of solve_data; (* data for a proof step triggered by a tactic *)
218 (* this tree contains isac's calculations;
219 the tree's structure has been copied from an early version of Theorema(c);
220 it has the disadvantage, that there is no space
221 for the first tactic in a script generating the first formula at (p,Frm);
222 this trouble has been covered by 'implicit_take' and 'Take' so far,
223 but it is crucial if the first tactic in a script is eg. 'Subproblem';
224 see 'type tac', Apply_Method.
228 | Nd of ppobj * (ctree list);
229 val e_ctree = EmptyPtree;
230 type state = ctree * pos'
231 val e_state = (EmptyPtree , e_pos')
233 fun rep_solve_data (PrfObj solve_data) = solve_data
234 | rep_solve_data _ = raise ERROR "rep_solve_data ONLY for solve_data"
235 fun rep_specify_data (PblObj specify_data) = specify_data
236 | rep_specify_data _ = raise ERROR "rep_solve_data ONLY for solve_data"
239 (*** minimal set of functions on Ctree* **)
241 fun is_pblobj (PblObj _) = true
242 | is_pblobj _ = false;
244 exception PTREE of string;
245 fun nth _ [] = raise PTREE "nth _ []"
247 | nth n (_ :: xs) = nth (n - 1) xs;
248 (*> nth 2 [11,22,33]; -->> val it = 22 : int*)
251 (** convert ctree to a string **)
253 (* convert a pos from list to string *)
254 fun pr_pos ps = (space_implode "." (map string_of_int ps)) ^ ". ";
255 (* show hd origin or form only *)
257 fun pr_short _ p (PblObj _) = pr_pos p ^ " ----- pblobj -----\n"
258 | pr_short ctxt p (PrfObj {form = form, ...}) = pr_pos p ^ UnparseC.term_in_ctxt ctxt form ^ "\n";
259 fun pr_ctree ctxt f pt =
261 fun pr_pt _ _ EmptyPtree = ""
262 | pr_pt pfn ps (Nd (b, [])) = pfn ps b
263 | pr_pt pfn ps (Nd (b, ts)) = pfn ps b ^ prts pfn ps 1 ts
264 and prts _ _ _ [] = ""
265 | prts pfn ps p (t :: ts) = (pr_pt pfn (ps @ [p]) t)^
266 (prts pfn ps (p + 1) ts)
267 in pr_pt (f ctxt) [] pt end;
271 (** access the branches of ctree **)
273 fun repl [] _ _ = raise PTREE "repl [] _ _"
274 | repl (_ :: ls) 1 e = e :: ls
275 | repl (l :: ls) n e = l :: (repl ls (n-1) e);
276 fun repl_app ls n e =
278 val lim = 1 + length ls
281 then raise PTREE "repl_app: n > lim"
284 else repl ls n e end;
286 (* get from obj at pos by f : ppobj -> 'a *)
287 fun get_obj _ EmptyPtree _ = raise PTREE "get_obj f EmptyPtree"
288 | get_obj f (Nd (b, _)) [] = f b
289 | get_obj f (Nd (_, bs)) (p :: ps) =
290 case \<^try>\<open> get_obj f (nth p bs) ps \<close> of
292 | NONE => raise PTREE ("get_obj: pos = " ^ ints2str' (p :: ps) ^ " does not exist");
293 fun get_nd EmptyPtree _ = raise PTREE "get_nd EmptyPtree"
295 | get_nd (Nd (_, nds)) (pos as p :: ps) =
296 case \<^try>\<open> get_nd (nth p nds) ps \<close> of
298 | NONE => raise PTREE ("get_nd: not existent pos = " ^ ints2str' pos);
300 (* for use by get_obj *)
301 fun g_form (PrfObj {form = f,...}) = f
302 | g_form (PblObj {origin= (_,_,f),...}) = f;
303 fun g_form' (Nd (PrfObj {form = f, ...}, _)) = f
304 | g_form' (Nd (PblObj {origin= (_, _, f),...}, _)) = f
305 | g_form' _ = raise ERROR "g_form': uncovered fun def.";
306 (* | g_form _ = raise PTREE "g_form not for PblObj";*)
307 fun g_origin (PblObj {origin = ori, ...}) = ori
308 | g_origin _ = raise PTREE "g_origin not for PrfObj";
310 fun g_fmz (PblObj {fmz = f, ...}) = f
311 | g_fmz _ = raise PTREE "g_fmz not for PrfObj";
313 fun g_spec (PblObj {spec = s, ...}) = s
314 | g_spec _ = raise PTREE "g_spec not for PrfObj";
315 fun g_pbl (PblObj {probl = p, ...}) = p
316 | g_pbl _ = raise PTREE "g_pbl not for PrfObj";
317 fun g_met (PblObj {meth = p, ...}) = p
318 | g_met _ = raise PTREE "g_met not for PrfObj";
319 fun g_domID (PblObj {spec = (d, _, _), ...}) = d
320 | g_domID _ = raise PTREE "g_metID not for PrfObj";
321 fun g_metID (PblObj {spec = (_, _, m), ...}) = m
322 | g_metID _ = raise PTREE "g_metID not for PrfObj";
323 fun g_ctxt (PblObj {ctxt, ...}) = ctxt
324 | g_ctxt _ = raise PTREE "g_ctxt not for PrfObj";
325 fun g_loc (PblObj {loc = l, ...}) = l
326 | g_loc (PrfObj {loc = l, ...}) = l;
327 fun g_branch (PblObj {branch = b, ...}) = b
328 | g_branch (PrfObj {branch = b, ...}) = b;
329 fun g_tac (PblObj {spec = (_, _, m),...}) = Tactic.Apply_Method m
330 | g_tac (PrfObj {tac = m, ...}) = m;
331 fun g_result (PblObj {result = r, ...}) = r
332 | g_result (PrfObj {result = r, ...}) = r;
333 fun g_res (PblObj {result = (r, _) ,...}) = r
334 | g_res (PrfObj {result = (r, _),...}) = r;
335 fun g_res' (Nd (PblObj {result = (r, _), ...}, _)) = r
336 | g_res' (Nd (PrfObj {result = (r, _),...}, _)) = r
337 | g_res' _ = raise PTREE "g_res': uncovered fun def.";
338 fun g_ostate (PblObj {ostate = r, ...}) = r
339 | g_ostate (PrfObj {ostate = r, ...}) = r;
340 fun g_ostate' (Nd (PblObj {ostate = r, ...}, _)) = r
341 | g_ostate' (Nd (PrfObj {ostate = r, ...}, _)) = r
342 | g_ostate' _ = raise PTREE "g_ostate': uncovered fun def.";
344 (* get the formula preceeding the current position in a calculation *)
345 fun get_curr_formula (pt, (p, p_)) =
347 Frm => get_obj g_form pt p
348 | Res => (fst o (get_obj g_result pt)) p
349 | _ => #3 (get_obj g_origin pt p); (* the headline*)
351 (* in CalcTree/Subproblem an 'just_created_' model is created;
352 this is filled to 'untouched' by Model/Refine_Problem *)
353 fun just_created_ (PblObj {meth, probl, spec, ...}) =
354 null meth andalso null probl andalso spec = References_Def.empty
355 | just_created_ _ = raise PTREE "g_ostate': uncovered fun def.";
356 val e_origin = ([], References_Def.empty, TermC.empty);
358 fun just_created (pt, (p, _)) =
359 let val ppobj = get_obj I pt p
360 in is_pblobj ppobj andalso just_created_ ppobj end;
362 (* does the pos in the ctree exist ? *)
363 fun existpt pos pt = can (get_obj I pt) pos;
364 (* does the pos' in the ctree exist, ie. extra check for result in the node *)
365 fun existpt' (p, p_) pt =
366 if can (get_obj I pt) p
368 Res => get_obj g_ostate pt p = Complete
372 (* is this position appropriate for calculating intermediate steps? *)
373 fun is_interpos (_, Res) = true
374 | is_interpos _ = false;
376 (* get the children of a node in ctree *)
377 fun children (Nd (PblObj _, cn)) = cn
378 | children (Nd (PrfObj _, cn)) = cn
379 | children _ = raise ERROR "children: uncovered fun def.";
381 (*/--------------- duplicates in ctree-navi.sml: required also here below ---------------\*)
383 fun lev_up [] = raise PTREE "lev_up []"
384 | lev_up p = (drop_last p):pos;
385 (* find the position of the next parent which is a PblObj in ctree *)
386 fun par_pblobj _ [] = []
391 if is_pblobj (get_obj I pt p)
393 else par pt (lev_up p)
394 in par pt (lev_up p) end;
396 (*\--------------- duplicates in ctree-navi.sml: required also here below ---------------/*)
398 (* insert obj b into ctree at pos, ev.overwriting this pos *)
399 fun insert_pt b EmptyPtree [] = Nd (b, [])
400 | insert_pt _ EmptyPtree _ = raise PTREE "insert_pt b Empty _"
401 | insert_pt b _ [] = Nd (b, [])
402 | insert_pt b (Nd (b', bs)) (p :: []) = Nd (b', repl_app bs p (Nd (b, [])))
403 | insert_pt b (Nd (b', bs)) (p :: ps) = Nd (b', repl_app bs p (insert_pt b (nth p bs) ps));
405 (* insert children to a node without children. compare: fun insert_pt *)
406 fun ins_chn _ EmptyPtree _ = raise PTREE "ins_chn: EmptyPtree"
407 | ins_chn _ (Nd _) [] = raise PTREE "ins_chn: pos = []"
408 | ins_chn ns (Nd (b, bs)) (p :: []) =
410 then raise PTREE "ins_chn: pos not existent"
413 val (b', bs') = case nth p bs of
414 Nd (b', bs') => (b', bs')
415 | _ => raise ERROR "ins_chn: uncovered case nth"
418 then Nd (b, repl_app bs p (Nd (b', ns)))
419 else raise PTREE "ins_chn: pos mustNOT be overwritten"
421 | ins_chn ns (Nd (b, bs)) (p::ps) = Nd (b, repl_app bs p (ins_chn ns (nth p bs) ps));
423 (* apply f to obj at pos, f: ppobj -> ppobj *)
424 fun appl_to_node f (Nd (b, bs)) = Nd (f b, bs)
425 | appl_to_node _ _ = raise ERROR "appl_to_node: uncovered fun def.";
426 fun appl_obj _ EmptyPtree [] = EmptyPtree
427 | appl_obj _ EmptyPtree _ = raise PTREE "appl_obj f Empty _"
428 | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs)
429 | appl_obj f (Nd (b, bs)) (p :: []) = Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs))
430 | appl_obj f (Nd (b, bs)) (p :: ps) = Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos)));
432 datatype ptform = Form of term | ModSpec of Specification_Def.T;
435 fun test_trans (PrfObj {branch, ...}) = true andalso branch = TransitiveB
436 | test_trans (PblObj {branch, ...}) = true andalso branch = TransitiveB;
439 fun is_pblobj' pt p =
440 let val ppobj = get_obj I pt p
441 in is_pblobj ppobj end;
443 fun del_res (PblObj {fmz, origin, spec, probl, meth, ctxt, loc = (l1, _), branch, ...}) =
444 PblObj {fmz = fmz, origin = origin, spec = spec, probl = probl, meth = meth,
445 ctxt = ctxt, loc= (l1, NONE), branch = branch,
446 result = (TermC.empty, []), ostate = Incomplete}
447 | del_res (PrfObj {form, tac, loc= (l1, _), branch, ...}) =
448 PrfObj {form = form, tac = tac, loc = (l1, NONE), branch = branch,
449 result = (TermC.empty, []), ostate = Incomplete};
452 fun get_loc EmptyPtree _ = (Istate_Def.empty, ContextC.empty)
453 | get_loc pt (p, Res) =
454 (case get_obj g_loc pt p of
455 (SOME ist_ctxt, NONE) => ist_ctxt
456 | (NONE , NONE) => (Istate_Def.empty, ContextC.empty)
457 | (_ , SOME ist_ctxt) => ist_ctxt)
458 | get_loc pt (p, _) =
459 (case get_obj g_loc pt p of
460 (NONE , SOME ist_ctxt) => ist_ctxt (* 020813 too liberal? *)
461 | (NONE , NONE) => (Istate_Def.empty, ContextC.empty)
462 | (SOME ist_ctxt, _) => ist_ctxt);
463 fun get_istate_LI pt p = get_loc pt p |> #1;
464 fun get_ctxt_LI pt p = get_loc pt p |> #2;
465 fun get_ctxt pt (pos as (p, p_)) =
466 if member op = [Frm, Res] p_
467 then get_loc pt pos |> #2 (*for program interpretation rely on fun get_loc*)
468 else (*p = Pbl: for specify phase take ctxt from PblObj *)
469 if (p |> get_obj g_origin pt |> LibraryC.fst3) = [] (*CAS-command ? *)
470 then (ThyC.get_theory "Isac_Knowledge"(*CAS-command unknown*)) |> Defs.global_context |> fst
471 else get_obj g_ctxt pt p
473 fun get_assumptions pt p = get_ctxt pt p |> ContextC.get_assumptions;
475 fun get_somespec' (dI, pI, mI) (dI', pI', mI') =
477 val domID = if dI = ThyC.id_empty then dI' else dI
478 val pblID = if pI = Problem.id_empty then pI' else pI
479 val metID = if mI = MethodC.id_empty then mI' else mI
480 in (domID, pblID, metID) end;
482 (**.development for extracting an 'interval' from ptree.**)
485 (*WN0510 version stopped in favour of get_interval with !!!move_dn, getFormulaeFromTo
486 actually used (inefficient) version with move_dn: see modspec.sml*)
489 fun hdp [] = 1 | hdp [0] = 1 | hdp x = hd x;(*start with first*)
490 fun hdq [] = 99999 | hdq [0] = 99999 | hdq x = hd x;(*take until last*)
491 fun tlp [] = [0] | tlp [_] = [0] | tlp x = tl x;
492 fun tlq [] = [99999] | tlq [_] = [99999] | tlq x = tl x;
494 fun getnd i (b,p) q (Nd (_, nds)) =
495 (if i <= 0 then [[b]] else []) @
496 (getnds (i-1) true (b@[hdp p], tlp p) (tlq q)
497 (take_fromto (hdp p) (hdq q) nds))
498 | getnd _ _ _ _ = raise ERROR "getnd: uncovered case in fun.def."
499 and getnds _ _ _ _ [] = [] (*no children*)
500 | getnds i _ (b,p) q [nd] = (getnd i (b,p) q nd) (*l+r-margin*)
502 | getnds i true (b,p) q [n1, n2] = (*l-margin, r-margin*)
503 (getnd i ( b, p ) [99999] n1) @
504 (getnd ~99999 (lev_on b,[0]) q n2)
506 | getnds i _ (b, _) q [n1, n2] = (*intern, r-margin*)
507 (getnd i ( b,[0]) [99999] n1) @
508 (getnd ~99999 (lev_on b,[0]) q n2)
510 | getnds i true (b,p) q (nd::(nds as _::_)) = (*l-margin, intern*)
511 (getnd i ( b, p ) [99999] nd) @
512 (getnds ~99999 false (lev_on b,[0]) q nds)
514 | getnds i _ (b, _) q (nd::(nds as _::_)) = (*intern, ...*)
515 (getnd i ( b,[0]) [99999] nd) @
516 (getnds ~99999 false (lev_on b,[0]) q nds);
518 (*get an 'interval from to' from a ptree as 'intervals f t' of respective nodes
519 where 'from' are pos, i.e. a key as int list, 'f' an int (to,t analoguous)
520 (1) the 'f' are given
521 (1a) by 'from' if 'f' = the respective element of 'from' (left margin)
522 (1b) -inifinity, if 'f' > the respective element of 'from' (internal node)
524 (2a) by 'to' if 't' = the respective element of 'to' (right margin)
525 (2b) inifinity, if 't' < the respective element of 'to (internal node)'
526 the 'f' and 't' are set by hdp,... *)
527 fun get_trace pt p q =
528 (flat o (getnds ((length p) -1) true ([hdp p], tlp p) (tlq q)))
529 (take_fromto (hdp p) (hdq q) (children pt));
532 (*extract a formula or model from ctree for itms2itemppc or model2xml*)
533 fun preconds2str bts =
534 (strs2str o (map (linefeed o pair2str o
535 (apsnd UnparseC.term) o
536 (apfst bool2str)))) bts;
538 fun ocalhd2str (b, p, hdf, itms, prec, spec) =
539 "(" ^ bool2str b ^ ", " ^ pos_2str p ^ ", " ^ UnparseC.term hdf ^
540 ", " ^ "\<forall>itms2str itms\<forall>" (*Model_Def.itms2str_ (ThyC.id_to_ctxt "Isac_Knowledge") itms*) ^
541 ", " ^ preconds2str prec ^ ", \n" ^ References_Def.to_string spec ^ " )";
545 fun is_pblnd (Nd (ppobj, _)) = is_pblobj ppobj
546 | is_pblnd _ = raise ERROR "is_pblnd: uncovered fun def.";
549 (* determine the previous pos' on the same level
550 WN0502 made for interSteps; _only_ works for branch TransitiveB WN120517 compare lev_back *)
551 fun lev_pred' _ ([], Res) = ([], Pbl)
552 | lev_pred' pt (p, Res) =
553 let val (p', last) = split_last p
556 then if (is_pblobj o (get_obj I pt)) p then (p, Pbl) else (p, Frm)
557 else if get_obj g_res pt (p' @ [last - 1]) = get_obj g_form pt p
558 then (p' @ [last - 1], Res) (* TransitiveB *)
559 else if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
561 | lev_pred' _ _ = raise ERROR "";
564 (**.insert into ctree and cut branches accordingly.**)
567 (* get all positions of certain intervals on the ctree.
568 old VERSION without move_dn; kept for occasional redesign
569 get all pos's to be cut in a ctree
570 below a pos or from a ctree list after i-th element (NO level_up) *)
571 fun get_allpos' (_, _) EmptyPtree = []
572 | get_allpos' (p, 1) (Nd (b, bs)) = (* p is pos of Nd *)
573 if g_ostate b = Incomplete
574 then (p, Frm) :: (get_allpos's (p, 1) bs)
575 else (p, Frm) :: (get_allpos's (p, 1) bs) @ [(p, Res)]
576 | get_allpos' (p, _) (Nd (b, bs)) = (* p is pos of Nd *)
577 if length bs > 0 orelse is_pblobj b
578 then if g_ostate b = Incomplete
579 then [(p,Frm)] @ (get_allpos's (p, 1) bs)
580 else [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p, Res)]
581 else if g_ostate b = Incomplete then [] else [(p, Res)]
582 and get_allpos's _ [] = []
583 | get_allpos's (p, i) (pt :: pts) = (* p is pos of parent-Nd *)
584 (get_allpos' (p @ [i], i) pt) @ (get_allpos's (p, i + 1) pts);
586 (*WN050106 like cut_level, but deletes exactly 1 node *)
587 fun cut_level__ _ _ EmptyPtree _ =raise PTREE "cut_level__ Empty _" (* for tests ONLY *)
588 | cut_level__ _ _ (Nd ( _, _)) ([], _) = raise PTREE "cut_level__ _ []"
589 | cut_level__ cuts P (Nd (b, bs)) (p :: [], p_) =
592 (Nd (b, drop_nth [] (p:Pos.posel, bs)),
593 cuts @ (if p_ = Frm then [(P @ [p], Res)] else []) @
594 (get_allpos's (P, p + 1) (drop_nth [] (p, bs))))
595 else (Nd (b, bs), cuts)
596 | cut_level__ cuts P (Nd (b, bs)) ((p :: ps), p_) =
598 val (bs', cuts') = cut_level__ cuts P (nth p bs) (ps, p_)
599 in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
601 fun cut_level _ _ EmptyPtree _ = raise PTREE "cut_level EmptyPtree _"
602 | cut_level _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level _ []"
603 | cut_level cuts P (Nd (b, bs)) (p :: [], p_) =
606 (Nd (b, take (p:Pos.posel, bs)),
608 (if p_ = Frm andalso (*#*) g_ostate b = Complete then [(P@[p],Res)] else ([]:pos' list)) @
609 (get_allpos's (P, p+1) (takerest (p, bs))))
610 else (Nd (b, bs), cuts)
611 | cut_level cuts P (Nd (b, bs)) ((p :: ps), p_) =
613 val (bs', cuts') = cut_level cuts P (nth p bs) (ps, p_)
614 in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
617 (*old version before WN050219, overwritten below*)
618 fun cut_tree _ ([], _) = raise PTREE "cut_tree _ ([],_)"
619 | cut_tree pt (pos as ([_], _)) =
621 val (pt', cuts) = cut_level [] [] pt pos
623 (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete then [] else [([], Res)]))
625 | cut_tree pt (p,p_) =
627 fun cutfn pt cuts (p, p_) =
629 val (pt', cuts') = cut_level [] (lev_up p) pt (p,p_)
631 if length cuts' > 0 andalso length p > 1
632 then cutfn pt' (cuts @ cuts') (lev_up p, Frm(*-->(p,Res)*))
633 else (pt', cuts @ cuts')
635 val (pt', cuts) = cutfn pt [] (p, p_)
637 (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete then [] else [([], Res)]))
642 fun move_dn _ (Nd (_, ns)) ([],p_) = (* root problem *)
644 Res => raise PTREE "move_dn: end of calculation"
646 if null ns (* go down from Pbl + Met *)
647 then raise PTREE "move_dn: solve problem not started"
649 | move_dn P (Nd (_, ns)) (p :: (ps as (_ :: _)), p_) = (* iterate to end of pos *)
651 then raise PTREE "move_dn: pos not existent 2"
652 else move_dn (P @ [p]) (nth p ns) (ps, p_)
653 | move_dn P (Nd (c, ns)) ([p], p_) = (* act on last element of pos *)
655 then raise PTREE "move_dn: pos not existent 3"
659 if p = length ns (* last Res on this level: go a level up *)
660 then if g_ostate c = Complete
662 else raise PTREE (ints2str' P ^ " not complete 1")
663 else (* go to the next Nd on this level, or down into the next Nd *)
664 if is_pblnd (nth (p + 1) ns) then (P@[p + 1], Pbl)
665 else if g_res' (nth p ns) = g_form' (nth (p + 1) ns)
666 then if (null o children o (nth (p + 1))) ns
667 then (* take the Res if Complete *)
668 if g_ostate' (nth (p + 1) ns) = Complete
669 then (P@[p + 1], Res)
670 else raise PTREE (ints2str' (P@[p + 1]) ^ " not complete 2")
671 else (P@[p + 1, 1], Frm) (* go down into the next PrfObj *)
672 else (P@[p + 1], Frm) (* take Frm: exists if the Nd exists *)
673 | Frm => (*go down or to the Res of this Nd*)
674 if (null o children o (nth p)) ns
675 then if g_ostate' (nth p ns) = Complete then (P @ [p], Res)
676 else raise PTREE (ints2str' (P @ [p])^" not complete 3")
677 else (P @ [p, 1], Frm)
678 | _ => (* is Pbl or Met *)
679 if (null o children o (nth p)) ns
680 then raise PTREE "move_dn:solve subproblem not startd"
682 if (is_pblnd o hd o children o (nth p)) ns
684 | move_dn _ _ _ = raise ERROR "";
686 (* get all positions in a ctree until ([],Res) or ostate=Incomplete
688 pos' list -> : accumulated, start with []
689 pos -> : the offset for subtrees wrt the root
691 pos' : initialization (the last pos' before ...)
692 -> pos' list : of positions in this (sub) tree (relative to the root)
694 fun get_allp cuts (P, pos) pt =
696 val nxt = move_dn [] pt pos (*exn if Incomplete reached*)
699 then get_allp (cuts @ [nxt]) (P, nxt) pt
700 else map (apfst (curry op @ P)) (cuts @ [nxt])
702 handle PTREE _ => (map (apfst (curry op@ P)) cuts);
705 (* the pts are assumed to be on the same level *)
706 fun get_allps cuts _ [] = cuts
707 | get_allps cuts P (pt :: pts) =
709 val below = get_allp [] (P, ([], Frm)) pt
712 then (P, Pbl) :: below
713 else if last_elem P = 1
714 then (P, Frm) :: below
716 val levres = levfrm @ (if null below then [(P, Res)] else [])
718 get_allps (cuts @ levres) (lev_on P) pts
721 (** these 2 funs decide on how far cut_tree goes **)
722 (* shall the nodes _after_ the pos to be inserted at be deleted?
723 shall cutting be continued on the higher level(s)? the Nd regarded will NOT be changed *)
724 fun test_trans (PrfObj {branch, ...}) = (branch = TransitiveB orelse branch = NoBranch)
725 | test_trans (PblObj {branch, ...}) = (branch = TransitiveB orelse branch = NoBranch);
727 (* cut_bottom new sml603..608
728 cut the level at the bottom of the pos (used by cappend_...)
729 and handle the parent in order to avoid extra case for root
730 fn: ctree -> : the _whole_ ctree for cut_levup
731 pos * Pos.posel -> : the pos after split_last
732 ctree -> : the parent of the Nd to be cut
734 (ctree * : the updated ctree
735 pos' list) * : the pos's cut
736 bool : cutting shall be continued on the higher level(s)
738 fun cut_bottom _ (pt' as Nd (b, [])) = ((pt', []), test_trans b)
739 | cut_bottom (P, p) (Nd (b, bs)) =
740 let (*divide level into 3 parts...*)
741 val keep = take (p - 1, bs)
742 val pt' = case nth p bs of
744 | _ => raise ERROR "cut_bottom: uncovered case nth p bs"
745 (*^^^^^_here_ will be 'insert_pt'ed by 'append_..'*)
746 val (tail, _) = (takerest (p, bs), if null (takerest (p, bs)) then 0 else p + 1)
747 val (children, cuts) =
750 (keep, (if is_pblnd pt' then [(P @ [p], Pbl)] else [])
751 @ (get_allp [] (P @ [p], (P, Frm)) pt')
752 @ (get_allps [] (P @ [p + 1]) tail))
753 else (keep @ [(*'insert_pt'ed by 'append_..'*)] @ tail,
754 get_allp [] (P @ [p], (P, Frm)) pt')
757 then (Nd (del_res b, children), cuts @ (if g_ostate b = Incomplete then [] else [(P, Res)]))
758 else (Nd (b, children), cuts)
759 in ((pt'', cuts), test_trans b) end
760 | cut_bottom _ _ = raise ERROR "cut_bottom: uncovered fun def.";
763 (* go all levels from the bottom of 'pos' up to the root,
764 on each level compose the children of a node and accumulate the cut Nds
766 pos' list -> : for accumulation
767 bool -> : cutting shall be continued on the higher level(s)
768 ctree -> : the whole ctree for 'get_nd pt P' on each level
769 ctree -> : the Nd from the lower level for insertion at path
770 pos * Pos.posel -> : pos=path split for convenience
771 ctree -> : Nd the children of are under consideration on this call
773 ctree * pos' list : the updated parent-Nd and the pos's of the Nds cut
775 fun cut_levup (cuts:pos' list) clevup pt pt' (P:pos, p:Pos.posel) (Nd (b, bs)) =
776 let (*divide level into 3 parts...*)
777 val keep = take (p - 1, bs)
778 (*val pt' comes as argument from below*)
780 (takerest (p, bs), if null (takerest (p, bs)) then 0 else p + 1)
781 val (children, cuts') =
783 then (keep @ [pt'], get_allps [] (P @ [p+1]) tail)
784 else (keep @ [pt'] @ tail, [])
785 val clevup' = if clevup then test_trans b else false
786 (*the first Nd with false stops cutting on all levels above*)
789 then (Nd (del_res b, children), cuts' @ (if g_ostate b = Incomplete then [] else [(P, Res)]))
790 else (Nd (b, children), cuts')
793 then (pt'', cuts @ cuts')
795 let val (P, p) = split_last P
796 in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P) end
798 | cut_levup _ _ _ _ _ _ = raise ERROR "cut_levup: uncovered fun def.";
800 (* cut nodes after and below an inserted node in the ctree;
801 the cuts range is limited by the predicate 'fun cutlevup' *)
802 fun cut_tree pt (pos, _) =
803 if not (existpt pos pt)
804 then (pt, []) (*appending a formula never cuts anything*)
807 val (P, p) = split_last pos
808 val ((pt', cuts), clevup) = cut_bottom (P, p) (get_nd pt P)
809 (* pt' is the updated parent of the Nd to cappend_..*)
814 let val (P, p) = split_last P
815 in cut_levup cuts clevup pt pt' (P, p) (get_nd pt P) end
818 (* get the theory explicitly just for the rootpbl;
819 thus use this function _after_ finishing specification *)
820 fun root_thy (Nd (PblObj {spec = (thyID, _, _), ctxt, ...}, _)) = ThyC.get_theory_PIDE ctxt thyID
821 | root_thy _ = raise ERROR "root_thy: uncovered fun def.";