1.1 --- a/src/sml/FE-interface/interface.sml Mon Dec 31 09:55:43 2007 +0100
1.2 +++ b/src/sml/FE-interface/interface.sml Mon Dec 31 14:18:53 2007 +0100
1.3 @@ -239,13 +239,27 @@
1.4 @see #TACTICS_ALL
1.5 @see #TACTICS_CURRENT_THEORY
1.6 @see #TACTICS_CURRENT_METHOD ..the only impl.WN040307.*)
1.7 +(*. fetch tactics to be applied to a particular step.*)
1.8 +(* WN071231 kept this version for later parametrisation*)
1.9 +(*.version 1: fetch _all_ tactics from script .*)
1.10 fun fetchApplicableTactics cI (scope:int) (p:pos') =
1.11 (let val ((pt, _), _) = get_calc cI
1.12 in (applicabletacticsOK cI (sel_rules pt p))
1.13 handle PTREE str => sysERROR2xml cI str
1.14 end)
1.15 handle _ => sysERROR2xml cI "error in kernel";
1.16 -
1.17 +(*.version 2: fetch _applicable_ _elementary_ (ie. recursively
1.18 + decompose rule-sets) Rewrite*, Calculate .*)
1.19 +(*
1.20 +fun fetchApplicableTactics cI (scope:int) (p:pos') =
1.21 + (let val ((pt, _), _) = get_calc cI
1.22 + val alltacs = sel_rules pt p
1.23 + val tacs = @@@@@@@@@
1.24 + in (applicabletacticsOK cI tacs)
1.25 + handle PTREE str => sysERROR2xml cI str
1.26 + end)
1.27 + handle _ => sysERROR2xml cI "error in kernel";
1.28 +*)
1.29 fun getAssumptions cI (p:pos') =
1.30 (let val ((pt,_),_) = get_calc cI
1.31 val (_, _, asms) = pt_extract (pt, p)
2.1 --- a/src/sml/IsacKnowledge/PolyMinus.ML Mon Dec 31 09:55:43 2007 +0100
2.2 +++ b/src/sml/IsacKnowledge/PolyMinus.ML Mon Dec 31 14:18:53 2007 +0100
2.3 @@ -172,6 +172,26 @@
2.4 Rls_ verschoenere
2.5 ], scr = EmptyScr}:rls;
2.6
2.7 +val rls_p_33 =
2.8 + append_rls "rls_p_33" e_rls
2.9 + [Rls_ ordne_alphabetisch,
2.10 + Rls_ fasse_zusammen,
2.11 + Rls_ verschoenere
2.12 + ];
2.13 +val rls_p_34 =
2.14 + append_rls "rls_p_34" e_rls
2.15 + [Rls_ klammern_ausmultiplizieren,
2.16 + Rls_ ordne_alphabetisch,
2.17 + Rls_ fasse_zusammen,
2.18 + Rls_ verschoenere
2.19 + ];
2.20 +val rechnen =
2.21 + append_rls "rechnen" e_rls
2.22 + [Calc ("op *", eval_binop "#mult_"),
2.23 + Calc ("op +", eval_binop "#add_"),
2.24 + Calc ("op -", eval_binop "#subtr_")
2.25 + ];
2.26 +
2.27 ruleset' :=
2.28 overwritelthy thy (!ruleset',
2.29 [("ordne_alphabetisch", prep_rls ordne_alphabetisch),
2.30 @@ -278,7 +298,7 @@
2.31 (*"(~ True) = False"*)
2.32 Thm ("not_false",num_str not_false)
2.33 (*"(~ False) = True"*)],
2.34 - crls = e_rls, nrls = multipliziere_aus},
2.35 + crls = e_rls, nrls = rls_p_33},
2.36 "Script SimplifyScript (t_::real) = \
2.37 \ (((Try (Rewrite_Set ordne_alphabetisch False)) @@ \
2.38 \ (Try (Rewrite_Set fasse_zusammen False)) @@ \
2.39 @@ -296,7 +316,7 @@
2.40 prls = append_rls "simplification_for_polynomials_prls" e_rls
2.41 [(*for preds in where_*)
2.42 Calc("Poly.is'_polyexp",eval_is_polyexp"")],
2.43 - crls = e_rls, nrls = multipliziere_aus},
2.44 + crls = e_rls, nrls = rls_p_34},
2.45 "Script SimplifyScript (t_::real) = \
2.46 \ (((Try (Rewrite_Set klammern_ausmultiplizieren False)) @@ \
2.47 \ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \
2.48 @@ -324,7 +344,7 @@
2.49 e_rls [(*for preds in where_*)
2.50 Calc ("Rational.is'_ratpolyexp",
2.51 eval_is_ratpolyexp "")],
2.52 - crls = e_rls, nrls = Erls},
2.53 + crls = e_rls, nrls = rechnen},
2.54 "Script ProbeScript (e_::bool) (ws_::bool list) = \
2.55 \ (let e_ = Take e_; \
2.56 \ e_ = Substitute ws_ e_ \
3.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/src/sml/ME/ctree.sml Mon Dec 31 14:18:53 2007 +0100
3.3 @@ -0,0 +1,2162 @@
3.4 +(* use"../ME/ctree.sml";
3.5 + use"ME/ctree.sml";
3.6 + use"ctree.sml";
3.7 + W.N.26.10.99
3.8 +
3.9 +writeln (pr_ptree pr_short pt);
3.10 +
3.11 +val Nd ( _, ns) = pt;
3.12 +
3.13 +*)
3.14 +
3.15 +(*structure Ptree (**): PTREE (**) = ###### outcommented ######*)
3.16 +signature PTREE =
3.17 +sig
3.18 + type ptree
3.19 + type envp
3.20 + val e_ptree : ptree
3.21 + exception PTREE of string
3.22 + type branch
3.23 + type ostate
3.24 + type cellID
3.25 + type cid
3.26 + type posel
3.27 + type pos
3.28 + type pos'
3.29 + type loc
3.30 + type domID
3.31 + type pblID
3.32 + type metID
3.33 + type spec
3.34 + type 'a ppc
3.35 + type con
3.36 + type subs
3.37 + type subst
3.38 + type env
3.39 + type ets
3.40 + val ets2str : ets -> string
3.41 + type item
3.42 + type tac
3.43 + type tac_
3.44 + val tac_2str : tac_ -> string
3.45 + type safe
3.46 + val safe2str : safe -> string
3.47 +
3.48 + type meth
3.49 + val cappend_atomic : ptree -> pos -> loc -> cterm' -> tac
3.50 + -> cterm' -> ostate -> cid -> ptree * posel list * cid
3.51 + val cappend_form : ptree
3.52 + -> pos -> loc -> cterm' -> cid -> ptree * pos * cid
3.53 + val cappend_parent : ptree -> pos -> loc -> cterm' -> tac
3.54 + -> branch -> cid -> ptree * int list * cid
3.55 + val cappend_problem : ptree -> posel list(*FIXME*) -> loc
3.56 + -> cterm' list * spec -> cid -> ptree * int list * cellID list
3.57 + val append_result : ptree -> pos -> cterm' -> ostate -> ptree * pos
3.58 +
3.59 + type ppobj
3.60 + val g_branch : ppobj -> branch
3.61 + val g_cell : ppobj -> cid
3.62 + val g_args : ppobj -> (int * (term list)) list (*args of scr*)
3.63 + val g_form : ppobj -> cterm'
3.64 + val g_loc : ppobj -> loc
3.65 + val g_met : ppobj -> meth
3.66 + val g_domID : ppobj -> domID
3.67 + val g_metID : ppobj -> metID
3.68 + val g_model : ppobj -> cterm' ppc
3.69 + val g_tac : ppobj -> tac
3.70 + val g_origin : ppobj -> cterm' list * spec
3.71 + val g_ostate : ppobj -> ostate
3.72 + val g_pbl : ppobj -> pblID * item ppc
3.73 + val g_result : ppobj -> cterm'
3.74 + val g_spec : ppobj -> spec
3.75 +(* val get_all : (ppobj -> 'a) -> ptree -> 'a list
3.76 + val get_alls : (ppobj -> 'a) -> ptree list -> 'a list *)
3.77 + val get_obj : (ppobj -> 'a) -> ptree -> pos -> 'a
3.78 + val gpt_cell : ptree -> cid
3.79 + val par_pblobj : ptree -> pos -> pos
3.80 + val pre_pos : pos -> pos
3.81 + val lev_dn : int list -> int list
3.82 + val lev_on : pos -> posel list
3.83 + val lev_pred : pos -> pos
3.84 + val lev_up : pos -> pos
3.85 +(* val pr_cell : pos -> ppobj -> string
3.86 + val pr_pos : int list -> string *)
3.87 + val pr_ptree : (pos -> ppobj -> string) -> ptree -> string
3.88 + val pr_short : pos -> ppobj -> string
3.89 +(* val repl : 'a list -> int -> 'a -> 'a list
3.90 + val repl_app : 'a list -> int -> 'a -> 'a list
3.91 + val repl_branch : branch -> ppobj -> ppobj
3.92 + val repl_domID : domID -> ppobj -> ppobj
3.93 + val repl_form : cterm' -> ppobj -> ppobj
3.94 + val repl_met : item ppc -> ppobj -> ppobj
3.95 + val repl_metID : metID -> ppobj -> ppobj
3.96 + val repl_model : cterm' list -> ppobj -> ppobj
3.97 + val repl_tac : tac -> ppobj -> ppobj
3.98 + val repl_pbl : item ppc -> ppobj -> ppobj
3.99 + val repl_pblID : pblID -> ppobj -> ppobj
3.100 + val repl_result : cterm' -> ostate -> ppobj -> ppobj
3.101 + val repl_spec : spec -> ppobj -> ppobj
3.102 + val repl_subs : (string * string) list -> ppobj -> ppobj *)
3.103 + val rootthy : ptree -> domID
3.104 +(* val test_trans : ppobj -> bool
3.105 + val uni__asm : (string * pos) list -> ppobj -> ppobj
3.106 + val uni__cid : cellID list -> ppobj -> ppobj *)
3.107 + val union_asm : ptree -> pos -> (string * pos) list -> ptree
3.108 + val union_cid : ptree -> pos -> cellID list -> ptree
3.109 + val update_branch : ptree -> pos -> branch -> ptree
3.110 + val update_domID : ptree -> pos -> domID -> ptree
3.111 + val update_met : ptree -> pos -> meth -> ptree
3.112 + val update_metppc : ptree -> pos -> item ppc -> ptree
3.113 + val update_metID : ptree -> pos -> metID -> ptree
3.114 + val update_tac : ptree -> pos -> tac -> ptree
3.115 + val update_pbl : ptree -> pos -> pblID * item ppc -> ptree
3.116 + val update_pblppc : ptree -> pos -> item ppc -> ptree
3.117 + val update_pblID : ptree -> pos -> pblID -> ptree
3.118 + val update_spec : ptree -> pos -> spec -> ptree
3.119 + val update_subs : ptree -> pos -> (string * string) list -> ptree
3.120 +
3.121 + val rep_pblobj : ppobj
3.122 + -> {branch:branch, cell:cid, env:envp, loc:loc, meth:meth, model:cterm' ppc,
3.123 + origin:cterm' list * spec, ostate:ostate, probl:pblID * item ppc,
3.124 + result:cterm', spec:spec}
3.125 + val rep_prfobj : ppobj
3.126 + -> {branch:branch, cell:cid, form:cterm', loc:loc, tac:tac,
3.127 + ostate:ostate, result:cterm'}
3.128 +end
3.129 +
3.130 +(* --------------
3.131 +structure Ptree (**): PTREE (**) =
3.132 +struct
3.133 + -------------- *)
3.134 +
3.135 +type env = (term * term) list;
3.136 +
3.137 +
3.138 +datatype branch =
3.139 + NoBranch | AndB | OrB
3.140 + | TransitiveB (* FIXXXME.8.03: set branch from met in Apply_Method
3.141 + FIXXXME.0402: -"- in Begin_Trans'*)
3.142 + | SequenceB | IntersectB | CollectB | MapB;
3.143 +fun branch2str NoBranch = "NoBranch"
3.144 + | branch2str AndB = "AndB"
3.145 + | branch2str OrB = "OrB"
3.146 + | branch2str TransitiveB = "TransitiveB"
3.147 + | branch2str SequenceB = "SequenceB"
3.148 + | branch2str IntersectB = "IntersectB"
3.149 + | branch2str CollectB = "CollectB"
3.150 + | branch2str MapB = "MapB";
3.151 +
3.152 +datatype ostate =
3.153 + Incomplete | Complete | Inconsistent(*WN041020 latter unused*);
3.154 +fun ostate2str Incomplete = "Incomplete"
3.155 + | ostate2str Complete = "Complete"
3.156 + | ostate2str Inconsistent = "Inconsistent";
3.157 +
3.158 +type cellID = int;
3.159 +type cid = cellID list;
3.160 +
3.161 +type posel = int; (* roundabout for (some of) nice signatures *)
3.162 +type pos = posel list;
3.163 +val pos2str = ints2str';
3.164 +datatype pos_ =
3.165 + Pbl (*PblObj-position: problem-type*)
3.166 + | Met (*PblObj-position: method*)
3.167 + | Frm (*PblObj-position: -> Pbl in ME (not by moveDown !)
3.168 + | PrfObj-position: formula*)
3.169 + | Res (*PblObj | PrfObj-position: result*)
3.170 + | Und; (*undefined*)
3.171 +fun pos_2str Pbl = "Pbl"
3.172 + | pos_2str Met = "Met"
3.173 + | pos_2str Frm = "Frm"
3.174 + | pos_2str Res = "Res"
3.175 + | pos_2str Und = "Und";
3.176 +
3.177 +type pos' = pos * pos_;
3.178 +(*WN.12.03 remembering interator (pos * pos_) for ptree
3.179 + pos : lev_on, lev_dn, lev_up,
3.180 + lev_onFrm, lev_dnRes (..see solve Apply_Method !)
3.181 + pos_:
3.182 +# generate1 sets pos_ if possible ...?WN0502?NOT...
3.183 +# generate1 does NOT set pos, because certain nodes can be lev_on OR lev_dn
3.184 + exceptions: Begin/End_Trans
3.185 +# thus generate(1) called in
3.186 +.# assy, locate_gen
3.187 +.# nxt_solv (tac_ -cases); general case:
3.188 + val pos' = case pos' of (p,Res) => (lev_on p',Res) | _ => pos'
3.189 +# WN050220, S(604):
3.190 + generate1...(Rewrite(f,..,res))..(pos, pos_)
3.191 + cappend_atomic.................pos ////// gets f+res always!!!
3.192 + cut_tree....................pos, pos_
3.193 +*)
3.194 +fun pos'2str (p,p_) = pair2str (ints2str' p, pos_2str p_);
3.195 +fun pos's2str ps = (strs2str' o (map pos'2str)) ps;
3.196 +val e_pos' = ([],Und):pos';
3.197 +
3.198 +fun res2str (t, ts) = pair2str (term2str t, terms2str ts);
3.199 +fun asm2str (t, p:pos) = pair2str (term2str t, ints2str' p);
3.200 +fun asms2str asms = (strs2str' o (map asm2str)) asms;
3.201 +
3.202 +
3.203 +
3.204 +(*26.4.02: never used after introduction of scripts !!!
3.205 +type loc = loc_ * (* + interpreter-state *)
3.206 + (loc_ * rls') (* -"- for script of the ruleset*)
3.207 + option;
3.208 +val e_loc = ([],None):loc;
3.209 +val ee_loc = (e_loc,e_loc);*)
3.210 +
3.211 +
3.212 +datatype safe = Sundef | Safe | Unsafe | Helpless;
3.213 +fun safe2str Sundef = "Sundef"
3.214 + | safe2str Safe = "Safe"
3.215 + | safe2str Unsafe = "Unsafe"
3.216 + | safe2str Helpless = "Helpless";
3.217 +
3.218 +type subs = cterm' list; (*16.11.00 for FE-KE*)
3.219 +val e_subs = ["(bdv, x)"];
3.220 +
3.221 +(*._sub_stitution as strings of _e_qualities.*)
3.222 +type sube = cterm' list;
3.223 +val e_sube = []:cterm' list;
3.224 +fun sube2str s = strs2str s;
3.225 +
3.226 +(*._sub_stitution as _t_erms of _e_qualities.*)
3.227 +type subte = term list;
3.228 +val e_subte = []:term list;
3.229 +fun subte2str ss = terms2str ss;
3.230 +
3.231 +fun subte2sube ss = map term2str ss;
3.232 +
3.233 +(*fun subst2str' thy' (s:subst) =
3.234 + (strs2str o
3.235 + (map (pair2str o
3.236 + (apsnd (Sign.string_of_term (sign_of (assoc_thy thy')))) o
3.237 + (apfst (Sign.string_of_term (sign_of (assoc_thy thy'))))))) s;*)
3.238 +fun subst2subs s = map (pair2str o
3.239 + (apfst (Sign.string_of_term (sign_of thy))) o
3.240 + (apsnd (Sign.string_of_term (sign_of thy)))) s;
3.241 +fun subst2subs' s = map ((apfst (Sign.string_of_term (sign_of thy))) o
3.242 + (apsnd (Sign.string_of_term (sign_of thy)))) s;
3.243 +fun subs2subst thy s = map (isapair2pair o term_of o the o (parse thy)) s;
3.244 +(*> subs2subst thy ["(bdv,x)","(err,#0)"];
3.245 +val it =
3.246 + [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real")),
3.247 + (Free ("err","RealDef.real"),Free ("#0","RealDef.real"))]
3.248 + : (term * term) list*)
3.249 +fun sube2subte ss = map str2term ss;
3.250 +
3.251 +
3.252 +fun isasub2subst isasub = ((map isapair2pair) o isalist2list) isasub;
3.253 +
3.254 +
3.255 +type scrstate = (*state for script interpreter*)
3.256 + env(*stack*) (*used to instantiate tac for checking assod
3.257 + 12.03.noticed: e_ not updated during execution ?!?*)
3.258 + * loc_ (*location of tac in script*)
3.259 + * term option(*argument of curried functions*)
3.260 + * term (*value obtained by tac executed
3.261 + updated also after a derivation by 'new_val'*)
3.262 + * safe (*estimation of how result will be obtained*)
3.263 + * bool; (*true = strongly .., false = weakly associated:
3.264 + only used during ass_dn/up*)
3.265 +val e_scrstate = ([],[],None,e_term,Sundef,false):scrstate;
3.266 +
3.267 +
3.268 +(*21.8.02 ---> definitions.sml for datatype scr
3.269 +type rrlsstate = (*state for reverse rewriting*)
3.270 + (term * (*the current formula*)
3.271 + rule list (*of reverse rewrite set (#1#)*)
3.272 + list * (*may be serveral, eg. in norm_rational*)
3.273 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
3.274 + (term * (*... rewrite with ...*)
3.275 + term list)) (*... assumptions*)
3.276 + list); (*derivation from given term to normalform
3.277 + in reverse order with sym_thm;
3.278 + (#1#) could be extracted from here #1*) --------*)
3.279 +
3.280 +datatype istate = (*interpreter state*)
3.281 + Uistate (*undefined in modspec, in '_deriv'ation*)
3.282 + | ScrState of scrstate (*for script interpreter*)
3.283 + | RrlsState of rrlsstate; (*for reverse rewriting*)
3.284 +val e_istate = (ScrState ([],[],None,e_term,Sundef,false)):istate;
3.285 +
3.286 +type iist = istate option * istate option;
3.287 +(*val e_iist = (e_istate, e_istate); --- sinnlos f"ur NICHT-equality-type*)
3.288 +
3.289 +
3.290 +fun rta2str (r,(t,a)) = "\n("^(rule2str r)^",("^(term2str t)^", "^
3.291 + (terms2str a)^"))";
3.292 +fun istate2str Uistate = "Uistate"
3.293 + | istate2str (ScrState (e,l,to,t,s,b):istate) =
3.294 + "ScrState ("^ subst2str e ^",\n "^
3.295 + loc_2str l ^", "^ termopt2str to ^",\n "^
3.296 + term2str t ^", "^ safe2str s ^", "^ bool2str b ^")"
3.297 + | istate2str (RrlsState (t,t1,rss,rtas)) =
3.298 + "RrlsState ("^(term2str t)^", "^(term2str t1)^", "^
3.299 + ((strs2str o (map (strs2str o (map rule2str)))) rss)^", "^
3.300 + ((strs2str o (map rta2str)) rtas)^")";
3.301 +fun istates2str (None, None) = "(#None, #None)"
3.302 + | istates2str (None, Some ist) = "(#None,\n#Some "^istate2str ist^")"
3.303 + | istates2str (Some ist, None) = "(#Some "^istate2str ist^",\n #None)"
3.304 + | istates2str (Some i1, Some i2) = "(#Some "^istate2str i1^",\n #Some "^
3.305 + istate2str i2^")";
3.306 +
3.307 +fun new_val v (ScrState (env, loc_, topt, _, safe, bool)) =
3.308 + (ScrState (env, loc_, topt, v, safe, bool))
3.309 + | new_val _ _ = raise error "new_val: only for ScrState";
3.310 +
3.311 +datatype con = land | lor;
3.312 +
3.313 +
3.314 +type spec =
3.315 + domID * (*WN.12.03: is replaced by thy from get_met ?FIXME? in:
3.316 + specify (Init_Proof..), nxt_specify_init_calc,
3.317 + assod (.SubProblem...), stac2tac (.SubProblem...)*)
3.318 + pblID *
3.319 + metID;
3.320 +fun spec2str ((dom,pbl,met)(*:spec*)) =
3.321 + "(" ^ (quote dom) ^ ", " ^ (strs2str pbl) ^
3.322 + ", " ^ (strs2str met) ^ ")";
3.323 +(*> spec2str empty_spec;
3.324 +val it = "(\"\", [], (\"\", \"\"))" : string *)
3.325 +val empty_spec = (e_domID,e_pblID,e_metID):spec;
3.326 +val e_spec = empty_spec;
3.327 +
3.328 +
3.329 +
3.330 +(*.tactics propagate the construction of the calc-tree;
3.331 + there are
3.332 + (a) 'specsteps' for the specify-phase, and others for the solve-phase
3.333 + (b) those of the solve-phase are 'initac's and others;
3.334 + initacs start with a formula different from the preceding formula.
3.335 + see 'type tac_' for the internal representation of tactics.*)
3.336 +datatype tac =
3.337 + Init_Proof of ((cterm' list) * spec)
3.338 +(*'specsteps'...*)
3.339 +| Model_Problem
3.340 +| Refine_Problem of pblID | Refine_Tacitly of pblID
3.341 +
3.342 +| Add_Given of cterm' | Del_Given of cterm'
3.343 +| Add_Find of cterm' | Del_Find of cterm'
3.344 +| Add_Relation of cterm' | Del_Relation of cterm'
3.345 +
3.346 +| Specify_Theory of domID | Specify_Problem of pblID
3.347 +| Specify_Method of metID
3.348 +(*...'specsteps'*)
3.349 +| Apply_Method of metID
3.350 +(*.creates an 'istate' in PblObj.env; in case of 'init_form'
3.351 + creates a formula at ((lev_on o lev_dn) p, Frm) and in this ppobj.'loc'
3.352 + 'Some istate' (at fst of 'loc').
3.353 + As each step (in the solve-phase) has a resulting formula (at the front-end)
3.354 + Apply_Method also does the 1st step in the script (an 'initac') if there
3.355 + is no 'init_form' .*)
3.356 +| Check_Postcond of pblID
3.357 +| Free_Solve
3.358 +
3.359 +| Rewrite_Inst of ( subs * thm') | Rewrite of thm'
3.360 + | Rewrite_Asm of thm'
3.361 +| Rewrite_Set_Inst of ( subs * rls') | Rewrite_Set of rls'
3.362 +| Detail_Set_Inst of ( subs * rls') | Detail_Set of rls'
3.363 +| End_Detail (*end of script from next_tac,
3.364 + in solve: switches back to parent script WN0509 drop!*)
3.365 +| Derive of rls' (*an input formula using rls WN0509 drop!*)
3.366 +| Calculate of string (* plus | minus | times | cancel | pow | sqrt *)
3.367 +| End_Ruleset
3.368 +| Substitute of sube | Apply_Assumption of cterm' list
3.369 +
3.370 +| Take of cterm' (*an 'initac'*)
3.371 +| Take_Inst of cterm'
3.372 +| Group of (con * int list )
3.373 +| Subproblem of (domID * pblID) (*an 'initac'*)
3.374 +| CAScmd of cterm' (*6.6.02 URD: Function formula; WN0509 drop!*)
3.375 +| End_Subproblem (*WN0509 drop!*)
3.376 +
3.377 +| Split_And | Conclude_And
3.378 +| Split_Or | Conclude_Or
3.379 +| Begin_Trans | End_Trans
3.380 +| Begin_Sequ | End_Sequ(* substitute root.env *)
3.381 +| Split_Intersect | End_Intersect
3.382 +| Check_elementwise of cterm' | Collect_Trues
3.383 +| Or_to_List
3.384 +
3.385 +| Empty_Tac (*TODO.11.6.03 ... of string: could carry msg of (Notappl msg)
3.386 + in 'helpless'*)
3.387 +| Tac of string(* eg.'repeat'*WN0509 drop!*)
3.388 +| User (*internal, for ets*WN0509 drop!*)
3.389 +| End_Proof';(* inout*)
3.390 +
3.391 +(* tac2str /--> library.sml: needed in dialog.sml for 'separable *)
3.392 +fun tac2str (ma:tac) = case ma of
3.393 + Init_Proof (ppc, spec) =>
3.394 + "Init_Proof "^(pair2str (strs2str ppc, spec2str spec))
3.395 + | Model_Problem => "Model_Problem "
3.396 + | Refine_Tacitly pblID => "Refine_Tacitly "^(strs2str pblID)
3.397 + | Refine_Problem pblID => "Refine_Problem "^(strs2str pblID)
3.398 + | Add_Given cterm' => "Add_Given "^cterm'
3.399 + | Del_Given cterm' => "Del_Given "^cterm'
3.400 + | Add_Find cterm' => "Add_Find "^cterm'
3.401 + | Del_Find cterm' => "Del_Find "^cterm'
3.402 + | Add_Relation cterm' => "Add_Relation "^cterm'
3.403 + | Del_Relation cterm' => "Del_Relation "^cterm'
3.404 +
3.405 + | Specify_Theory domID => "Specify_Theory "^(quote domID )
3.406 + | Specify_Problem pblID => "Specify_Problem "^(strs2str pblID )
3.407 + | Specify_Method metID => "Specify_Method "^(strs2str metID)
3.408 + | Apply_Method metID => "Apply_Method "^(strs2str metID)
3.409 + | Check_Postcond pblID => "Check_Postcond "^(strs2str pblID)
3.410 + | Free_Solve => "Free_Solve"
3.411 +
3.412 + | Rewrite_Inst (subs,thm')=>
3.413 + "Rewrite_Inst "^(pair2str (subs2str subs, spair2str thm'))
3.414 + | Rewrite thm' => "Rewrite "^(spair2str thm')
3.415 + | Rewrite_Asm thm' => "Rewrite_Asm "^(spair2str thm')
3.416 + | Rewrite_Set_Inst (subs, rls) =>
3.417 + "Rewrite_Set_Inst "^(pair2str (subs2str subs, quote rls))
3.418 + | Rewrite_Set rls => "Rewrite_Set "^(quote rls )
3.419 + | Detail_Set rls => "Detail_Set "^(quote rls )
3.420 + | Detail_Set_Inst (subs, rls) =>
3.421 + "Detail_Set_Inst "^(pair2str (subs2str subs, quote rls))
3.422 + | End_Detail => "End_Detail"
3.423 + | Derive rls' => "Derive "^rls'
3.424 + | Calculate op_ => "Calculate "^op_
3.425 + | Substitute sube => "Substitute "^sube2str sube
3.426 + | Apply_Assumption ct's => "Apply_Assumption "^(strs2str ct's)
3.427 +
3.428 + | Take cterm' => "Take "^(quote cterm' )
3.429 + | Take_Inst cterm' => "Take_Inst "^(quote cterm' )
3.430 + | Group (con, ints) =>
3.431 + "Group "^(pair2str (con2str con, ints2str ints))
3.432 + | Subproblem (domID, pblID) =>
3.433 + "Subproblem "^(pair2str (domID, strs2str pblID))
3.434 +(*| Subproblem_Full (spec, cts') =>
3.435 + "Subproblem_Full "^(pair2str (spec2str spec, strs2str cts'))*)
3.436 + | End_Subproblem => "End_Subproblem"
3.437 + | CAScmd cterm' => "CAScmd "^(quote cterm')
3.438 +
3.439 + | Check_elementwise cterm'=> "Check_elementwise "^(quote cterm')
3.440 + | Or_to_List => "Or_to_List "
3.441 + | Collect_Trues => "Collect_Trues"
3.442 +
3.443 + | Empty_Tac => "Empty_Tac"
3.444 + | Tac string => "Tac "^string
3.445 + | User => "User"
3.446 + | End_Proof' => "tac End_Proof'"
3.447 + | _ => "tac2str not impl. for ?!";
3.448 +
3.449 +fun is_rewset (Rewrite_Set_Inst _) = true
3.450 + | is_rewset (Rewrite_Set _) = true
3.451 + | is_rewset _ = false;
3.452 +fun is_rewtac (Rewrite _) = true
3.453 + | is_rewtac (Rewrite_Inst _) = true
3.454 + | is_rewtac (Rewrite_Asm _) = true
3.455 + | is_rewtac tac = is_rewset tac;
3.456 +
3.457 +fun tac2IDstr (ma:tac) = case ma of
3.458 + Model_Problem => "Model_Problem"
3.459 + | Refine_Tacitly pblID => "Refine_Tacitly"
3.460 + | Refine_Problem pblID => "Refine_Problem"
3.461 + | Add_Given cterm' => "Add_Given"
3.462 + | Del_Given cterm' => "Del_Given"
3.463 + | Add_Find cterm' => "Add_Find"
3.464 + | Del_Find cterm' => "Del_Find"
3.465 + | Add_Relation cterm' => "Add_Relation"
3.466 + | Del_Relation cterm' => "Del_Relation"
3.467 +
3.468 + | Specify_Theory domID => "Specify_Theory"
3.469 + | Specify_Problem pblID => "Specify_Problem"
3.470 + | Specify_Method metID => "Specify_Method"
3.471 + | Apply_Method metID => "Apply_Method"
3.472 + | Check_Postcond pblID => "Check_Postcond"
3.473 + | Free_Solve => "Free_Solve"
3.474 +
3.475 + | Rewrite_Inst (subs,thm')=> "Rewrite_Inst"
3.476 + | Rewrite thm' => "Rewrite"
3.477 + | Rewrite_Asm thm' => "Rewrite_Asm"
3.478 + | Rewrite_Set_Inst (subs, rls) => "Rewrite_Set_Inst"
3.479 + | Rewrite_Set rls => "Rewrite_Set"
3.480 + | Detail_Set rls => "Detail_Set"
3.481 + | Detail_Set_Inst (subs, rls) => "Detail_Set_Inst"
3.482 + | Derive rls' => "Derive "
3.483 + | Calculate op_ => "Calculate "
3.484 + | Substitute subs => "Substitute"
3.485 + | Apply_Assumption ct's => "Apply_Assumption"
3.486 +
3.487 + | Take cterm' => "Take"
3.488 + | Take_Inst cterm' => "Take_Inst"
3.489 + | Group (con, ints) => "Group"
3.490 + | Subproblem (domID, pblID) => "Subproblem"
3.491 + | End_Subproblem => "End_Subproblem"
3.492 + | CAScmd cterm' => "CAScmd"
3.493 +
3.494 + | Check_elementwise cterm'=> "Check_elementwise"
3.495 + | Or_to_List => "Or_to_List "
3.496 + | Collect_Trues => "Collect_Trues"
3.497 +
3.498 + | Empty_Tac => "Empty_Tac"
3.499 + | Tac string => "Tac "
3.500 + | User => "User"
3.501 + | End_Proof' => "End_Proof'"
3.502 + | _ => "tac2str not impl. for ?!";
3.503 +
3.504 +fun rls_of (Rewrite_Set_Inst (_, rls)) = rls
3.505 + | rls_of (Rewrite_Set rls) = rls
3.506 + | rls_of tac = raise error ("rls_of: called with tac '"^tac2IDstr tac^"'");
3.507 +
3.508 +fun thm_of_rew (Rewrite_Inst (subs,(thmID,_))) =
3.509 + (thmID, Some ((subs2subst (assoc_thy "Isac.thy") subs):subst))
3.510 + | thm_of_rew (Rewrite (thmID,_)) = (thmID, None)
3.511 + | thm_of_rew (Rewrite_Asm (thmID,_)) = (thmID, None);
3.512 +
3.513 +fun rls_of_rewset (Rewrite_Set_Inst (subs,rls)) =
3.514 + (rls, Some ((subs2subst (assoc_thy "Isac.thy") subs):subst))
3.515 + | rls_of_rewset (Rewrite_Set rls) = (rls, None)
3.516 + | rls_of_rewset (Detail_Set rls) = (rls, None)
3.517 + | rls_of_rewset (Detail_Set_Inst (subs, rls)) =
3.518 + (rls, Some ((subs2subst (assoc_thy "Isac.thy") subs):subst));
3.519 +
3.520 +(*fun rule2tac (Thm (thmID, thm)) =
3.521 + Rewrite (thmID, string_of_thmI thm)
3.522 + | rule2tac (Rls_ rls) = Rewrite_Set (id_rls rls)
3.523 + | rule2tac (Rls_ rls) = Rewrite_Set (id_rls rls)
3.524 + | rule2tac rule =
3.525 + raise error ("rule2tac: called with '" ^ rule2str rule ^ "'");
3.526 +WN071231*)
3.527 +fun rule2tac _ (Calc (opID, thm)) = Calculate opID
3.528 + | rule2tac [] (Thm (thmID, thm)) = Rewrite (thmID, string_of_thmI thm)
3.529 + | rule2tac subst (Thm (thmID, thm)) =
3.530 + Rewrite_Inst (subst2subs subst, (thmID, string_of_thmI thm))
3.531 + | rule2tac [] (Rls_ rls) = Rewrite_Set (id_rls rls)
3.532 + | rule2tac subst (Rls_ rls) =
3.533 + Rewrite_Set_Inst (subst2subs subst, (id_rls rls))
3.534 + | rule2tac _ rule =
3.535 + raise error ("rule2tac: called with '" ^ rule2str rule ^ "'");
3.536 +
3.537 +
3.538 +type fmz_ = cterm' list;
3.539 +
3.540 +(*.a formalization of an example containing data
3.541 + sufficient for mechanically finding the solution for the example.*)
3.542 +(*FIXME.WN051014: dont store fmz = (_,spec) in the PblObj,
3.543 + this is done in origin*)
3.544 +type fmz = fmz_ * spec;
3.545 +val e_fmz = ([],e_spec);
3.546 +
3.547 +(*tac_ is made from tac in applicable_in,
3.548 + and carries all data necessary for generate;*)
3.549 +datatype tac_ =
3.550 +(* datatype tac = *)
3.551 + Init_Proof' of ((cterm' list) * spec)
3.552 + (* ori list !: code specify -> applicable*)
3.553 +| Model_Problem' of pblID *
3.554 + itm list * (*the 'untouched' pbl*)
3.555 + itm list (*the casually completed met*)
3.556 +| Refine_Tacitly' of pblID * (*input*)
3.557 + pblID * (*the refined from applicable_in*)
3.558 + domID * (*from new pbt?! filled in specify*)
3.559 + metID * (*from new pbt?! filled in specify*)
3.560 + itm list (*drop ! 9.03: remains [] for
3.561 + Model_Problem recognizing its activation*)
3.562 +| Refine_Problem' of (pblID * (itm list * (bool * Term.term) list))
3.563 + (*FIXME?040215 drop: done automatically in init_proof + Subproblem'*)
3.564 +| Add_Given' of cterm' *
3.565 + itm list (*updated with input in fun specify_additem*)
3.566 +| Add_Find' of cterm' *
3.567 + itm list (*updated with input in fun specify_additem*)
3.568 +| Add_Relation' of cterm' *
3.569 + itm list (*updated with input in fun specify_additem*)
3.570 +| Del_Given' of cterm' | Del_Find' of cterm' | Del_Relation' of cterm'
3.571 + (*4.00.: all.. term: in applicable_in ..? Syn ?only for FormFK?*)
3.572 +
3.573 +| Specify_Theory' of domID
3.574 +| Specify_Problem' of (pblID * (* *)
3.575 + (bool * (* matches *)
3.576 + (itm list * (* ppc *)
3.577 + (bool * term) list))) (* preconditions *)
3.578 +| Specify_Method' of metID *
3.579 + ori list * (*repl. "#undef"*)
3.580 + itm list (*... updated from pbl to met*)
3.581 +| Apply_Method' of metID *
3.582 + (term option) * (*init_form*)
3.583 + istate
3.584 +| Check_Postcond' of
3.585 + pblID *
3.586 + (term * (*returnvalue of script in solve*)
3.587 + cterm' list)(*collect by get_assumptions_ in applicable_in, except if
3.588 + butlast tac is Check_elementwise: take only these asms*)
3.589 +| Free_Solve'
3.590 +
3.591 +| Rewrite_Inst' of theory' * rew_ord' * rls
3.592 + * bool * subst * thm' * term * (term * term list)
3.593 +| Rewrite' of theory' * rew_ord' * rls * bool * thm' *
3.594 + term * (term * term list)
3.595 +| Rewrite_Asm' of theory' * rew_ord' * rls * bool * thm' *
3.596 + term * (term * term list)
3.597 +| Rewrite_Set_Inst' of theory' * bool * subst * rls *
3.598 + term * (term * term list)
3.599 +| Detail_Set_Inst' of theory' * bool * subst * rls *
3.600 + term * (term * term list)
3.601 +| Rewrite_Set' of theory' * bool * rls * term * (term * term list)
3.602 +| Detail_Set' of theory' * bool * rls * term * (term * term list)
3.603 +| End_Detail' of (term * (term list)) (*see End_Trans'*)
3.604 +| End_Ruleset' of term
3.605 +| Derive' of rls
3.606 +| Calculate' of theory' * string * term * (term * thm')
3.607 + (*WN.29.4.03 asm?: * term list??*)
3.608 +| Substitute' of subte (*the 'substitution': terms of type bool*)
3.609 + * term (*to be substituted in*)
3.610 + * term (*resulting from the substitution*)
3.611 +| Apply_Assumption' of term list * term
3.612 +
3.613 +| Take' of term | Take_Inst' of term
3.614 +| Group' of (con * int list * term)
3.615 +| Subproblem' of (spec *
3.616 + (ori list) * (*filled in assod Subproblem'*)
3.617 + term * (*-"-, headline of calc-head *)
3.618 + fmz_ *
3.619 + term) (*Subproblem(dom,pbl)*)
3.620 +| CAScmd' of term
3.621 +| End_Subproblem' of term (*???*)
3.622 +| Split_And' of term | Conclude_And' of term
3.623 +| Split_Or' of term | Conclude_Or' of term
3.624 +| Begin_Trans' of term | End_Trans' of (term * (term list))
3.625 +| Begin_Sequ' | End_Sequ'(* substitute root.env*)
3.626 +| Split_Intersect' of term | End_Intersect' of term
3.627 +| Check_elementwise' of (*special case:*)
3.628 + term * (*(1)the current formula: [x=1,x=...]*)
3.629 + string * (*(2)the pred from Check_elementwise *)
3.630 + (term * (*(3)composed from (1) and (2): {x. pred}*)
3.631 + term list) (*20.5.03 assumptions*)
3.632 +
3.633 +| Or_to_List' of term * term (* (a | b, [a,b]) *)
3.634 +| Collect_Trues' of term
3.635 +
3.636 +| Empty_Tac_ | Tac_ of (*for dummies*)
3.637 + theory *
3.638 + string * (*form*)
3.639 + string * (*in Tac*)
3.640 + string (*result of Tac".."*)
3.641 +| User' (*internal for ets*) | End_Proof'';(*End_Proof:inout*)
3.642 +
3.643 +fun tac_2str ma = case ma of
3.644 + Init_Proof' (ppc, spec) =>
3.645 + "Init_Proof' "^(pair2str (strs2str ppc, spec2str spec))
3.646 + | Model_Problem' (pblID,_,_) => "Model_Problem' "^(strs2str pblID )
3.647 + | Refine_Tacitly'(p,prefin,domID,metID,itms)=>
3.648 + "Refine_Tacitly' ("
3.649 + ^(strs2str p)^", "^(strs2str prefin)^", "
3.650 + ^domID^", "^(strs2str metID)^", pbl-itms)"
3.651 + | Refine_Problem' ms => "Refine_Problem' ("^(*matchs2str ms*)"..."^")"
3.652 +(*| Match_Problem' (pI, (ok, (itms, pre))) =>
3.653 + "Match_Problem' "^(spair2str (strs2str pI,
3.654 + spair2str (bool2str ok,
3.655 + spair2str ("itms2str itms",
3.656 + "items2str pre"))))*)
3.657 + | Add_Given' cterm' => "Add_Given' "(*^cterm'*)
3.658 + | Del_Given' cterm' => "Del_Given' "(*^cterm'*)
3.659 + | Add_Find' cterm' => "Add_Find' "(*^cterm'*)
3.660 + | Del_Find' cterm' => "Del_Find' "(*^cterm'*)
3.661 + | Add_Relation' cterm' => "Add_Relation' "(*^cterm'*)
3.662 + | Del_Relation' cterm' => "Del_Relation' "(*^cterm'*)
3.663 +
3.664 + | Specify_Theory' domID => "Specify_Theory' "^(quote domID )
3.665 + | Specify_Problem' (pI, (ok, (itms, pre))) =>
3.666 + "Specify_Problem' "^(spair2str (strs2str pI,
3.667 + spair2str (bool2str ok,
3.668 + spair2str ("itms2str itms",
3.669 + "items2str pre"))))
3.670 + | Specify_Method' (pI,oris,itms) =>
3.671 + "Specify_Method' ("^metID2str pI^", "^oris2str oris^", )"
3.672 +
3.673 + | Apply_Method' (metID,_,_) => "Apply_Method' "^(strs2str metID)
3.674 + | Check_Postcond' (pblID,(scval,asm)) =>
3.675 + "Check_Postcond' "^(spair2str(strs2str pblID,
3.676 + spair2str (term2str scval, strs2str asm)))
3.677 +
3.678 + | Free_Solve' => "Free_Solve'"
3.679 +
3.680 + | Rewrite_Inst' (*subs,thm'*) _ =>
3.681 + "Rewrite_Inst' "(*^(pair2str (subs2str subs, spair2str thm'))*)
3.682 + | Rewrite' thm' => "Rewrite' "(*^(spair2str thm')*)
3.683 + | Rewrite_Asm' thm' => "Rewrite_Asm' "(*^(spair2str thm')*)
3.684 + | Rewrite_Set_Inst' (*subs,thm'*) _ =>
3.685 + "Rewrite_Set_Inst' "(*^(pair2str (subs2str subs, quote rls))*)
3.686 + | Rewrite_Set'(thy',pasm,rls',f,(f',asm))
3.687 + => "Rewrite_Set' ("^thy'^","^(bool2str pasm)^","^(id_rls rls')^","
3.688 + ^(Sign.string_of_term (sign_of thy) f)^",("^(Sign.string_of_term (sign_of thy) f')
3.689 + ^","^((strs2str o (map (Sign.string_of_term (sign_of thy)))) asm)^"))"
3.690 +
3.691 + | End_Detail' _ => "End_Detail' xxx"
3.692 + | Detail_Set' _ => "Detail_Set' xxx"
3.693 + | Detail_Set_Inst' _ => "Detail_Set_Inst' xxx"
3.694 +
3.695 + | Derive' rls => "Derive' "^id_rls rls
3.696 + | Calculate' _ => "Calculate' "
3.697 + | Substitute' subs => "Substitute' "(*^(subs2str subs)*)
3.698 + | Apply_Assumption' ct's => "Apply_Assumption' "(*^(strs2str ct's)*)
3.699 +
3.700 + | Take' cterm' => "Take' "(*^(quote cterm' )*)
3.701 + | Take_Inst' cterm' => "Take_Inst' "(*^(quote cterm' )*)
3.702 + | Group' (con, ints, _) =>
3.703 + "Group' "^(pair2str (con2str con, ints2str ints))
3.704 + | Subproblem' (spec, oris, _,_,pbl_form) =>
3.705 + "Subproblem' "(*^(pair2str (domID, strs2str ,...))*)
3.706 + | End_Subproblem' _ => "End_Subproblem'"
3.707 + | CAScmd' cterm' => "CAScmd' "(*^(quote cterm')*)
3.708 +
3.709 + | Empty_Tac_ => "Empty_Tac_"
3.710 + | User' => "User'"
3.711 + | Tac_ (_,form,id,result) => "Tac_ (thy,"^form^","^id^","^result^")"
3.712 + | _ => "tac_2str not impl. for arg";
3.713 +
3.714 +(*'executed tactics' (tac_s) with local environment etc.;
3.715 + used for continuing eval script + for generate*)
3.716 +type ets =
3.717 + (loc_ * (* of tactic in scr, tactic (weakly) associated with tac_*)
3.718 + (tac_ * (* (for generate) *)
3.719 + env * (* with 'tactic=result' as a rule, tactic ev. _not_ ready:
3.720 + for handling 'parallel let'*)
3.721 + env * (* with results of (ready) tacs *)
3.722 + term * (* itr_arg of tactic, for upd. env at Repeat, Try*)
3.723 + term * (* result value of the tac *)
3.724 + safe))
3.725 + list;
3.726 +val Ets = []:ets;
3.727 +
3.728 +
3.729 +fun ets2s (l,(m,eno,env,iar,res,s)) =
3.730 + "\n("^(loc_2str l)^",("^(tac_2str m)^
3.731 + ",\n ens= "^(subst2str eno)^
3.732 + ",\n env= "^(subst2str env)^
3.733 + ",\n iar= "^(Sign.string_of_term (sign_of thy) iar)^
3.734 + ",\n res= "^(Sign.string_of_term (sign_of thy) res)^
3.735 + ",\n "^(safe2str s)^"))";
3.736 +fun ets2str (ets:ets) = (strs2str o (map ets2s)) ets;
3.737 +
3.738 +
3.739 +type envp =(*9.5.03: unused, delete with field in ptree.PblObj FIXXXME*)
3.740 + (int * term list) list * (*assoc-list: args of met*)
3.741 + (int * rls) list * (*assoc-list: tacs already done ///15.9.00*)
3.742 + (int * ets) list * (*assoc-list: tacs etc. already done*)
3.743 + (string * pos) list; (*asms * from where*)
3.744 +val empty_envp = ([],[],[],[]):envp;
3.745 +
3.746 +datatype ppobj =
3.747 + PrfObj of {cell : lrd option, (*where in form tac has been applied*)
3.748 + (*^^^FIXME.WN0607 rename this field*)
3.749 + form : term,
3.750 + tac : tac, (* also in istate*)
3.751 + loc : istate option * istate option, (*for form, result
3.752 +13.8.02: (None,None) <==> e_istate ! see update_loc, get_loc*)
3.753 + branch: branch,
3.754 + result: term * term list,
3.755 + ostate: ostate} (*Complete <=> result is OK*)
3.756 + | PblObj of {cell : lrd option,(*unused: meaningful only for some _Prf_Obj*)
3.757 + fmz : fmz, (*from init:FIXME never use this spec;-drop*)
3.758 + origin: (ori list) * (*representation from fmz+pbt
3.759 + for efficiently adding items in probl, meth*)
3.760 + spec * (*updated by Refine_Tacitly*)
3.761 + term, (*headline of calc-head, as calculated
3.762 + initially(!)*)
3.763 + (*# the origin of a root-pbl is created from fmz
3.764 + (thus providing help for input to the user),
3.765 + # the origin of a sub-pbl is created from the argument
3.766 + -list of a script-tac 'SubProblem (spec) [arg-list]'
3.767 + by 'match_ags'*)
3.768 + spec : spec, (*explicitly input*)
3.769 + probl : itm list, (*itms explicitly input*)
3.770 + meth : itm list, (*itms automatically added to copy of probl
3.771 + TODO: input like to 'probl'*)
3.772 + env : istate option,(*for problem with initac in script*)
3.773 + loc : istate option * istate option, (*for pbl+met * result*)
3.774 + branch: branch,
3.775 + result: term * term list,
3.776 + ostate: ostate}; (*Complete <=> result is _proven_ OK*)
3.777 +
3.778 +(*.this tree contains isac's calculations; TODO.WN03 rename to ctree;
3.779 + the structure has been copied from an early version of Theorema(c);
3.780 + it has the disadvantage, that there is no space
3.781 + for the first tactic in a script generating the first formula at (p,Frm);
3.782 + this trouble has been covered by 'init_form' and 'Take' so far,
3.783 + but it is crucial if the first tactic in a script is eg. 'Subproblem';
3.784 + see 'type tac ', Apply_Method.
3.785 +.*)
3.786 +datatype ptree =
3.787 + EmptyPtree
3.788 + | Nd of ppobj * (ptree list);
3.789 +val e_ptree = EmptyPtree;
3.790 +
3.791 +fun rep_prfobj (PrfObj {cell,form,tac,loc,branch,result,ostate}) =
3.792 + {cell=cell,form=form,tac=tac,loc=loc,branch=branch,result=result,ostate=ostate};
3.793 +fun rep_pblobj (PblObj {cell,origin,fmz,spec,probl,meth,env,
3.794 + loc,branch,result,ostate}) =
3.795 + {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,meth=meth,
3.796 + env=env,loc=loc,branch=branch,result=result,ostate=ostate};
3.797 +fun is_prfobj (PrfObj _) = true
3.798 + | is_prfobj _ =false;
3.799 +(*val is_prfobj' = get_obj is_prfobj; *)
3.800 +fun is_pblobj (PblObj _) = true
3.801 + | is_pblobj _ = false;
3.802 +(*val is_pblobj' = get_obj is_pblobj; 'Error: unbound constructor get_obj'*)
3.803 +
3.804 +
3.805 +exception PTREE of string;
3.806 +fun nth _ [] = raise PTREE "nth _ []"
3.807 + | nth 1 (x::xs) = x
3.808 + | nth n (x::xs) = nth (n-1) xs;
3.809 +(*> nth 2 [11,22,33]; -->> val it = 22 : int*)
3.810 +
3.811 +fun lev_up ([]:pos) = raise PTREE "lev_up []"
3.812 + | lev_up p = (drop_last p):pos;
3.813 +fun lev_on ([]:pos) = raise PTREE "lev_on []"
3.814 + | lev_on pos =
3.815 + let val len = length pos
3.816 + in (drop_last pos) @ [(nth len pos)+1] end;
3.817 +fun lev_onFrm ((p,_):pos') = (lev_on p,Frm):pos'
3.818 + | lev_onFrm p = raise PTREE ("*** lev_onFrm: pos'="^(pos'2str p));
3.819 +(*040216: for inform --> embed_deriv: remains on same level*)
3.820 +fun lev_back (([],_):pos') = raise PTREE "lev_on_back: called by ([],_)"
3.821 + | lev_back (p,_) =
3.822 + if last_elem p <= 1 then (p, Frm):pos'
3.823 + else ((drop_last p) @ [(nth (length p) p) - 1], Res);
3.824 +(*.increase pos by n within a level.*)
3.825 +fun pos_plus 0 pos = pos
3.826 + | pos_plus n ((p,Frm):pos') = pos_plus (n-1) (p, Res)
3.827 + | pos_plus n ((p, _):pos') = pos_plus (n-1) (lev_on p, Res);
3.828 +
3.829 +
3.830 +
3.831 +fun lev_pred ([]:pos) = raise PTREE "lev_pred []"
3.832 + | lev_pred (pos:pos) =
3.833 + let val len = length pos
3.834 + in ((drop_last pos) @ [(nth len pos)-1]):pos end;
3.835 +(*lev_pred [1,2,3];
3.836 +val it = [1,2,2] : pos
3.837 +> lev_pred [1];
3.838 +val it = [0] : pos *)
3.839 +
3.840 +fun lev_dn p = p @ [0];
3.841 +(*> (lev_dn o lev_on) [1,2,3];
3.842 +val it = [1,2,4,0] : pos *)
3.843 +(*fun lev_dn' ((p,p_):pos') = (lev_dn p, Frm):pos'; WN.3.12.03: never used*)
3.844 +fun lev_dnRes ((p,_):pos') = (lev_dn p, Res):pos';
3.845 +
3.846 +(*4.4.00*)
3.847 +fun lev_up_ ((p,Res):pos') = (lev_up p,Res):pos'
3.848 + | lev_up_ p' = raise error ("lev_up_: called for "^(pos'2str p'));
3.849 +fun lev_dn_ ((p,_):pos') = (lev_dn p,Res):pos'
3.850 +fun ind ((p,_):pos') = length p; (*WN050108 deprecated in favour of lev_of*)
3.851 +fun lev_of ((p,_):pos') = length p;
3.852 +
3.853 +
3.854 +(** convert ptree to a string **)
3.855 +
3.856 +(* convert a pos from list to string *)
3.857 +fun pr_pos ps = (space_implode "." (map string_of_int ps))^". ";
3.858 +(* show hd origin or form only *)
3.859 +fun pr_short (p:pos) (PblObj {origin = (ori,_,_),...}) =
3.860 + ((pr_pos p) ^ " ----- pblobj -----\n")
3.861 +(* ((((Sign.string_of_term (sign_of thy)) o #4 o hd) ori)^" "^
3.862 + (((Sign.string_of_term (sign_of thy)) o hd(*!?!*) o #5 o hd) ori))^
3.863 + "\n") *)
3.864 + | pr_short p (PrfObj {form = form,...}) =
3.865 + ((pr_pos p) ^ (term2str form) ^ "\n");
3.866 +(*
3.867 +fun pr_cell (p:pos) (PblObj {cell = c, origin = (ori,_,_),...}) =
3.868 + ((ints2str c) ^" "^
3.869 + ((((Sign.string_of_term (sign_of thy)) o #4 o hd) ori)^" "^
3.870 + (((Sign.string_of_term (sign_of thy)) o hd(*!?!*) o #5 o hd) ori))^
3.871 + "\n")
3.872 + | pr_cell p (PrfObj {cell = c, form = form,...}) =
3.873 + ((ints2str c) ^" "^ (term2str form) ^ "\n");
3.874 +*)
3.875 +
3.876 +(* convert ptree *)
3.877 +fun pr_ptree f pt =
3.878 + let
3.879 + fun pr_pt pfn _ EmptyPtree = ""
3.880 + | pr_pt pfn ps (Nd (b, [])) = pfn ps b
3.881 + | pr_pt pfn ps (Nd (b, ts)) = (pfn ps b)^
3.882 + (prts pfn (ps:pos) 1 ts)
3.883 + and prts pfn ps p [] = ""
3.884 + | prts pfn ps p (t::ts) = (pr_pt pfn (ps @ [p]) t)^
3.885 + (prts pfn ps (p+1) ts)
3.886 + in pr_pt f [] pt end;
3.887 +(*
3.888 +> fun prfn ps b = (pr_pos ps)^" "^b(*TODO*)^"\n";
3.889 +> val pt = ref EmptyPtree;
3.890 +> pt:=Nd("root",
3.891 + [Nd("xx1",[]),
3.892 + Nd("xx2",
3.893 + [Nd("xx2.1.",[]),
3.894 + Nd("xx2.2.",[])]),
3.895 + Nd("xx3",[])]);
3.896 +> writeln (pr_ptree prfn (!pt));
3.897 +*)
3.898 +
3.899 +
3.900 +(** access the branches of ptree **)
3.901 +
3.902 +fun ins_nth 1 e l = e::l
3.903 + | ins_nth n e [] = raise PTREE "ins_nth n e []"
3.904 + | ins_nth n e (l::ls) = l::(ins_nth (n-1) e ls);
3.905 +fun repl [] _ _ = raise PTREE "repl [] _ _"
3.906 + | repl (l::ls) 1 e = e::ls
3.907 + | repl (l::ls) n e = l::(repl ls (n-1) e);
3.908 +fun repl_app ls n e =
3.909 + let val lim = 1 + length ls
3.910 + in if n > lim then raise PTREE "repl_app: n > lim"
3.911 + else if n = lim then ls @ [e]
3.912 + else repl ls n e end;
3.913 +(*
3.914 +> repl [1,2,3] 2 22222;
3.915 +val it = [1,22222,3] : int list
3.916 +> repl_app [1,2,3,4] 5 5555;
3.917 +val it = [1,2,3,4,5555] : int list
3.918 +> repl_app [1,2,3] 2 22222;
3.919 +val it = [1,22222,3] : int list
3.920 +> repl_app [1] 2 22222 ;
3.921 +val it = [1,22222] : int list
3.922 +*)
3.923 +
3.924 +
3.925 +(*.get from obj at pos by f : ppobj -> 'a.*)
3.926 +fun get_obj f EmptyPtree (_:pos) = raise PTREE "get_obj f EmptyPtree"
3.927 + | get_obj f (Nd (b, _)) [] = f b
3.928 + | get_obj f (Nd (b, bs)) (p::ps) =
3.929 +(* val (f, Nd (b, bs), (p::ps)) = (I, pt, p);
3.930 + *)
3.931 + let val _ = (nth p bs) handle _ => raise PTREE ("get_obj: pos = "^
3.932 + (ints2str' (p::ps))^" does not exist");
3.933 + in (get_obj f (nth p bs) (ps:pos))
3.934 + (*before WN050419: 'wrong type..' raised also if pos doesn't exist*)
3.935 + handle _ => raise PTREE (*"get_obj: at pos = "^
3.936 + (ints2str' (p::ps))^" wrong type of ppobj"*)
3.937 + ("get_obj: pos = "^
3.938 + (ints2str' (p::ps))^" does not exist")
3.939 + end;
3.940 +fun get_nd EmptyPtree _ = raise PTREE "get_nd EmptyPtree"
3.941 + | get_nd n [] = n
3.942 + | get_nd (Nd (_,nds)) (pos as p::(ps:pos)) = (get_nd (nth p nds) ps)
3.943 + handle _ => raise PTREE ("get_nd: not existent pos = "^(ints2str' pos));
3.944 +
3.945 +
3.946 +(* for use by get_obj *)
3.947 +fun g_cell (PblObj {cell = c,...}) = None
3.948 + | g_cell (PrfObj {cell = c,...}) = c;(*WN0607 hack for quick introduction of lrd + rewrite-at (thms, calcs)*)
3.949 +fun g_form (PrfObj {form = f,...}) = f
3.950 + | g_form (PblObj {origin=(_,_,f),...}) = f;
3.951 +fun g_form' (Nd (PrfObj {form = f,...}, _)) = f
3.952 + | g_form' (Nd (PblObj {origin=(_,_,f),...}, _)) = f;
3.953 +(* | g_form _ = raise PTREE "g_form not for PblObj";*)
3.954 +fun g_origin (PblObj {origin = ori,...}) = ori
3.955 + | g_origin _ = raise PTREE "g_origin not for PrfObj";
3.956 +fun g_fmz (PblObj {fmz = f,...}) = f
3.957 + | g_fmz _ = raise PTREE "g_fmz not for PrfObj";
3.958 +fun g_spec (PblObj {spec = s,...}) = s
3.959 + | g_spec _ = raise PTREE "g_spec not for PrfObj";
3.960 +fun g_pbl (PblObj {probl = p,...}) = p
3.961 + | g_pbl _ = raise PTREE "g_pbl not for PrfObj";
3.962 +fun g_met (PblObj {meth = p,...}) = p
3.963 + | g_met _ = raise PTREE "g_met not for PrfObj";
3.964 +fun g_domID (PblObj {spec = (d,_,_),...}) = d
3.965 + | g_domID _ = raise PTREE "g_metID not for PrfObj";
3.966 +fun g_metID (PblObj {spec = (_,_,m),...}) = m
3.967 + | g_metID _ = raise PTREE "g_metID not for PrfObj";
3.968 +fun g_env (PblObj {env,...}) = env
3.969 + | g_env _ = raise PTREE "g_env not for PrfObj";
3.970 +fun g_loc (PblObj {loc = l,...}) = l
3.971 + | g_loc (PrfObj {loc = l,...}) = l;
3.972 +fun g_branch (PblObj {branch = b,...}) = b
3.973 + | g_branch (PrfObj {branch = b,...}) = b;
3.974 +fun g_tac (PblObj {spec = (d,p,m),...}) = Apply_Method m
3.975 + | g_tac (PrfObj {tac = m,...}) = m;
3.976 +fun g_result (PblObj {result = r,...}) = r
3.977 + | g_result (PrfObj {result = r,...}) = r;
3.978 +fun g_res (PblObj {result = (r,_),...}) = r
3.979 + | g_res (PrfObj {result = (r,_),...}) = r;
3.980 +fun g_res' (Nd (PblObj {result = (r,_),...}, _)) = r
3.981 + | g_res' (Nd (PrfObj {result = (r,_),...}, _)) = r;
3.982 +fun g_ostate (PblObj {ostate = r,...}) = r
3.983 + | g_ostate (PrfObj {ostate = r,...}) = r;
3.984 +fun g_ostate' (Nd (PblObj {ostate = r,...}, _)) = r
3.985 + | g_ostate' (Nd (PrfObj {ostate = r,...}, _)) = r;
3.986 +
3.987 +fun gpt_cell (Nd (PblObj {cell = c,...},_)) = None
3.988 + | gpt_cell (Nd (PrfObj {cell = c,...},_)) = c;
3.989 +
3.990 +(*in CalcTree/Subproblem an 'just_created_' model is created;
3.991 + this is filled to 'untouched' by Model/Refine_Problem*)
3.992 +fun just_created_ (PblObj {meth, probl, spec, ...}) =
3.993 + null meth andalso null probl andalso spec = e_spec;
3.994 +val e_origin = ([],e_spec,e_term): (ori list) * spec * term;
3.995 +
3.996 +fun just_created (pt,(p,_):pos') =
3.997 + let val ppobj = get_obj I pt p
3.998 + in is_pblobj ppobj andalso just_created_ ppobj end;
3.999 +
3.1000 +(*.does the pos in the ctree exist ?.*)
3.1001 +fun existpt pos pt = can (get_obj I pt) pos;
3.1002 +(*.does the pos' in the ctree exist, ie. extra check for result in the node.*)
3.1003 +fun existpt' ((p,p_):pos') pt =
3.1004 + if can (get_obj I pt) p
3.1005 + then case p_ of
3.1006 + Res => get_obj g_ostate pt p = Complete
3.1007 + | _ => true
3.1008 + else false;
3.1009 +
3.1010 +(*.is this position appropriate for calculating intermediate steps?.*)
3.1011 +fun is_interpos ((_, Res):pos') = true
3.1012 + | is_interpos _ = false;
3.1013 +
3.1014 +fun last_onlev pt pos = not (existpt (lev_on pos) pt);
3.1015 +
3.1016 +
3.1017 +(*.find the position of the next parent which is a PblObj in ptree.*)
3.1018 +fun par_pblobj pt ([]:pos) = ([]:pos)
3.1019 + | par_pblobj pt p =
3.1020 + let fun par pt [] = []
3.1021 + | par pt p = if is_pblobj (get_obj I pt p) then p
3.1022 + else par pt (lev_up p)
3.1023 + in par pt (lev_up p) end;
3.1024 +(* lev_up for hard_gen operating with pos = [...,0] *)
3.1025 +
3.1026 +(*.find the position and the children of the next parent which is a PblObj.*)
3.1027 +fun par_children (Nd (PblObj _, children)) ([]:pos) = (children, []:pos)
3.1028 + | par_children (pt as Nd (PblObj _, children)) p =
3.1029 + let fun par [] = (children, [])
3.1030 + | par p = let val Nd (obj, children) = get_nd pt p
3.1031 + in if is_pblobj obj then (children, p) else par (lev_up p)
3.1032 + end;
3.1033 + in par (lev_up p) end;
3.1034 +
3.1035 +(*.get the children of a node in ptree.*)
3.1036 +fun children (Nd (PblObj _, cn)) = cn
3.1037 + | children (Nd (PrfObj _, cn)) = cn;
3.1038 +
3.1039 +
3.1040 +(*.find the next parent, which is either a PblObj (return true)
3.1041 + or a PrfObj with tac = Detail_Set (return false).*)
3.1042 +(*FIXME.3.4.03:re-organize par_pbl_det after rls' --> rls*)
3.1043 +fun par_pbl_det pt ([]:pos) = (true, []:pos, Erls)
3.1044 + | par_pbl_det pt p =
3.1045 + let fun par pt [] = (true, [], Erls)
3.1046 + | par pt p = if is_pblobj (get_obj I pt p) then (true, p, Erls)
3.1047 + else case get_obj g_tac pt p of
3.1048 + (*Detail_Set rls' => (false, p, assoc_rls rls')
3.1049 + (*^^^--- before 040206 after ---vvv*)
3.1050 + |*)Rewrite_Set rls' => (false, p, assoc_rls rls')
3.1051 + | Rewrite_Set_Inst (_, rls') =>
3.1052 + (false, p, assoc_rls rls')
3.1053 + | _ => par pt (lev_up p)
3.1054 + in par pt (lev_up p) end;
3.1055 +
3.1056 +
3.1057 +
3.1058 +
3.1059 +(*.get from the whole ptree by f : ppobj -> 'a.*)
3.1060 +fun get_all f EmptyPtree = []
3.1061 + | get_all f (Nd (b, [])) = [f b]
3.1062 + | get_all f (Nd (b, bs)) = [f b] @ (get_alls f bs)
3.1063 +and get_alls f [] = []
3.1064 + | get_alls f pts = flat (map (get_all f) pts);
3.1065 +
3.1066 +
3.1067 +(*.insert obj b into ptree at pos, ev.overwriting this pos.*)
3.1068 +fun insert b EmptyPtree ([]:pos) = Nd (b, [])
3.1069 + | insert b EmptyPtree _ = raise PTREE "insert b Empty _"
3.1070 + | insert b (Nd ( _, _)) [] = raise PTREE "insert b _ []"
3.1071 + | insert b (Nd (b', bs)) (p::[]) =
3.1072 + Nd (b', repl_app bs p (Nd (b,[])))
3.1073 + | insert b (Nd (b', bs)) (p::ps) =
3.1074 + Nd (b', repl_app bs p (insert b (nth p bs) ps));
3.1075 +(*
3.1076 +> type ppobj = string;
3.1077 +> writeln (pr_ptree prfn (!pt));
3.1078 + val pt = ref Empty;
3.1079 + pt:= insert ("root":ppobj) EmptyPtree [];
3.1080 + pt:= insert ("xx1":ppobj) (!pt) [1];
3.1081 + pt:= insert ("xx2":ppobj) (!pt) [2];
3.1082 + pt:= insert ("xx3":ppobj) (!pt) [3];
3.1083 + pt:= insert ("xx2.1":ppobj) (!pt) [2,1];
3.1084 + pt:= insert ("xx2.2":ppobj) (!pt) [2,2];
3.1085 + pt:= insert ("xx2.1.1":ppobj) (!pt) [2,1,1];
3.1086 + pt:= insert ("xx2.1.2":ppobj) (!pt) [2,1,2];
3.1087 + pt:= insert ("xx2.1.3":ppobj) (!pt) [2,1,3];
3.1088 +*)
3.1089 +
3.1090 +(*.insert children to a node without children.*)
3.1091 +(*compare: fun insert*)
3.1092 +fun ins_chn _ EmptyPtree (_:pos) = raise PTREE "ins_chn: EmptyPtree"
3.1093 + | ins_chn ns (Nd _) [] = raise PTREE "ins_chn: pos = []"
3.1094 + | ins_chn ns (Nd (b, bs)) (p::[]) =
3.1095 + if p > length bs then raise PTREE "ins_chn: pos not existent"
3.1096 + else let val Nd (b', bs') = nth p bs
3.1097 + in if null bs' then Nd (b, repl_app bs p (Nd (b', ns)))
3.1098 + else raise PTREE "ins_chn: pos mustNOT be overwritten" end
3.1099 + | ins_chn ns (Nd (b, bs)) (p::ps) =
3.1100 + Nd (b, repl_app bs p (ins_chn ns (nth p bs) ps));
3.1101 +
3.1102 +(* print_depth 11;ins_chn;print_depth 3; ###insert#########################*);
3.1103 +
3.1104 +
3.1105 +(** apply f to obj at pos, f: ppobj -> ppobj **)
3.1106 +
3.1107 +fun appl_to_node f (Nd (b,bs)) = Nd (f b, bs);
3.1108 +fun appl_obj f EmptyPtree [] = EmptyPtree
3.1109 + | appl_obj f EmptyPtree _ = raise PTREE "appl_obj f Empty _"
3.1110 + | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs)
3.1111 + | appl_obj f (Nd (b, bs)) (p::[]) =
3.1112 + Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs))
3.1113 + | appl_obj f (Nd (b, bs)) (p::ps) =
3.1114 + Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos)));
3.1115 +
3.1116 +(* for use by appl_obj *)
3.1117 +fun repl_form f (PrfObj {cell=c,form= _,tac=tac,loc=loc,
3.1118 + branch=branch,result=result,ostate=ostate}) =
3.1119 + PrfObj {cell=c,form= f,tac=tac,loc=loc,
3.1120 + branch=branch,result=result,ostate=ostate}
3.1121 + | repl_form _ _ = raise PTREE "repl_form takes no PblObj";
3.1122 +fun repl_pbl x (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1123 + spec=spec,probl=_,meth=meth,env=env,loc=loc,
3.1124 + branch=branch,result=result,ostate=ostate}) =
3.1125 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl= x,
3.1126 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
3.1127 + | repl_pbl _ _ = raise PTREE "repl_pbl takes no PrfObj";
3.1128 +fun repl_met x (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1129 + spec=spec,probl=probl,meth=_,env=env,loc=loc,
3.1130 + branch=branch,result=result,ostate=ostate}) =
3.1131 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
3.1132 + meth= x,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
3.1133 + | repl_met _ _ = raise PTREE "repl_pbl takes no PrfObj";
3.1134 +
3.1135 +fun repl_spec x (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1136 + spec= _,probl=probl,meth=meth,env=env,loc=loc,
3.1137 + branch=branch,result=result,ostate=ostate}) =
3.1138 + PblObj {cell=cell,origin=origin,fmz=fmz,spec= x,probl=probl,
3.1139 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
3.1140 + | repl_spec _ _ = raise PTREE "repl_domID takes no PrfObj";
3.1141 +fun repl_domID x (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1142 + spec=(_,p,m),probl=probl,meth=meth,env=env,loc=loc,
3.1143 + branch=branch,result=result,ostate=ostate}) =
3.1144 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(x,p,m),probl=probl,
3.1145 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
3.1146 + | repl_domID _ _ = raise PTREE "repl_domID takes no PrfObj";
3.1147 +fun repl_pblID x (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1148 + spec=(d,_,m),probl=probl,meth=meth,env=env,loc=loc,
3.1149 + branch=branch,result=result,ostate=ostate}) =
3.1150 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,x,m),probl=probl,
3.1151 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
3.1152 + | repl_pblID _ _ = raise PTREE "repl_pblID takes no PrfObj";
3.1153 +fun repl_metID x (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1154 + spec=(d,p,_),probl=probl,meth=meth,env=env,loc=loc,
3.1155 + branch=branch,result=result,ostate=ostate}) =
3.1156 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,p,x),probl=probl,
3.1157 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
3.1158 + | repl_metID _ _ = raise PTREE "repl_metID takes no PrfObj";
3.1159 +
3.1160 +fun repl_result l f' s (PrfObj {cell=cell,form=form,tac=tac,loc=_,
3.1161 + branch=branch,result = _ ,ostate = _}) =
3.1162 + PrfObj {cell=cell,form=form,tac=tac,loc= l,
3.1163 + branch=branch,result = f',ostate = s}
3.1164 + | repl_result l f' s (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1165 + spec=spec,probl=probl,meth=meth,env=env,loc=_,
3.1166 + branch=branch,result= _ ,ostate= _}) =
3.1167 + PblObj {cell=cell,origin=origin,fmz=fmz,
3.1168 + spec=spec,probl=probl,meth=meth,env=env,loc= l,
3.1169 + branch=branch,result= f',ostate= s};
3.1170 +
3.1171 +fun repl_tac x (PrfObj {cell=cell,form=form,tac= _,loc=loc,
3.1172 + branch=branch,result=result,ostate=ostate}) =
3.1173 + PrfObj {cell=cell,form=form,tac= x,loc=loc,
3.1174 + branch=branch,result=result,ostate=ostate}
3.1175 + | repl_tac _ _ = raise PTREE "repl_tac takes no PblObj";
3.1176 +
3.1177 +fun repl_branch b (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1178 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
3.1179 + branch= _,result=result,ostate=ostate}) =
3.1180 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
3.1181 + meth=meth,env=env,loc=loc,branch= b,result=result,ostate=ostate}
3.1182 + | repl_branch b (PrfObj {cell=cell,form=form,tac=tac,loc=loc,
3.1183 + branch= _,result=result,ostate=ostate}) =
3.1184 + PrfObj {cell=cell,form=form,tac=tac,loc=loc,
3.1185 + branch= b,result=result,ostate=ostate};
3.1186 +
3.1187 +fun repl_env e
3.1188 + (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1189 + spec=spec,probl=probl,meth=meth,env=_,loc=loc,
3.1190 + branch=branch,result=result,ostate=ostate}) =
3.1191 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
3.1192 + meth=meth,env=e,loc=loc,branch=branch,
3.1193 + result=result,ostate=ostate}
3.1194 + | repl_env _ _ = raise PTREE "repl_ets takes no PrfObj";
3.1195 +
3.1196 +fun repl_oris oris
3.1197 + (PblObj {cell=cell,origin=(_,spe,hdf),fmz=fmz,
3.1198 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
3.1199 + branch=branch,result=result,ostate=ostate}) =
3.1200 + PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl,
3.1201 + meth=meth,env=env,loc=loc,branch=branch,
3.1202 + result=result,ostate=ostate}
3.1203 + | repl_oris _ _ = raise PTREE "repl_oris takes no PrfObj";
3.1204 +fun repl_orispec spe
3.1205 + (PblObj {cell=cell,origin=(oris,_,hdf),fmz=fmz,
3.1206 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
3.1207 + branch=branch,result=result,ostate=ostate}) =
3.1208 + PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl,
3.1209 + meth=meth,env=env,loc=loc,branch=branch,
3.1210 + result=result,ostate=ostate}
3.1211 + | repl_orispec _ _ = raise PTREE "repl_orispec takes no PrfObj";
3.1212 +
3.1213 +fun repl_loc l (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1214 + spec=spec,probl=probl,meth=meth,env=env,loc=_,
3.1215 + branch=branch,result=result,ostate=ostate}) =
3.1216 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
3.1217 + meth=meth,env=env,loc=l,branch=branch,result=result,ostate=ostate}
3.1218 + | repl_loc l (PrfObj {cell=cell,form=form,tac=tac,loc=_,
3.1219 + branch=branch,result=result,ostate=ostate}) =
3.1220 + PrfObj {cell=cell,form=form,tac=tac,loc= l,
3.1221 + branch=branch,result=result,ostate=ostate};
3.1222 +(*
3.1223 +fun uni__cid cell'
3.1224 + (PblObj {cell=cell,origin=origin,fmz=fmz,
3.1225 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
3.1226 + branch=branch,result=result,ostate=ostate}) =
3.1227 + PblObj {cell=cell union cell',origin=origin,fmz=fmz,spec=spec,probl=probl,
3.1228 + meth=meth,env=env,loc=loc,branch=branch,
3.1229 + result=result,ostate=ostate}
3.1230 + | uni__cid cell'
3.1231 + (PrfObj {cell=cell,form=form,tac=tac,loc=loc,
3.1232 + branch=branch,result=result,ostate=ostate}) =
3.1233 + PrfObj {cell=cell union cell',form=form,tac=tac,loc=loc,
3.1234 + branch=branch,result=result,ostate=ostate};
3.1235 +*)
3.1236 +
3.1237 +(*WN050219 put here for interpreting code for cut_tree below...*)
3.1238 +type ocalhd =
3.1239 + bool * (*ALL itms+preconds true*)
3.1240 + pos_ * (*model belongs to Problem | Method*)
3.1241 + term * (*header: Problem... or Cas
3.1242 + FIXXXME.12.03: item! for marking syntaxerrors*)
3.1243 + itm list * (*model: given, find, relate*)
3.1244 + ((bool * term) list) *(*model: preconds*)
3.1245 + spec; (*specification*)
3.1246 +val e_ocalhd = (false, Und, e_term, [e_itm], [(false, e_term)], e_spec);
3.1247 +
3.1248 +datatype ptform =
3.1249 + Form of term
3.1250 + | ModSpec of ocalhd;
3.1251 +val e_ptform = Form e_term;
3.1252 +val e_ptform' = ModSpec e_ocalhd;
3.1253 +
3.1254 +
3.1255 +
3.1256 +(*.applies (snd f) to the branches at a pos if ((fst f) b),
3.1257 + f : (ppobj -> bool) * (int -> ptree list -> ptree list).*)
3.1258 +
3.1259 +fun appl_branch f EmptyPtree [] = (EmptyPtree, false)
3.1260 + | appl_branch f EmptyPtree _ = raise PTREE "appl_branch f Empty _"
3.1261 + | appl_branch f (Nd ( _, _)) [] = raise PTREE "appl_branch f _ []"
3.1262 + | appl_branch f (Nd (b, bs)) (p::[]) =
3.1263 + if (fst f) b then (Nd (b, (snd f) (p:posel) bs), true)
3.1264 + else (Nd (b, bs), false)
3.1265 + | appl_branch f (Nd (b, bs)) (p::ps) =
3.1266 + let val (b',bool) = appl_branch f (nth p bs) ps
3.1267 + in (Nd (b, repl_app bs p b'), bool) end;
3.1268 +
3.1269 +(* for cut_level; appl_branch(deprecated) *)
3.1270 +fun test_trans (PrfObj{branch = Transitive,...}) = true
3.1271 + | test_trans (PblObj{branch = Transitive,...}) = true
3.1272 + | test_trans _ = false;
3.1273 +
3.1274 +fun is_pblobj' pt (p:pos) =
3.1275 + let val ppobj = get_obj I pt p
3.1276 + in is_pblobj ppobj end;
3.1277 +
3.1278 +
3.1279 +fun delete_result pt (p:pos) =
3.1280 + (appl_obj (repl_result (fst (get_obj g_loc pt p), None)
3.1281 + (e_term,[]) Incomplete) pt p);
3.1282 +
3.1283 +fun del_res (PblObj {cell, fmz, origin, spec, probl, meth,
3.1284 + env, loc=(l1,_), branch, result, ostate}) =
3.1285 + PblObj {cell=cell,fmz=fmz,origin=origin,spec=spec,probl=probl,meth=meth,
3.1286 + env=env, loc=(l1,None), branch=branch, result=(e_term,[]),
3.1287 + ostate=Incomplete}
3.1288 +
3.1289 + | del_res (PrfObj {cell, form, tac, loc=(l1,_), branch, result, ostate}) =
3.1290 + PrfObj {cell=cell,form=form,tac=tac, loc=(l1,None), branch=branch,
3.1291 + result=(e_term,[]), ostate=Incomplete};
3.1292 +
3.1293 +
3.1294 +(*
3.1295 +fun update_fmz pt pos x = appl_obj (repl_fmz x) pt pos;
3.1296 + 1.00 not used anymore*)
3.1297 +
3.1298 +(*FIXME.WN.12.03: update_X X pos pt -> pt could be chained by o (efficiency?)*)
3.1299 +fun update_env pt pos x = appl_obj (repl_env x) pt pos;
3.1300 +fun update_domID pt pos x = appl_obj (repl_domID x) pt pos;
3.1301 +fun update_pblID pt pos x = appl_obj (repl_pblID x) pt pos;
3.1302 +fun update_metID pt pos x = appl_obj (repl_metID x) pt pos;
3.1303 +fun update_spec pt pos x = appl_obj (repl_spec x) pt pos;
3.1304 +
3.1305 +fun update_pbl pt pos x = appl_obj (repl_pbl x) pt pos;
3.1306 +fun update_pblppc pt pos x = appl_obj (repl_pbl x) pt pos;
3.1307 +
3.1308 +fun update_met pt pos x = appl_obj (repl_met x) pt pos;
3.1309 +(*1.09.01 ----
3.1310 +fun update_metppc pt pos x =
3.1311 + let val {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,...} =
3.1312 + get_obj g_met pt pos
3.1313 + in appl_obj (repl_met
3.1314 + {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,ppc=x})
3.1315 + pt pos end;*)
3.1316 +fun update_metppc pt pos x = appl_obj (repl_met x) pt pos;
3.1317 +
3.1318 +(*fun union_cid pt pos x = appl_obj (uni__cid x) pt pos;*)
3.1319 +
3.1320 +fun update_branch pt pos x = appl_obj (repl_branch x) pt pos;
3.1321 +fun update_tac pt pos x = appl_obj (repl_tac x) pt pos;
3.1322 +
3.1323 +fun update_oris pt pos x = appl_obj (repl_oris x) pt pos;
3.1324 +fun update_orispec pt pos x = appl_obj (repl_orispec x) pt pos;
3.1325 +
3.1326 + (*done by append_* !! 3.5.02; ununsed WN050305 thus outcommented
3.1327 +fun update_loc pt (p,_) (ScrState ([],[],None,
3.1328 + Const ("empty",_),Sundef,false)) =
3.1329 + appl_obj (repl_loc (None,None)) pt p
3.1330 + | update_loc pt (p,Res) x =
3.1331 + let val (lform,_) = get_obj g_loc pt p
3.1332 + in appl_obj (repl_loc (lform,Some x)) pt p end
3.1333 +
3.1334 + | update_loc pt (p,_) x =
3.1335 + let val (_,lres) = get_obj g_loc pt p
3.1336 + in appl_obj (repl_loc (Some x,lres)) pt p end;-------------*)
3.1337 +
3.1338 +(*WN050305 for handling cut_tree in cappend_atomic -- TODO redesign !*)
3.1339 +fun update_loc' pt p iss = appl_obj (repl_loc iss) pt p;
3.1340 +
3.1341 +(*13.8.02---------------------------
3.1342 +fun get_loc EmptyPtree _ = None
3.1343 + | get_loc pt (p,Res) =
3.1344 + let val (lfrm,lres) = get_obj g_loc pt p
3.1345 + in if lres = e_istate then lfrm else lres end
3.1346 + | get_loc pt (p,_) =
3.1347 + let val (lfrm,lres) = get_obj g_loc pt p
3.1348 + in if lfrm = e_istate then lres else lfrm end; 5.10.00: too liberal ?*)
3.1349 +(*13.8.02: options, because istate is no equalitype any more*)
3.1350 +fun get_loc EmptyPtree _ = e_istate
3.1351 + | get_loc pt (p,Res) =
3.1352 + (case get_obj g_loc pt p of
3.1353 + (Some i, None) => i
3.1354 + | (None , None) => e_istate
3.1355 + | (_ , Some i) => i)
3.1356 + | get_loc pt (p,_) =
3.1357 + (case get_obj g_loc pt p of
3.1358 + (None , Some i) => i (*13.8.02 just copied from ^^^: too liberal ?*)
3.1359 + | (None , None) => e_istate
3.1360 + | (Some i, _) => i);
3.1361 +val get_istate = get_loc; (*3.5.02*)
3.1362 +
3.1363 +(*.collect the assumptions within a problem up to a certain position.*)
3.1364 +type asms = (term * pos) list;(*WN0502 should be (pos' * term) list
3.1365 + ...........===^===*)
3.1366 +
3.1367 +fun get_asm (b:pos, p:pos) (Nd (PblObj {result=(_,asm),...},_)) =
3.1368 + ((*writeln ("### get_asm PblObj:(b,p)= "^
3.1369 + (pair2str(ints2str b, ints2str p)));*)
3.1370 + (map (rpair b) asm):asms)
3.1371 + | get_asm (b, p) (Nd (PrfObj {result=(_,asm),...}, [])) =
3.1372 + ((*writeln ("### get_asm PrfObj []:(b,p)= "^
3.1373 + (pair2str(ints2str b, ints2str p)));*)
3.1374 + (map (rpair b) asm))
3.1375 + | get_asm (b, p:pos) (Nd (PrfObj _, nds)) =
3.1376 + let (*val _= writeln ("### get_asm PrfObj nds:(b,p)= "^
3.1377 + (pair2str(ints2str b, ints2str p)));*)
3.1378 + val levdn =
3.1379 + if p <> [] then (b @ [hd p]:pos, tl p:pos)
3.1380 + else (b @ [1], [99999]) (*_deeper_ nesting is always _before_ p*)
3.1381 + in gets_asm levdn 1 nds end
3.1382 +and gets_asm _ _ [] = []
3.1383 + | gets_asm (b, p' as p::ps) i (nd::nds) =
3.1384 + if p < i then []
3.1385 + else ((*writeln ("### gets_asm: (b,p')= "^(pair2str(ints2str b,
3.1386 + ints2str p')));*)
3.1387 + (get_asm (b @ [i], ps) nd) @ (gets_asm (b, p') (i + 1) nds));
3.1388 +
3.1389 +fun get_assumptions_ (Nd (PblObj {result=(r,asm),...}, cn)) (([], _):pos') =
3.1390 + if r = e_term then gets_asm ([], [99999]) 1 cn
3.1391 + else map (rpair []) asm
3.1392 + | get_assumptions_ pt (p,p_) =
3.1393 + let val (cn, base) = par_children pt p
3.1394 + val offset = drop (length base, p)
3.1395 + val base' = replicate (length base) 1
3.1396 + val offset' = case p_ of
3.1397 + Frm => let val (qs,q) = split_last offset
3.1398 + in qs @ [q - 1] end
3.1399 + | _ => offset
3.1400 + (*val _= writeln ("... get_assumptions: (b,o)= "^
3.1401 + (pair2str(ints2str base',ints2str offset)))*)
3.1402 + in gets_asm (base', offset) 1 cn end;
3.1403 +
3.1404 +
3.1405 +(*---------
3.1406 +end
3.1407 +
3.1408 +open Ptree;
3.1409 +----------*)
3.1410 +
3.1411 +(*pos of the formula on FE relative to the current pos,
3.1412 + which is the next writepos*)
3.1413 +fun pre_pos ([]:pos) = []:pos
3.1414 + | pre_pos pp =
3.1415 + let val (ps,p) = split_last pp
3.1416 + in case p of 1 => ps | n => ps @ [n-1] end;
3.1417 +
3.1418 +(*WN.20.5.03 ... but not used*)
3.1419 +fun posless [] (_::_) = true
3.1420 + | posless (_::_) [] = false
3.1421 + | posless (p::ps) (q::qs) = if p = q then posless ps qs else p < q;
3.1422 +(* posless [2,3,4] [3,4,5];
3.1423 +true
3.1424 +> posless [2,3,4] [1,2,3];
3.1425 +false
3.1426 +> posless [2,3] [2,3,4];
3.1427 +true
3.1428 +> posless [2,3,4] [2,3];
3.1429 +false
3.1430 +> posless [6] [6,5,2];
3.1431 +true
3.1432 ++++ see Isabelle/../library.ML*)
3.1433 +
3.1434 +
3.1435 +(**.development for extracting an 'interval' from ptree.**)
3.1436 +
3.1437 +(*version 1 stopped 8.03 in favour of get_interval with !!!move_dn
3.1438 + actually used (inefficient) version with move_dn: see modspec.sml*)
3.1439 +local
3.1440 +
3.1441 +fun hdp [] = 1 | hdp [0] = 1 | hdp x = hd x;(*start with first*)
3.1442 +fun hdq [] = 99999 | hdq [0] = 99999 | hdq x = hd x;(*take until last*)
3.1443 +fun tlp [] = [0] | tlp [_] = [0] | tlp x = tl x;
3.1444 +fun tlq [] = [99999] | tlq [_] = [99999] | tlq x = tl x;
3.1445 +
3.1446 +fun getnd i (b,p) q (Nd (po, nds)) =
3.1447 + (if i <= 0 then [[b]] else []) @
3.1448 + (getnds (i-1) true (b@[hdp p], tlp p) (tlq q)
3.1449 + (take_fromto (hdp p) (hdq q) nds))
3.1450 +
3.1451 +and getnds _ _ _ _ [] = [] (*no children*)
3.1452 + | getnds i _ (b,p) q [nd] = (getnd i (b,p) q nd) (*l+r-margin*)
3.1453 +
3.1454 + | getnds i true (b,p) q [n1, n2] = (*l-margin, r-margin*)
3.1455 + (getnd i ( b, p ) [99999] n1) @
3.1456 + (getnd ~99999 (lev_on b,[0]) q n2)
3.1457 +
3.1458 + | getnds i _ (b,p) q [n1, n2] = (*intern, r-margin*)
3.1459 + (getnd i ( b,[0]) [99999] n1) @
3.1460 + (getnd ~99999 (lev_on b,[0]) q n2)
3.1461 +
3.1462 + | getnds i true (b,p) q (nd::(nds as _::_)) = (*l-margin, intern*)
3.1463 + (getnd i ( b, p ) [99999] nd) @
3.1464 + (getnds ~99999 false (lev_on b,[0]) q nds)
3.1465 +
3.1466 + | getnds i _ (b,p) q (nd::(nds as _::_)) = (*intern, ...*)
3.1467 + (getnd i ( b,[0]) [99999] nd) @
3.1468 + (getnds ~99999 false (lev_on b,[0]) q nds);
3.1469 +in
3.1470 +(*get an 'interval from to' from a ptree as 'intervals f t' of respective nodes
3.1471 + where 'from' are pos, i.e. a key as int list, 'f' an int (to,t analoguous)
3.1472 +(1) the 'f' are given
3.1473 +(1a) by 'from' if 'f' = the respective element of 'from' (left margin)
3.1474 +(1b) -inifinity, if 'f' > the respective element of 'from' (internal node)
3.1475 +(2) the 't' ar given
3.1476 +(2a) by 'to' if 't' = the respective element of 'to' (right margin)
3.1477 +(2b) inifinity, if 't' < the respective element of 'to (internal node)'
3.1478 +the 'f' and 't' are set by hdp,... *)
3.1479 +fun get_trace pt p q =
3.1480 + (flat o (getnds ((length p) -1) true ([hdp p], tlp p) (tlq q)))
3.1481 + (take_fromto (hdp p) (hdq q) (children pt));
3.1482 +end;
3.1483 +(*WN0510 stoppde this development;
3.1484 + actually used (inefficient) version with move_dn: getFormulaeFromTo*)
3.1485 +
3.1486 +
3.1487 +
3.1488 +
3.1489 +fun get_somespec ((dI,pI,mI):spec) ((dI',pI',mI'):spec) =
3.1490 + let val domID = if dI = e_domID
3.1491 + then if dI' = e_domID
3.1492 + then raise error"pt_extract: no domID in probl,origin"
3.1493 + else dI'
3.1494 + else dI
3.1495 + val pblID = if pI = e_pblID
3.1496 + then if pI' = e_pblID
3.1497 + then raise error"pt_extract: no pblID in probl,origin"
3.1498 + else pI'
3.1499 + else pI
3.1500 + val metID = if mI = e_metID
3.1501 + then if pI' = e_metID
3.1502 + then raise error"pt_extract: no metID in probl,origin"
3.1503 + else mI'
3.1504 + else mI
3.1505 + in (domID, pblID, metID):spec end;
3.1506 +fun get_somespec' ((dI,pI,mI):spec) ((dI',pI',mI'):spec) =
3.1507 + let val domID = if dI = e_domID then dI' else dI
3.1508 + val pblID = if pI = e_pblID then pI' else pI
3.1509 + val metID = if mI = e_metID then mI' else mI
3.1510 + in (domID, pblID, metID):spec end;
3.1511 +
3.1512 +(*extract a formula or model from ptree for itms2itemppc or model2xml*)
3.1513 +fun preconds2str bts =
3.1514 + (strs2str o (map (linefeed o pair2str o
3.1515 + (apsnd term2str) o
3.1516 + (apfst bool2str)))) bts;
3.1517 +fun ocalhd2str ((b, p, hdf, itms, prec, spec):ocalhd) =
3.1518 + "("^bool2str b^", "^pos_2str p^", "^term2str hdf^
3.1519 + ", "^itms2str (assoc_thy "Isac.thy") itms^
3.1520 + ", "^preconds2str prec^", \n"^spec2str spec^" )";
3.1521 +
3.1522 +
3.1523 +
3.1524 +fun is_pblnd (Nd (ppobj, _)) = is_pblobj ppobj;
3.1525 +
3.1526 +
3.1527 +(**.functions for the 'ptree iterator' as seen from the FE-Kernel interface.**)
3.1528 +
3.1529 +(*move one step down into existing nodes of ptree; regard TransitiveB
3.1530 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~##################
3.1531 +fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*)
3.1532 +(* val (Nd (c, ns), ([],p_)) = (pt, get_pos cI uI);
3.1533 + *)
3.1534 + if is_pblobj c
3.1535 + then case p_ of (*Frm => ([], Pbl) 1.12.03
3.1536 + |*) Res => raise PTREE "move_dn: end of calculation"
3.1537 + | _ => if null ns (*go down from Pbl + Met*)
3.1538 + then raise PTREE "move_dn: solve problem not started"
3.1539 + else ([1], Frm)
3.1540 + else (case p_ of Res => raise PTREE "move_dn: end of (sub-)tree"
3.1541 + | _ => if null ns
3.1542 + then raise PTREE "move_dn: pos not existent 1"
3.1543 + else ([1], Frm))
3.1544 +
3.1545 + (*iterate towards end of pos*)
3.1546 +(* val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ([]:pos, pt, get_pos cI uI);
3.1547 + val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ((P@[p]),(nth p ns),(ps, p_));
3.1548 + *)
3.1549 + | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
3.1550 + if p > length ns then raise PTREE "move_dn: pos not existent 2"
3.1551 + else move_dn ((P@[p]): pos) (nth p ns) (ps, p_)
3.1552 +(* val (P, (Nd (c, ns)), ([p], p_)) = ((P@[p]), (nth p ns), (ps, p_));
3.1553 + val (P, (Nd (c, ns)), ([p], p_)) = ([],pt,get_pos cI uI);
3.1554 + *)
3.1555 + | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
3.1556 + if p > length ns then raise PTREE "move_dn: pos not existent 3"
3.1557 + else if is_pblnd (nth p ns) then
3.1558 + ((*writeln("### move_dn: is_pblnd (nth p ns), P= "^ints2str' P^", \n"^
3.1559 + "length ns= "^((string_of_int o length) ns)^
3.1560 + ", p= "^string_of_int p^", p_= "^pos_2str p_);*)
3.1561 + case p_ of Res => if p = length ns
3.1562 + then if g_ostate c = Complete then (P, Res)
3.1563 + else raise PTREE (ints2str' P^" not complete")
3.1564 + (*FIXME here handle not-sequent-branches*)
3.1565 + else if g_branch c = TransitiveB
3.1566 + andalso (not o is_pblnd o (nth (p+1))) ns
3.1567 + then (P@[p+1], Res)
3.1568 + else (P@[p+1], if is_pblnd (nth (p+1) ns)
3.1569 + then Pbl else Frm)
3.1570 + | _ => if (null o children o (nth p)) ns (*go down from Pbl*)
3.1571 + then raise PTREE "move_dn: solve subproblem not started"
3.1572 + else (P @ [p, 1],
3.1573 + if (is_pblnd o hd o children o (nth p)) ns
3.1574 + then Pbl else Frm)
3.1575 + )
3.1576 + (* val (P, Nd (c, ns), ([p], p_)) = ([], pt, ([1], Frm));
3.1577 + *)
3.1578 + else case p_ of Frm => if (null o children o (nth p)) ns
3.1579 + (*then if g_ostate c = Complete then (P@[p],Res)*)
3.1580 + then if g_ostate' (nth p ns) = Complete
3.1581 + then (P@[p],Res)
3.1582 + else raise PTREE "move_dn: pos not existent 4"
3.1583 + else (P @ [p, 1], (*go down*)
3.1584 + if (is_pblnd o hd o children o (nth p)) ns
3.1585 + then Pbl else Frm)
3.1586 + | Res => if p = length ns
3.1587 + then
3.1588 + if g_ostate c = Complete then (P, Res)
3.1589 + else raise PTREE (ints2str' P^" not complete")
3.1590 + else
3.1591 + if g_branch c = TransitiveB
3.1592 + andalso (not o is_pblnd o (nth (p+1))) ns
3.1593 + then if (null o children o (nth (p+1))) ns
3.1594 + then (P@[p+1], Res)
3.1595 + else (P@[p+1,1], Frm)(*040221*)
3.1596 + else (P@[p+1], if is_pblnd (nth (p+1) ns)
3.1597 + then Pbl else Frm);
3.1598 +*)
3.1599 +(*.move one step down into existing nodes of ptree; skip Res = Frm.nxt;
3.1600 + move_dn at the end of the calc-tree raises PTREE.*)
3.1601 +fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*)
3.1602 + (case p_ of
3.1603 + Res => raise PTREE "move_dn: end of calculation"
3.1604 + | _ => if null ns (*go down from Pbl + Met*)
3.1605 + then raise PTREE "move_dn: solve problem not started"
3.1606 + else ([1], Frm))
3.1607 + | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =(*iterate to end of pos*)
3.1608 + if p > length ns then raise PTREE "move_dn: pos not existent 2"
3.1609 + else move_dn ((P@[p]): pos) (nth p ns) (ps, p_)
3.1610 +
3.1611 + | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
3.1612 + if p > length ns then raise PTREE "move_dn: pos not existent 3"
3.1613 + else case p_ of
3.1614 + Res =>
3.1615 + if p = length ns (*last Res on this level: go a level up*)
3.1616 + then if g_ostate c = Complete then (P, Res)
3.1617 + else raise PTREE (ints2str' P^" not complete 1")
3.1618 + else (*go to the next Nd on this level, or down into the next Nd*)
3.1619 + if is_pblnd (nth (p+1) ns) then (P@[p+1], Pbl)
3.1620 + else
3.1621 + if g_res' (nth p ns) = g_form' (nth (p+1) ns)
3.1622 + then if (null o children o (nth (p+1))) ns
3.1623 + then (*take the Res if Complete*)
3.1624 + if g_ostate' (nth (p+1) ns) = Complete
3.1625 + then (P@[p+1], Res)
3.1626 + else raise PTREE (ints2str' (P@[p+1])^
3.1627 + " not complete 2")
3.1628 + else (P@[p+1,1], Frm)(*go down into the next PrfObj*)
3.1629 + else (P@[p+1], Frm)(*take Frm: exists if the Nd exists*)
3.1630 + | Frm => (*go down or to the Res of this Nd*)
3.1631 + if (null o children o (nth p)) ns
3.1632 + then if g_ostate' (nth p ns) = Complete then (P @ [p], Res)
3.1633 + else raise PTREE (ints2str' (P @ [p])^" not complete 3")
3.1634 + else (P @ [p, 1], Frm)
3.1635 + | _ => (*is Pbl or Met*)
3.1636 + if (null o children o (nth p)) ns
3.1637 + then raise PTREE "move_dn:solve subproblem not startd"
3.1638 + else (P @ [p, 1],
3.1639 + if (is_pblnd o hd o children o (nth p)) ns
3.1640 + then Pbl else Frm);
3.1641 +
3.1642 +
3.1643 +(*.go one level down into ptree.*)
3.1644 +fun movelevel_dn [] (Nd (c, ns)) ([],p_) = (*root problem*)
3.1645 + if is_pblobj c
3.1646 + then if null ns
3.1647 + then raise PTREE "solve problem not started"
3.1648 + else ([1], if (is_pblnd o hd) ns then Pbl else Frm)
3.1649 + else raise PTREE "pos not existent 1"
3.1650 +
3.1651 + (*iterate towards end of pos*)
3.1652 + | movelevel_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
3.1653 + if p > length ns then raise PTREE "pos not existent 2"
3.1654 + else movelevel_dn (P@[p]) (nth p ns) (ps, p_)
3.1655 +
3.1656 + | movelevel_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
3.1657 + if p > length ns then raise PTREE "pos not existent 3" else
3.1658 + case p_ of Res =>
3.1659 + if p = length ns
3.1660 + then raise PTREE "no children"
3.1661 + else
3.1662 + if g_branch c = TransitiveB
3.1663 + then if (null o children o (nth (p+1))) ns
3.1664 + then raise PTREE "no children"
3.1665 + else (P @ [p+1, 1],
3.1666 + if (is_pblnd o hd o children o (nth (p+1))) ns
3.1667 + then Pbl else Frm)
3.1668 + else if (null o children o (nth p)) ns
3.1669 + then raise PTREE "no children"
3.1670 + else (P @ [p, 1], if (is_pblnd o hd o children o (nth p)) ns
3.1671 + then Pbl else Frm)
3.1672 + | _ => if (null o children o (nth p)) ns
3.1673 + then raise PTREE "no children"
3.1674 + else (P @ [p, 1], (*go down*)
3.1675 + if (is_pblnd o hd o children o (nth p)) ns
3.1676 + then Pbl else Frm);
3.1677 +
3.1678 +
3.1679 +
3.1680 +(*.go to the previous position in ptree; regard TransitiveB.*)
3.1681 +fun move_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*)
3.1682 + if is_pblobj c
3.1683 + then case p_ of Res => if null ns then ([], Pbl) (*Res -> Pbl (not Met)!*)
3.1684 + else ([length ns], Res)
3.1685 + | _ => raise PTREE "begin of calculation"
3.1686 + else raise PTREE "pos not existent"
3.1687 +
3.1688 + | move_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = (*iterate to end of pos*)
3.1689 + if p > length ns then raise PTREE "pos not existent"
3.1690 + else move_up (P@[p]) (nth p ns) (ps,p_)
3.1691 +
3.1692 + | move_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
3.1693 + if p > length ns then raise PTREE "pos not existent"
3.1694 + else if is_pblnd (nth p ns) then
3.1695 + case p_ of Res =>
3.1696 + let val nc = (length o children o (nth p)) ns
3.1697 + in if nc = 0 then (P@[p], Pbl) (*Res -> Pbl (not Met)!*)
3.1698 + else (P @ [p, nc], Res) end (*go down*)
3.1699 + | _ => if p = 1 then (P, Pbl) else (P@[p-1], Res)
3.1700 + else case p_ of Frm => if p <> 1 then (P, Frm)
3.1701 + else if is_pblobj c then (P, Pbl) else (P, Frm)
3.1702 + | Res =>
3.1703 + let val nc = (length o children o (nth p)) ns
3.1704 + in if nc = 0 (*cannot go down*)
3.1705 + then if g_branch c = TransitiveB andalso p <> 1
3.1706 + then (P@[p-1], Res) else (P@[p], Frm)
3.1707 + else (P @ [p, nc], Res) end; (*go down*)
3.1708 +
3.1709 +
3.1710 +
3.1711 +(*.go one level up in ptree; sets the position on Frm.*)
3.1712 +fun movelevel_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*)
3.1713 + raise PTREE "pos not existent"
3.1714 +
3.1715 + (*iterate towards end of pos*)
3.1716 + | movelevel_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
3.1717 + if p > length ns then raise PTREE "pos not existent"
3.1718 + else movelevel_up (P@[p]) (nth p ns) (ps,p_)
3.1719 +
3.1720 + | movelevel_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
3.1721 + if p > length ns then raise PTREE "pos not existent"
3.1722 + else if is_pblobj c then (P, Pbl) else (P, Frm);
3.1723 +
3.1724 +
3.1725 +(*.go to the next calc-head up in the calc-tree.*)
3.1726 +fun movecalchd_up pt ((p, Res):pos') =
3.1727 + (par_pblobj pt p, Pbl):pos'
3.1728 + | movecalchd_up pt (p, _) =
3.1729 + if is_pblobj (get_obj I pt p)
3.1730 + then (p, Pbl) else (par_pblobj pt p, Pbl);
3.1731 +
3.1732 +(*.determine the previous pos' on the same level.*)
3.1733 +(*WN0502 made for interSteps; _only_ works for branch TransitiveB*)
3.1734 +fun lev_pred' pt (pos:pos' as ([],Res)) = ([],Pbl):pos'
3.1735 + | lev_pred' pt (pos:pos' as (p, Res)) =
3.1736 + let val (p', last) = split_last p
3.1737 + in if last = 1
3.1738 + then if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
3.1739 + else if get_obj g_res pt (p' @ [last - 1]) = get_obj g_form pt p
3.1740 + then (p' @ [last - 1], Res) (*TransitiveB*)
3.1741 + else if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
3.1742 + end;
3.1743 +
3.1744 +(*.determine the next pos' on the same level.*)
3.1745 +fun lev_on' pt (([],Pbl):pos') = ([],Res):pos'
3.1746 + | lev_on' pt (p, Res) =
3.1747 + if get_obj g_res pt p = get_obj g_form pt (lev_on p)(*TransitiveB*)
3.1748 + then if existpt' (lev_on p, Res) pt then (lev_on p, Res)
3.1749 + else raise error ("lev_on': (p, Res) -> (p, Res) not existent, \
3.1750 + \p = "^ints2str' (lev_on p))
3.1751 + else (lev_on p, Frm)
3.1752 + | lev_on' pt (p, _) =
3.1753 + if existpt' (p, Res) pt then (p, Res)
3.1754 + else raise error ("lev_on': (p, Frm) -> (p, Res) not existent, \
3.1755 + \p = "^ints2str' p);
3.1756 +
3.1757 +fun exist_lev_on' pt p = (lev_on' pt p; true) handle _ => false;
3.1758 +
3.1759 +(*.is the pos' at the last element of a calulation _AND_ can be continued.*)
3.1760 +(* val (pt, pos as (p,p_)) = (pt, ([1],Frm));
3.1761 + *)
3.1762 +fun is_curr_endof_calc pt (([],Res) : pos') = false
3.1763 + | is_curr_endof_calc pt (pos as (p,_)) =
3.1764 + not (exist_lev_on' pt pos)
3.1765 + andalso get_obj g_ostate pt (lev_up p) = Incomplete;
3.1766 +
3.1767 +
3.1768 +(**.insert into ctree and cut branches accordingly.**)
3.1769 +
3.1770 +(*.get all positions of certain intervals on the ctree.*)
3.1771 +(*OLD VERSION without move_dn; kept for occasional redesign
3.1772 + get all pos's to be cut in a ptree
3.1773 + below a pos or from a ptree list after i-th element (NO level_up).*)
3.1774 +fun get_allpos' (_:pos, _:posel) EmptyPtree = ([]:pos' list)
3.1775 + | get_allpos' (p, 1) (Nd (b, bs)) = (*p is pos of Nd*)
3.1776 + if g_ostate b = Incomplete
3.1777 + then ((*writeln("get_allpos' (p, 1) Incomplete: p="^ints2str' p);*)
3.1778 + [(p,Frm)] @ (get_allpos's (p, 1) bs)
3.1779 + )
3.1780 + else ((*writeln("get_allpos' (p, 1) else: p="^ints2str' p);*)
3.1781 + [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)]
3.1782 + )
3.1783 + (*WN041020 here we assume what is presented on the worksheet ?!*)
3.1784 + | get_allpos' (p, i) (Nd (b, bs)) = (*p is pos of Nd*)
3.1785 + if length bs > 0 orelse is_pblobj b
3.1786 + then if g_ostate b = Incomplete
3.1787 + then [(p,Frm)] @ (get_allpos's (p, 1) bs)
3.1788 + else [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)]
3.1789 + else
3.1790 + if g_ostate b = Incomplete
3.1791 + then []
3.1792 + else [(p,Res)]
3.1793 +(*WN041020 here we assume what is presented on the worksheet ?!*)
3.1794 +and get_allpos's _ [] = []
3.1795 + | get_allpos's (p, i) (pt::pts) = (*p is pos of parent-Nd*)
3.1796 + (get_allpos' (p@[i], i) pt) @ (get_allpos's (p, i+1) pts);
3.1797 +
3.1798 +(*.get all positions of certain intervals on the ctree.*)
3.1799 +(*NEW version WN050225*)
3.1800 +
3.1801 +
3.1802 +(*.cut branches.*)
3.1803 +(*before WN041019......
3.1804 +val cut_branch = (test_trans, curry take):
3.1805 + (ppobj -> bool) * (int -> ptree list -> ptree list);
3.1806 +.. formlery used for ...
3.1807 +fun cut_tree''' _ [] = EmptyPtree
3.1808 + | cut_tree''' pt pos =
3.1809 + let val (pt',cut) = appl_branch cut_branch pt pos
3.1810 + in if cut andalso length pos > 1 then cut_tree''' pt' (lev_up pos)
3.1811 + else pt' end;
3.1812 +*)
3.1813 +(*OLD version before WN050225*)
3.1814 +(*WN050106 like cut_level, but deletes exactly 1 node --- for tests ONLY*)
3.1815 +fun cut_level_'_ (_:pos' list) (_:pos) EmptyPtree (_:pos') =
3.1816 + raise PTREE "cut_level_'_ Empty _"
3.1817 + | cut_level_'_ _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level_'_ _ []"
3.1818 + | cut_level_'_ cuts P (Nd (b, bs)) (p::[],p_) =
3.1819 + if test_trans b
3.1820 + then (Nd (b, drop_nth [] (p:posel, bs)),
3.1821 + (* ~~~~~~~~~~~*)
3.1822 + cuts @
3.1823 + (if p_ = Frm then [(P@[p],Res)] else ([]:pos' list)) @
3.1824 + (*WN041020 here we assume what is presented on the worksheet ?!*)
3.1825 + (get_allpos's (P, p+1) (drop_nth [] (p, bs))))
3.1826 + (* ~~~~~~~~~~~*)
3.1827 + else (Nd (b, bs), cuts)
3.1828 + | cut_level_'_ cuts P (Nd (b, bs)) ((p::ps),p_) =
3.1829 + let val (bs',cuts') = cut_level_'_ cuts P (nth p bs) (ps, p_)
3.1830 + in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
3.1831 +
3.1832 +(*before WN050219*)
3.1833 +fun cut_level (_:pos' list) (_:pos) EmptyPtree (_:pos') =
3.1834 + raise PTREE "cut_level EmptyPtree _"
3.1835 + | cut_level _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level _ []"
3.1836 +
3.1837 + | cut_level cuts P (Nd (b, bs)) (p::[],p_) =
3.1838 + if test_trans b
3.1839 + then (Nd (b, take (p:posel, bs)),
3.1840 + cuts @
3.1841 + (if p_ = Frm andalso (*#*) g_ostate b = Complete
3.1842 + then [(P@[p],Res)] else ([]:pos' list)) @
3.1843 + (*WN041020 here we assume what is presented on the worksheet ?!*)
3.1844 + (get_allpos's (P, p+1) (takerest (p, bs))))
3.1845 + else (Nd (b, bs), cuts)
3.1846 +
3.1847 + | cut_level cuts P (Nd (b, bs)) ((p::ps),p_) =
3.1848 + let val (bs',cuts') = cut_level cuts P (nth p bs) (ps, p_)
3.1849 + in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
3.1850 +
3.1851 +(*OLD version before WN050219, overwritten below*)
3.1852 +fun cut_tree _ (([],_):pos') = raise PTREE "cut_tree _ ([],_)"
3.1853 + | cut_tree pt (pos as ([p],_)) =
3.1854 + let val (pt', cuts) = cut_level ([]:pos' list) [] pt pos
3.1855 + in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete
3.1856 + then [] else [([],Res)])) end
3.1857 + | cut_tree pt (p,p_) =
3.1858 + let
3.1859 + fun cutfn pt cuts (p,p_) =
3.1860 + let val (pt', cuts') = cut_level [] (lev_up p) pt (p,p_)
3.1861 + val cuts'' = if get_obj g_ostate pt (lev_up p) = Incomplete
3.1862 + then [] else [(lev_up p, Res)]
3.1863 + in if length cuts' > 0 andalso length p > 1
3.1864 + then cutfn pt' (cuts @ cuts') (lev_up p, Frm(*-->(p,Res)*))
3.1865 + else (pt',cuts @ cuts') end
3.1866 + val (pt', cuts) = cutfn pt [] (p,p_)
3.1867 + in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete
3.1868 + then [] else [([], Res)])) end;
3.1869 +
3.1870 +
3.1871 +(*########/ inserted from ctreeNEW.sml \#################################**)
3.1872 +
3.1873 +(*.get all positions in a ptree until ([],Res) or ostate=Incomplete
3.1874 +val get_allp = fn :
3.1875 + pos' list -> : accumulated, start with []
3.1876 + pos -> : the offset for subtrees wrt the root
3.1877 + ptree -> : (sub)tree
3.1878 + pos' : initialization (the last pos' before ...)
3.1879 + -> pos' list : of positions in this (sub) tree (relative to the root)
3.1880 +.*)
3.1881 +(* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([], Frm):pos');
3.1882 + val (cuts, P, pt, pos) = ([], [2], get_nd pt [2], ([], Frm):pos');
3.1883 + length (children pt);
3.1884 + *)
3.1885 +fun get_allp (cuts:pos' list) (P:pos, pos:pos') pt =
3.1886 + (let val nxt = move_dn [] pt pos (*exn if Incomplete reached*)
3.1887 + in if nxt <> ([],Res)
3.1888 + then get_allp (cuts @ [nxt]) (P, nxt) pt
3.1889 + else (map (apfst (curry op@ P)) (cuts @ [nxt])): pos' list
3.1890 + end) handle PTREE _ => (map (apfst (curry op@ P)) cuts);
3.1891 +
3.1892 +
3.1893 +(*the pts are assumed to be on the same level*)
3.1894 +fun get_allps (cuts: pos' list) (P:pos) [] = cuts
3.1895 + | get_allps cuts P (pt::pts) =
3.1896 + let val below = get_allp [] (P, ([], Frm)) pt
3.1897 + val levfrm =
3.1898 + if is_pblnd pt
3.1899 + then (P, Pbl)::below
3.1900 + else if last_elem P = 1
3.1901 + then (P, Frm)::below
3.1902 + else (*Trans*) below
3.1903 + val levres = levfrm @ (if null below then [(P, Res)] else [])
3.1904 + in get_allps (cuts @ levres) (lev_on P) pts end;
3.1905 +
3.1906 +
3.1907 +(**.these 2 funs decide on how far cut_tree goes.**)
3.1908 +(*.shall the nodes _after_ the pos to be inserted at be deleted?.*)
3.1909 +fun test_trans (PrfObj{branch = Transitive,...}) = true
3.1910 + | test_trans (PrfObj{branch = NoBranch,...}) = true
3.1911 + | test_trans (PblObj{branch = Transitive,...}) = true
3.1912 + | test_trans (PblObj{branch = NoBranch,...}) = true
3.1913 + | test_trans _ = false;
3.1914 +(*.shall cutting be continued on the higher level(s)?
3.1915 + the Nd regarded will NOT be changed.*)
3.1916 +fun cutlevup (PblObj _) = false (*for tests of LK0502*)
3.1917 + | cutlevup _ = true;
3.1918 +val cutlevup = test_trans;(*WN060727 after summerterm tests.LK0502 withdrawn*)
3.1919 +
3.1920 +(*cut_bottom new sml603..608
3.1921 +cut the level at the bottom of the pos (used by cappend_...)
3.1922 +and handle the parent in order to avoid extra case for root
3.1923 +fn: ptree -> : the _whole_ ptree for cut_levup
3.1924 + pos * posel -> : the pos after split_last
3.1925 + ptree -> : the parent of the Nd to be cut
3.1926 +return
3.1927 + (ptree * : the updated ptree
3.1928 + pos' list) * : the pos's cut
3.1929 + bool : cutting shall be continued on the higher level(s)
3.1930 +*)
3.1931 +fun cut_bottom _ (pt' as Nd (b, [])) = ((pt', []), cutlevup b)
3.1932 + | cut_bottom (P:pos, p:posel) (Nd (b, bs)) =
3.1933 + let (*divide level into 3 parts...*)
3.1934 + val keep = take (p - 1, bs)
3.1935 + val pt' as Nd (_,bs') = nth p bs
3.1936 + (*^^^^^_here_ will be 'insert'ed by 'append_..'*)
3.1937 + val (tail, tp) = (takerest (p, bs),
3.1938 + if null (takerest (p, bs)) then 0 else p + 1)
3.1939 + val (children, cuts) =
3.1940 + if test_trans b
3.1941 + then (keep,
3.1942 + (if is_pblnd pt' then [(P @ [p], Pbl)] else [])
3.1943 + @ (get_allp [] (P @ [p], (P, Frm)) pt')
3.1944 + @ (get_allps [] (P @ [p+1]) tail))
3.1945 + else (keep @ [(*'insert'ed by 'append_..'*)] @ tail,
3.1946 + get_allp [] (P @ [p], (P, Frm)) pt')
3.1947 + val (pt'', cuts) =
3.1948 + if cutlevup b
3.1949 + then (Nd (del_res b, children),
3.1950 + cuts @ (if g_ostate b = Incomplete then [] else [(P,Res)]))
3.1951 + else (Nd (b, children), cuts)
3.1952 + (*val _= writeln("####cut_bottom (P, p)="^pos2str (P @ [p])^
3.1953 + ", Nd=.............................................")
3.1954 + val _= show_pt pt''
3.1955 + val _= writeln("####cut_bottom form='"^
3.1956 + term2str (get_obj g_form pt'' []))
3.1957 + val _= writeln("####cut_bottom cuts#="^string_of_int (length cuts)^
3.1958 + ", cuts="^pos's2str cuts)*)
3.1959 + in ((pt'', cuts:pos' list), cutlevup b) end;
3.1960 +
3.1961 +
3.1962 +(*.go all levels from the bottom of 'pos' up to the root,
3.1963 + on each level compose the children of a node and accumulate the cut Nds
3.1964 +args
3.1965 + pos' list -> : for accumulation
3.1966 + bool -> : cutting shall be continued on the higher level(s)
3.1967 + ptree -> : the whole ptree for 'get_nd pt P' on each level
3.1968 + ptree -> : the Nd from the lower level for insertion at path
3.1969 + pos * posel -> : pos=path split for convenience
3.1970 + ptree -> : Nd the children of are under consideration on this call
3.1971 +returns :
3.1972 + ptree * pos' list : the updated parent-Nd and the pos's of the Nds cut
3.1973 +.*)
3.1974 +fun cut_levup (cuts:pos' list) clevup pt pt' (P:pos, p:posel) (Nd (b, bs)) =
3.1975 + let (*divide level into 3 parts...*)
3.1976 + val keep = take (p - 1, bs)
3.1977 + (*val pt' comes as argument from below*)
3.1978 + val (tail, tp) = (takerest (p, bs),
3.1979 + if null (takerest (p, bs)) then 0 else p + 1)
3.1980 + val (children, cuts') =
3.1981 + if clevup
3.1982 + then (keep @ [pt'], get_allps [] (P @ [p+1]) tail)
3.1983 + else (keep @ [pt'] @ tail, [])
3.1984 + val clevup' = if clevup then cutlevup b else false
3.1985 + (*the first Nd with false stops cutting on all levels above*)
3.1986 + val (pt'', cuts') =
3.1987 + if clevup'
3.1988 + then (Nd (del_res b, children),
3.1989 + cuts' @ (if g_ostate b = Incomplete then [] else [(P,Res)]))
3.1990 + else (Nd (b, children), cuts')
3.1991 + (*val _= writeln("#####cut_levup clevup= "^bool2str clevup)
3.1992 + val _= writeln("#####cut_levup cutlevup b= "^bool2str (cutlevup b))
3.1993 + val _= writeln("#####cut_levup (P, p)="^pos2str (P @ [p])^
3.1994 + ", Nd=.............................................")
3.1995 + val _= show_pt pt''
3.1996 + val _= writeln("#####cut_levup form='"^
3.1997 + term2str (get_obj g_form pt'' []))
3.1998 + val _= writeln("#####cut_levup cuts#="^string_of_int (length cuts)^
3.1999 + ", cuts="^pos's2str cuts)*)
3.2000 + in if null P then (pt'', (cuts @ cuts'):pos' list)
3.2001 + else let val (P, p) = split_last P
3.2002 + in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P)
3.2003 + end
3.2004 + end;
3.2005 +
3.2006 +(*.cut nodes after and below an inserted node in the ctree;
3.2007 + the cuts range is limited by the predicate 'fun cutlevup'.*)
3.2008 +fun cut_tree pt (pos,_) =
3.2009 + if not (existpt pos pt)
3.2010 + then (pt,[]) (*appending a formula never cuts anything*)
3.2011 + else let val (P, p) = split_last pos
3.2012 + val ((pt', cuts), clevup) = cut_bottom (P, p) (get_nd pt P)
3.2013 + (* pt' is the updated parent of the Nd to cappend_..*)
3.2014 + in if null P then (pt', cuts)
3.2015 + else let val (P, p) = split_last P
3.2016 + in cut_levup cuts clevup pt pt' (P, p) (get_nd pt P)
3.2017 + end
3.2018 + end;
3.2019 +
3.2020 +fun append_atomic p l f r f' s pt =
3.2021 + let (**val _= writeln("#@append_atomic: pos ="^pos2str p)**)
3.2022 + val (iss, f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
3.2023 + then (*after Take*)
3.2024 + ((fst (get_obj g_loc pt p), Some l),
3.2025 + get_obj g_form pt p)
3.2026 + else ((None, Some l), f)
3.2027 + in insert (PrfObj {cell = None,
3.2028 + form = f,
3.2029 + tac = r,
3.2030 + loc = iss,
3.2031 + branch= NoBranch,
3.2032 + result= f',
3.2033 + ostate= s}) pt p end;
3.2034 +
3.2035 +
3.2036 +(*20.8.02: cappend_* FIXXXXME cut branches below cannot be decided here:
3.2037 + detail - generate - cappend: inserted, not appended !!!
3.2038 +
3.2039 + cut decided in applicable_in !?!
3.2040 +*)
3.2041 +fun cappend_atomic pt p loc f r f' s =
3.2042 +(* val (pt, p, loc, f, r, f', s) =
3.2043 + (pt,p,l,f,Rewrite_Set_Inst (subst2subs subs',id_rls rls'),
3.2044 + (f',asm),Complete);
3.2045 + *)
3.2046 +((*writeln("##@cappend_atomic: pos ="^pos2str p);*)
3.2047 + apfst (append_atomic p loc f r f' s) (cut_tree pt (p,Frm))
3.2048 +);
3.2049 +(*TODO.WN050305 redesign the handling of istates*)
3.2050 +fun cappend_atomic pt p ist_res f r f' s =
3.2051 + if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
3.2052 + then (*after Take: transfer Frm and respective istate*)
3.2053 + let val (ist_form, f) = (get_loc pt (p,Frm),
3.2054 + get_obj g_form pt p)
3.2055 + val (pt, cs) = cut_tree pt (p,Frm)
3.2056 + val pt = append_atomic p e_istate f r f' s pt
3.2057 + val pt = update_loc' pt p (Some ist_form, Some ist_res)
3.2058 + in (pt, cs) end
3.2059 + else apfst (append_atomic p ist_res f r f' s) (cut_tree pt (p,Frm));
3.2060 +
3.2061 +
3.2062 +(* called by Take *)
3.2063 +fun append_form p l f pt =
3.2064 +((*writeln("##@append_form: pos ="^pos2str p);*)
3.2065 + insert (PrfObj {cell = None,
3.2066 + form = (*if existpt p pt
3.2067 + andalso get_obj g_tac pt p = Empty_Tac
3.2068 + (*distinction from 'old' (+complete!) pobjs*)
3.2069 + then get_obj g_form pt p else*) f,
3.2070 + tac = Empty_Tac,
3.2071 + loc = (Some l, None),
3.2072 + branch= NoBranch,
3.2073 + result= (e_term,[]),
3.2074 + ostate= Incomplete}) pt p
3.2075 +);
3.2076 +(* val (p,loc,f) = ([1], e_istate, str2term "x + 1 = 2");
3.2077 + val (p,loc,f) = (fst p, e_istate, str2term "-1 + x = 0");
3.2078 + *)
3.2079 +fun cappend_form pt p loc f =
3.2080 +((*writeln("##@cappend_form: pos ="^pos2str p);*)
3.2081 + apfst (append_form p loc f) (cut_tree pt (p,Frm))
3.2082 +);
3.2083 +fun cappend_form pt p loc f =
3.2084 +let (*val _= writeln("##@cappend_form: pos ="^pos2str p)
3.2085 + val _= writeln("##@cappend_form before cut_tree: loc ="^istate2str loc)*)
3.2086 + val (pt', cs) = cut_tree pt (p,Frm)
3.2087 + val pt'' = append_form p loc f pt'
3.2088 + (*val _= writeln("##@cappend_form after append: loc ="^
3.2089 + istates2str (get_obj g_loc pt'' p))*)
3.2090 +in (pt'', cs) end;
3.2091 +
3.2092 +
3.2093 +
3.2094 +fun append_result pt p l f s =
3.2095 +((*writeln("##@append_result: pos ="^pos2str p);*)
3.2096 + (appl_obj (repl_result (fst (get_obj g_loc pt p),
3.2097 + Some l) f s) pt p, [])
3.2098 +);
3.2099 +
3.2100 +
3.2101 +(*WN041022 deprecated, still for kbtest/diffapp.sml, /systest/root-equ.sml*)
3.2102 +fun append_parent p l f r b pt =
3.2103 + let (*val _= writeln("###append_parent: pos ="^pos2str p);*)
3.2104 + val (ll,f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
3.2105 + then ((fst (get_obj g_loc pt p), Some l),
3.2106 + get_obj g_form pt p)
3.2107 + else ((Some l, None), f)
3.2108 + in insert (PrfObj
3.2109 + {cell = None,
3.2110 + form = f,
3.2111 + tac = r,
3.2112 + loc = ll,
3.2113 + branch= b,
3.2114 + result= (e_term,[]),
3.2115 + ostate= Incomplete}) pt p end;
3.2116 +fun cappend_parent pt p loc f r b =
3.2117 +((*writeln("###cappend_parent: pos ="^pos2str p);*)
3.2118 + apfst (append_parent p loc f r b) (cut_tree pt (p,Und))
3.2119 +);
3.2120 +
3.2121 +
3.2122 +fun append_problem [] l fmz (strs,spec,hdf) _ =
3.2123 +((*writeln("###append_problem: pos = []");*)
3.2124 + (Nd (PblObj
3.2125 + {cell = None,
3.2126 + origin= (strs,spec,hdf),
3.2127 + fmz = fmz,
3.2128 + spec = empty_spec,
3.2129 + probl = []:itm list,
3.2130 + meth = []:itm list,
3.2131 + env = None,
3.2132 + loc = (Some l, None),
3.2133 + branch= TransitiveB,(*FIXXXXXME.27.8.03: for equations only*)
3.2134 + result= (e_term,[]),
3.2135 + ostate= Incomplete},[]))
3.2136 +)
3.2137 + | append_problem p l fmz (strs,spec,hdf) pt =
3.2138 +((*writeln("###append_problem: pos ="^pos2str p);*)
3.2139 + insert (PblObj
3.2140 + {cell = None,
3.2141 + origin= (strs,spec,hdf),
3.2142 + fmz = fmz,
3.2143 + spec = empty_spec,
3.2144 + probl = []:itm list,
3.2145 + meth = []:itm list,
3.2146 + env = None,
3.2147 + loc = (Some l, None),
3.2148 + branch= TransitiveB,
3.2149 + result= (e_term,[]),
3.2150 + ostate= Incomplete}) pt p
3.2151 +);
3.2152 +fun cappend_problem _ [] loc fmz ori =
3.2153 +((*writeln("###cappend_problem: pos = []");*)
3.2154 + (append_problem [] loc fmz ori EmptyPtree,[])
3.2155 +)
3.2156 + | cappend_problem pt p loc fmz ori =
3.2157 +((*writeln("###cappend_problem: pos ="^pos2str p);*)
3.2158 + apfst (append_problem p (loc:istate) fmz ori) (cut_tree pt (p,Frm))
3.2159 +);
3.2160 +
3.2161 +(*.get the theory explicitly specified for the rootpbl;
3.2162 + thus use this function _after_ finishing specification.*)
3.2163 +fun rootthy (Nd (PblObj {spec=(thyID, _, _),...}, _)) = assoc_thy thyID
3.2164 + | rootthy _ = raise error "rootthy";
3.2165 +
4.1 --- a/src/sml/ME/rewtools.sml Mon Dec 31 09:55:43 2007 +0100
4.2 +++ b/src/sml/ME/rewtools.sml Mon Dec 31 14:18:53 2007 +0100
4.3 @@ -612,6 +612,26 @@
4.4 > thms_of_rls rls;
4.5 *)
4.6
4.7 +(**. get all rules in a rule set (recursivley containing rule sets)
4.8 + applicable to a given formula.**)
4.9 +fun try_rew thy ((_, ro) : rew_ord) erls (subst : subst) f
4.10 + (thm' as Thm (_, thm)) =
4.11 + if contains_bdv thm
4.12 + then case rewrite_inst_ thy ro erls false subst thm f of
4.13 + Some _ => [rule2tac subst thm']
4.14 + | None => []
4.15 + else (case rewrite_ thy ro erls false thm f of
4.16 + Some_ => [rule2tac [] thm']
4.17 + | None => [])
4.18 + | try_rew thy _ _ _ f (cal as Calc c) =
4.19 + (case get_calculation_ thy c f of
4.20 + Some _ => [rule2tac [] cal]
4.21 + | None => [])
4.22 + | try_rew thy _ _ subst f (Rls_ rls) =
4.23 + flat (filter_appl_rews thy subst f rls)
4.24 +and filter_appl_rews thy subst f (Rls {rew_ord = ro, erls, rules,...}) =
4.25 + map (try_rew thy ro erls subst f) rules;
4.26 +
4.27 (*.not only for thydata, but also for thy's etc.*)
4.28 fun theID2guh (theID:theID) =
4.29 case length theID of
5.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2 +++ b/src/sml/ME/script.sml Mon Dec 31 14:18:53 2007 +0100
5.3 @@ -0,0 +1,2029 @@
5.4 +(* interpreter for scripts
5.5 + (c) Walther Neuper 2000
5.6 +
5.7 +use"ME/script.sml";
5.8 +use"script.sml";
5.9 +*)
5.10 +
5.11 +signature INTERPRETER =
5.12 +sig
5.13 + (*type ets (list of executed tactics) see sequent.sml*)
5.14 +
5.15 + datatype locate
5.16 + = NotLocatable
5.17 + | Steps of (tac_ * mout * ptree * pos' * cid * safe (* ets*)) list
5.18 +(* | ToDo of ets 28.4.02*)
5.19 +
5.20 + (*diss: next-tactic-function*)
5.21 + val next_tac : theory' -> ptree * pos' -> metID -> scr -> ets -> tac_
5.22 + (*diss: locate-function*)
5.23 + val locate_gen : theory'
5.24 + -> tac_
5.25 + -> ptree * pos' -> scr * rls -> ets -> loc_ -> locate
5.26 +
5.27 + val sel_rules : ptree -> pos' -> tac list
5.28 + val init_form : scr -> ets -> loc_ * term option (*FIXME not up to date*)
5.29 + val formal_args : term -> term list
5.30 +
5.31 + (*shift to library ...*)
5.32 + val inst_abs : theory' -> term -> term
5.33 + val itms2args : metID -> itm list -> term list
5.34 + val user_interrupt : loc_ * (tac_ * env * env * term * term * safe)
5.35 + (*val empty : term*)
5.36 +end
5.37 +
5.38 +
5.39 +
5.40 +
5.41 +(*
5.42 +structure Interpreter : INTERPRETER =
5.43 +struct
5.44 +*)
5.45 +
5.46 +(*.traces the leaves (ie. non-tactical nodes) of the script
5.47 + found by next_tac.
5.48 + a leaf is either a tactic or an 'exp' in 'let v = expr'
5.49 + where 'exp' does not contain a tactic.*)
5.50 +val trace_script = ref false;
5.51 +
5.52 +type step = (*data for creating a new node in the ptree;
5.53 + designed for use:
5.54 + fun ass* scrstate steps =
5.55 + ... case ass* scrstate steps of
5.56 + Assoc (scrstate, steps) => ... ass* scrstate steps*)
5.57 + tac_ (*transformed from associated tac*)
5.58 + * mout (*result with indentation etc.*)
5.59 + * ptree (*containing node created by tac_ + resp. scrstate*)
5.60 + * pos' (*position in ptree; ptree * pos' is the proofstate*)
5.61 + * pos' list; (*of ptree-nodes probably cut (by fst tac_)*)
5.62 +val e_step = (Empty_Tac_, EmptyMout, EmptyPtree, e_pos',[]:pos' list):step;
5.63 +
5.64 +fun rule2thm' (Thm (id, thm)) = (id, string_of_thmI thm):thm'
5.65 + | rule2thm' r = raise error ("rule2thm': not defined for "^(rule2str r));
5.66 +fun rule2rls' (Rls_ rls) = id_rls rls
5.67 + | rule2rls' r = raise error ("rule2rls': not defined for "^(rule2str r));
5.68 +
5.69 +(*.makes a (rule,term) list to a Step (m, mout, pt', p', cid) for solve;
5.70 + complicated with current t in rrlsstate.*)
5.71 +fun rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) [(r, (f', am))] =
5.72 + let val thy = assoc_thy thy'
5.73 + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
5.74 + val is = RrlsState (f',f'',rss,rts)
5.75 + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
5.76 + val (p', cid, mout, pt') = generate1 thy m is p pt
5.77 + in (is, (m, mout, pt', p', cid)::steps) end
5.78 + | rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa))
5.79 + ((r, (f', am))::rts') =
5.80 + let val thy = assoc_thy thy'
5.81 + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
5.82 + val is = RrlsState (f',f'',rss,rts)
5.83 + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
5.84 + val (p', cid, mout, pt') = generate1 thy m is p pt
5.85 + in rts2steps ((m, mout, pt', p', cid)::steps)
5.86 + ((pt',p'),(f',f'',rss,rts),(thy',ro,er,pa)) rts' end;
5.87 +
5.88 +
5.89 +(*. functions for the environment stack .*)
5.90 +fun accessenv id es = the (assoc((top es):env, id))
5.91 + handle _ => error ("accessenv: "^(free2str id)^" not in env");
5.92 +fun updateenv id vl (es:env stack) =
5.93 + (push (overwrite(top es, (id, vl))) (pop es)):env stack;
5.94 +fun pushenv id vl (es:env stack) =
5.95 + (push (overwrite(top es, (id, vl))) es):env stack;
5.96 +val popenv = pop:env stack -> env stack;
5.97 +
5.98 +
5.99 +
5.100 +fun de_esc_underscore str =
5.101 + let fun scan [] = []
5.102 + | scan (s::ss) = if s = "'" then (scan ss)
5.103 + else (s::(scan ss))
5.104 + in (implode o scan o explode) str end;
5.105 +(*
5.106 +> val str = "Rewrite_Set_Inst";
5.107 +> val esc = esc_underscore str;
5.108 +val it = "Rewrite'_Set'_Inst" : string
5.109 +> val des = de_esc_underscore esc;
5.110 + val des = de_esc_underscore esc;*)
5.111 +
5.112 +
5.113 +(*WN.12.5.03 not used any more,
5.114 + tacs are more stable than listepxr: subst_tacexpr
5.115 +fun is_listexpr t =
5.116 + (((ids_of o head_of) t) inter (!listexpr)) <> [];
5.117 +----*)
5.118 +
5.119 +(*go at a location in a script and fetch the contents*)
5.120 +fun go [] t = t
5.121 + | go (D::p) (Abs(s,ty,t0)) = go (p:loc_) t0
5.122 + | go (L::p) (t1 $ t2) = go p t1
5.123 + | go (R::p) (t1 $ t2) = go p t2
5.124 + | go l _ = raise error ("go: no "^(loc_2str l));
5.125 +(*
5.126 +> val t = (term_of o the o (parse thy)) "a+b";
5.127 +val it = Const (#,#) $ Free (#,#) $ Free ("b","RealDef.real") : term
5.128 +> val plus_a = go [L] t;
5.129 +> val b = go [R] t;
5.130 +> val plus = go [L,L] t;
5.131 +> val a = go [L,R] t;
5.132 +
5.133 +> val t = (term_of o the o (parse thy)) "a+b+c";
5.134 +val t = Const (#,#) $ (# $ # $ Free #) $ Free ("c","RealDef.real") : term
5.135 +> val pl_pl_a_b = go [L] t;
5.136 +> val c = go [R] t;
5.137 +> val a = go [L,R,L,R] t;
5.138 +> val b = go [L,R,R] t;
5.139 +*)
5.140 +
5.141 +
5.142 +(* get a subterm t with test t, and record location *)
5.143 +fun get l test (t as Const (s,T)) =
5.144 + if test t then Some (l,t) else None
5.145 + | get l test (t as Free (s,T)) =
5.146 + if test t then Some (l,t) else None
5.147 + | get l test (t as Bound n) =
5.148 + if test t then Some (l,t) else None
5.149 + | get l test (t as Var (s,T)) =
5.150 + if test t then Some (l,t) else None
5.151 + | get l test (t as Abs (s,T,body)) =
5.152 + if test t then Some (l:loc_,t) else get ((l@[D]):loc_) test body
5.153 + | get l test (t as t1 $ t2) =
5.154 + if test t then Some (l,t)
5.155 + else case get (l@[L]) test t1 of
5.156 + None => get (l@[R]) test t2
5.157 + | Some (l',t') => Some (l',t');
5.158 +(*18.6.00
5.159 +> val sss = ((term_of o the o (parse thy))
5.160 + "Script Solve_root_equation (eq_::bool) (v_::real) (err_::bool) =\
5.161 + \ (let e_ = Try (Rewrite square_equation_left True eq_) \
5.162 + \ in [e_])");
5.163 + ______ compares head_of !!
5.164 +> get [] (eq_str "Let") sss; [R]
5.165 +> get [] (eq_str "Script.Try") sss; [R,L,R]
5.166 +> get [] (eq_str "Script.Rewrite") sss; [R,L,R,R]
5.167 +> get [] (eq_str "True") sss; [R,L,R,R,L,R]
5.168 +> get [] (eq_str "e_") sss; [R,R]
5.169 +*)
5.170 +
5.171 +fun test_negotiable t = ((strip_thy o (term_str Script.thy) o head_of) t)
5.172 + mem (!negotiable);
5.173 +
5.174 +(*30.4.02: vvv--- doesnt work with curried functions ---> get_tac ------
5.175 +(*18.6.00: below _ALL_ negotiables must be in fun-patterns !
5.176 + then the last (non)pattern must be a subproblem*)
5.177 +fun init_frm thy (Const ("Script.Rewrite",_) $ _ $ _ $ eq) = Some eq
5.178 + | init_frm thy (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ eq) = Some eq
5.179 + | init_frm thy (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ eq) = Some eq
5.180 + | init_frm thy (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ eq) =
5.181 + Some eq
5.182 + | init_frm thy (Const ("Script.Calculate",_) $ _ $ t) = Some t
5.183 + | init_frm thy t =
5.184 + (*if ((strip_thy o (term_str thy) o head_of) t) mem (!subpbls)
5.185 + then None
5.186 + else *)raise error ("init_frm: not impl. for "^
5.187 + (Sign.string_of_term (sign_of thy) t));
5.188 +
5.189 +> val t = (term_of o the o (parse thy))
5.190 + "Rewrite square_equation_left True (sqrt(#9+#4*x)=sqrt x + sqrt(#5+x))";
5.191 +> val Some ini = init_frm thy t;
5.192 +> Sign.string_of_term (sign_of thy) ini;
5.193 +val it = "sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)" : string
5.194 +
5.195 +> val t = (term_of o the o (parse thy))
5.196 + "solve_univar (Reals, [univar,equation], no_met) e1_ v1_";
5.197 +> val ini = init_frm thy t;
5.198 +> Sign.string_of_term (sign_of thy) ini;
5.199 +val it = "empty" : string
5.200 +
5.201 +> val t = (term_of o the o (parse thy))
5.202 + "Rewrite_Set norm_equation False x + #1 = #2";
5.203 +> val Some ini = init_frm thy t;
5.204 +> Sign.string_of_term (sign_of thy) ini;
5.205 +val it = "x + #1 = #2" : string
5.206 +
5.207 +> val t = (term_of o the o (parse thy))
5.208 + "Rewrite_Set_Inst [(bdv,x)] isolate_bdv False x + #1 = #2";
5.209 +> val Some ini = init_frm thy t;
5.210 +> Sign.string_of_term (sign_of thy) ini;
5.211 +val it = "x + #1 = #2" : string *)
5.212 +
5.213 +
5.214 +(*.get argument of first stactic in a script for init_form.*)
5.215 +fun get_stac thy (h $ body) =
5.216 +(*
5.217 + *)
5.218 + let
5.219 + fun get_t y (Const ("Script.Seq",_) $ e1 $ e2) a =
5.220 + (case get_t y e1 a of None => get_t y e2 a | la => la)
5.221 + | get_t y (Const ("Script.Seq",_) $ e1 $ e2 $ a) _ =
5.222 + (case get_t y e1 a of None => get_t y e2 a | la => la)
5.223 + | get_t y (Const ("Script.Try",_) $ e) a = get_t y e a
5.224 + | get_t y (Const ("Script.Try",_) $ e $ a) _ = get_t y e a
5.225 + | get_t y (Const ("Script.Repeat",_) $ e) a = get_t y e a
5.226 + | get_t y (Const ("Script.Repeat",_) $ e $ a) _ = get_t y e a
5.227 + | get_t y (Const ("Script.Or",_) $e1 $ e2) a =
5.228 + (case get_t y e1 a of None => get_t y e2 a | la => la)
5.229 + | get_t y (Const ("Script.Or",_) $e1 $ e2 $ a) _ =
5.230 + (case get_t y e1 a of None => get_t y e2 a | la => la)
5.231 + | get_t y (Const ("Script.While",_) $ c $ e) a = get_t y e a
5.232 + | get_t y (Const ("Script.While",_) $ c $ e $ a) _ = get_t y e a
5.233 + | get_t y (Const ("Script.Letpar",_) $ e1 $ Abs (_,_,e2)) a =
5.234 + (case get_t y e1 a of None => get_t y e2 a | la => la)
5.235 + (*| get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
5.236 + (writeln("get_t: Let e1= "^(term2str e1)^", e2= "^(term2str e2));
5.237 + case get_t y e1 a of None => get_t y e2 a | la => la)
5.238 + | get_t y (Abs (_,_,e)) a = get_t y e a*)
5.239 + | get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
5.240 + get_t y e1 a (*don't go deeper without evaluation !*)
5.241 + | get_t y (Const ("If",_) $ c $ e1 $ e2) a = None
5.242 + (*(case get_t y e1 a of None => get_t y e2 a | la => la)*)
5.243 +
5.244 + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ $ a) _ = Some a
5.245 + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ ) a = Some a
5.246 + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ a) _ = Some a
5.247 + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ ) a = Some a
5.248 + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ a) _ = Some a
5.249 + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ ) a = Some a
5.250 + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $a)_ =Some a
5.251 + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ ) a =Some a
5.252 + | get_t y (Const ("Script.Calculate",_) $ _ $ a) _ = Some a
5.253 + | get_t y (Const ("Script.Calculate",_) $ _ ) a = Some a
5.254 +
5.255 + | get_t y (Const ("Script.Substitute",_) $ _ $ a) _ = Some a
5.256 + | get_t y (Const ("Script.Substitute",_) $ _ ) a = Some a
5.257 +
5.258 + | get_t y (Const ("Script.SubProblem",_) $ _ $ _) _ = None
5.259 +
5.260 + | get_t y x _ =
5.261 + ((*writeln ("### get_t yac: list-expr "^(term2str x));*)
5.262 + None)
5.263 +in get_t thy body e_term end;
5.264 +
5.265 +(*FIXME: get 1st stac by next_stac [] instead of ... ?? 29.7.02*)
5.266 +(* val Script sc = scr;
5.267 + *)
5.268 +fun init_form thy (Script sc) env =
5.269 + (case get_stac thy sc of
5.270 + None => None (*raise error ("init_form: no 1st stac in "^
5.271 + (Sign.string_of_term (sign_of thy) sc))*)
5.272 + | Some stac => Some (subst_atomic env stac))
5.273 + | init_form _ _ _ = raise error "init_form: no match";
5.274 +
5.275 +(* use"ME/script.sml";
5.276 + use"script.sml";
5.277 + *)
5.278 +
5.279 +
5.280 +
5.281 +(*the 'iteration-argument' of a stac (args not eval)*)
5.282 +fun itr_arg _ (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ v) = v
5.283 + | itr_arg _ (Const ("Script.Rewrite",_) $ _ $ _ $ v) = v
5.284 + | itr_arg _ (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ v) = v
5.285 + | itr_arg _ (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ v) = v
5.286 + | itr_arg _ (Const ("Script.Calculate",_) $ _ $ v) = v
5.287 + | itr_arg _ (Const ("Script.Check'_elementwise",_) $ consts $ _) = consts
5.288 + | itr_arg _ (Const ("Script.Or'_to'_List",_) $ _) = e_term
5.289 + | itr_arg _ (Const ("Script.Tac",_) $ _) = e_term
5.290 + | itr_arg _ (Const ("Script.SubProblem",_) $ _ $ _) = e_term
5.291 + | itr_arg thy t = raise error
5.292 + ("itr_arg not impl. for "^
5.293 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));
5.294 +(* val t = (term_of o the o (parse thy))"Rewrite rroot_square_inv False e_";
5.295 +> itr_arg "Script.thy" t;
5.296 +val it = Free ("e_","RealDef.real") : term
5.297 +> val t = (term_of o the o (parse thy))"xxx";
5.298 +> itr_arg "Script.thy" t;
5.299 +*** itr_arg not impl. for xxx
5.300 +uncaught exception ERROR
5.301 + raised at: library.ML:1114.35-1114.40*)
5.302 +
5.303 +
5.304 +(*.get the arguments of the script out of the scripts parsetree.*)
5.305 +fun formal_args scr = (fst o split_last o snd o strip_comb) scr;
5.306 +(*
5.307 +> formal_args scr;
5.308 + [Free ("f_","RealDef.real"),Free ("v_","RealDef.real"),
5.309 + Free ("eqs_","bool List.list")] : term list
5.310 +*)
5.311 +
5.312 +(*.get the identifier of the script out of the scripts parsetree.*)
5.313 +fun id_of_scr sc = (id_of o fst o strip_comb) sc;
5.314 +
5.315 +
5.316 +(*WN020526: not clear, when a is available in ass_up for eva-_true*)
5.317 +(*WN060906: in "fun handle_leaf" eg. uses "Some M__"(from some PREVIOUS
5.318 + curried Rewrite) for CURRENT value (which may be different from PREVIOUS);
5.319 + thus "None" must be set at the end of currying (ill designed anyway)*)
5.320 +fun upd_env_opt env (Some a, v) = upd_env env (a,v)
5.321 + | upd_env_opt env (None, v) =
5.322 + (writeln("*** upd_env_opt: (None,"^(term2str v)^")");env);
5.323 +
5.324 +
5.325 +type dsc = typ; (*<-> nam..unknow in Descript.thy*)
5.326 +fun typ_str (Type (s,_)) = s
5.327 + | typ_str (TFree(s,_)) = s
5.328 + | typ_str (TVar ((s,i),_)) = s^(string_of_int i);
5.329 +
5.330 +(*get the _result_-type of a description*)
5.331 +fun dsc_valT (Const (_,(Type (_,[_,T])))) = (strip_thy o typ_str) T;
5.332 +(*> val t = (term_of o the o (parse thy)) "equality";
5.333 +> val T = type_of t;
5.334 +val T = "bool => Tools.una" : typ
5.335 +> val dsc = dsc_valT t;
5.336 +val dsc = "una" : string
5.337 +
5.338 +> val t = (term_of o the o (parse thy)) "fixedValues";
5.339 +> val T = type_of t;
5.340 +val T = "bool List.list => Tools.nam" : typ
5.341 +> val dsc = dsc_valT t;
5.342 +val dsc = "nam" : string*)
5.343 +
5.344 +(*.from penv in itm_ make args for script depending on type of description.*)
5.345 +(*6.5.03 TODO: push penv into script -- and drop mk_arg here || drop penv
5.346 + 9.5.03 penv postponed: penv = env for script at the moment, (*mk_arg*)*)
5.347 +fun mk_arg thy d [] = raise error ("mk_arg: no data for "^
5.348 + (Sign.string_of_term (sign_of thy) d))
5.349 + | mk_arg thy d [t] =
5.350 + (case dsc_valT d of
5.351 + "una" => [t]
5.352 + | "nam" =>
5.353 + [case t of
5.354 + r as (Const ("op =",_) $ _ $ _) => r
5.355 + | _ => raise error
5.356 + ("mk_arg: dsc-typ 'nam' applied to non-equality "^
5.357 + (Sign.string_of_term (sign_of thy) t))]
5.358 + | s => raise error ("mk_arg: not impl. for "^s))
5.359 +
5.360 + | mk_arg thy d (t::ts) = (mk_arg thy d [t]) @ (mk_arg thy d ts);
5.361 +(*
5.362 + val d = d_in itm_;
5.363 + val [t] = ts_in itm_;
5.364 +mk_arg thy
5.365 +*)
5.366 +
5.367 +
5.368 +
5.369 +
5.370 +(*.create the actual parameters (args) of script: their order
5.371 + is given by the order in met.pat .*)
5.372 +(*WN.5.5.03: ?: does this allow for different descriptions ???
5.373 + ?: why not taken from formal args of script ???
5.374 +!: FIXXXME penv: push it here in itms2args into script-evaluation*)
5.375 +(* val (thy, mI, itms) = (thy, metID, itms);
5.376 + *)
5.377 +fun itms2args thy mI (itms:itm list) =
5.378 + let val mvat = max_vt itms
5.379 + fun okv mvat (_,vats,b,_,_) = mvat mem vats andalso b
5.380 + val itms = filter (okv mvat) itms
5.381 + fun test_dsc d (_,_,_,_,itm_) = (d = d_in itm_)
5.382 + fun itm2arg itms (_,(d,_)) =
5.383 + case find_first (test_dsc d) itms of
5.384 + None =>
5.385 + raise error ("itms2args: '"^term2str d^"' not in itms")
5.386 + (*| Some (_,_,_,_,itm_) => mk_arg thy (d_in itm_) (ts_in itm_);
5.387 + penv postponed; presently penv holds already env for script*)
5.388 + | Some (_,_,_,_,itm_) => penvval_in itm_
5.389 + fun sel_given_find (s,_) = (s = "#Given") orelse (s = "#Find")
5.390 + val pats = (#ppc o get_met) mI
5.391 + in (flat o (map (itm2arg itms))) pats end;
5.392 +(*
5.393 +> val sc = ... Solve_root_equation ...
5.394 +> val mI = ("Script.thy","sqrt-equ-test");
5.395 +> val PblObj{meth={ppc=itms,...},...} = get_obj I pt [];
5.396 +> val ts = itms2args thy mI itms;
5.397 +> map (Sign.string_of_term (sign_of thy)) ts;
5.398 +["sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)","x","#0"] : string list
5.399 +*)
5.400 +
5.401 +
5.402 +(*["bool_ (1+x=2)","real_ x"] --match_ags--> oris
5.403 + --oris2fmz_vals--> ["equality (1+x=2)","boundVariable x","solutions L"]*)
5.404 +fun oris2fmz_vals oris =
5.405 + let fun ori2fmz_vals ((_,_,_,dsc,ts):ori) =
5.406 + ((term2str o comp_dts') (dsc, ts), last_elem ts)
5.407 + handle _ => raise error ("ori2fmz_env called with "^terms2str ts)
5.408 + in (split_list o (map ori2fmz_vals)) oris end;
5.409 +
5.410 +(*detour necessary, because generate1 delivers a string-result*)
5.411 +fun mout2term thy (Form' (FormKF (_,_,_,_,res))) =
5.412 + (term_of o the o (parse (assoc_thy thy))) res
5.413 + | mout2term thy (Form' (PpcKF _)) = e_term;(*3.8.01: res of subpbl
5.414 + at time of detection in script*)
5.415 +
5.416 +(*.convert a script-tac 'stac' to a tactic 'tac'; if stac is an initac,
5.417 + then convert to a 'tac_' (as required in appy).
5.418 + arg pt:ptree for pushing the thy specified in rootpbl into subpbls.*)
5.419 +fun stac2tac_ pt thy (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f) =
5.420 +(* val (pt, thy, (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f)) =
5.421 + (pt, (assoc_thy th), stac);
5.422 + *)
5.423 + let val tid = (de_esc_underscore o strip_thy) thmID
5.424 + in (Rewrite (tid, (string_of_thmI o
5.425 + (assoc_thm' thy)) (tid,"")), Empty_Tac_) end
5.426 +(* val (thy,
5.427 + mm as(Const ("Script.Rewrite'_Inst",_) $ sub $ Free(thmID,_) $ _ $ f))
5.428 + = (assoc_thy th,stac);
5.429 + stac2tac_ pt thy mm;
5.430 +
5.431 + assoc_thm' (assoc_thy "Isac.thy") (tid,"");
5.432 + assoc_thm' Isac.thy (tid,"");
5.433 + *)
5.434 + | stac2tac_ pt thy (Const ("Script.Rewrite'_Inst",_) $
5.435 + sub $ Free (thmID,_) $ _ $ f) =
5.436 + let val subML = ((map isapair2pair) o isalist2list) sub
5.437 + val subStr = subst2subs subML
5.438 + val tid = (de_esc_underscore o strip_thy) thmID (*4.10.02 unnoetig*)
5.439 + in (Rewrite_Inst
5.440 + (subStr, (tid, (string_of_thmI o
5.441 + (assoc_thm' thy)) (tid,""))), Empty_Tac_) end
5.442 +
5.443 + | stac2tac_ pt thy (Const ("Script.Rewrite'_Set",_) $ Free (rls,_) $ _ $ f)=
5.444 + (Rewrite_Set ((de_esc_underscore o strip_thy) rls), Empty_Tac_)
5.445 +
5.446 + | stac2tac_ pt thy (Const ("Script.Rewrite'_Set'_Inst",_) $
5.447 + sub $ Free (rls,_) $ _ $ f) =
5.448 + let val subML = ((map isapair2pair) o isalist2list) sub;
5.449 + val subStr = subst2subs subML;
5.450 + in (Rewrite_Set_Inst (subStr,rls), Empty_Tac_) end
5.451 +
5.452 + | stac2tac_ pt thy (Const ("Script.Calculate",_) $ Free (op_,_) $ f) =
5.453 + (Calculate op_, Empty_Tac_)
5.454 +
5.455 + | stac2tac_ pt thy (Const ("Script.Take",_) $ t) =
5.456 + (Take (term2str t), Empty_Tac_)
5.457 +
5.458 + | stac2tac_ pt thy (Const ("Script.Substitute",_) $ isasub $ arg) =
5.459 + (Substitute ((subte2sube o isalist2list) isasub), Empty_Tac_)
5.460 +(* val t = str2term"Substitute [x = L, M_b L = 0] (M_b x = q_0 * x + c)";
5.461 + val Const ("Script.Substitute", _) $ isasub $ arg = t;
5.462 + *)
5.463 +
5.464 +(*12.1.01.*)
5.465 + | stac2tac_ pt thy (Const("Script.Check'_elementwise",_) $ _ $
5.466 + (set as Const ("Collect",_) $ Abs (_,_,pred))) =
5.467 + (Check_elementwise (Sign.string_of_term (sign_of thy) pred),
5.468 + (*set*)Empty_Tac_)
5.469 +
5.470 + | stac2tac_ pt thy (Const("Script.Or'_to'_List",_) $ _ ) =
5.471 + (Or_to_List, Empty_Tac_)
5.472 +
5.473 +(*12.1.01.for subproblem_equation_dummy in root-equation *)
5.474 + | stac2tac_ pt thy (Const ("Script.Tac",_) $ Free (str,_)) =
5.475 + (Tac ((de_esc_underscore o strip_thy) str), Empty_Tac_)
5.476 + (*L_ will come from pt in appl_in*)
5.477 +
5.478 + (*3.12.03 copied from assod SubProblem*)
5.479 +(* val Const ("Script.SubProblem",_) $
5.480 + (Const ("Pair",_) $
5.481 + Free (dI',_) $
5.482 + (Const ("Pair",_) $ pI' $ mI')) $ ags' =
5.483 + str2term
5.484 + "SubProblem (EqSystem_, [linear, system], [no_met])\
5.485 + \ [bool_list_ [c_2 = 0, L * c + c_2 = q_0 * L ^^^ 2 / 2],\
5.486 + \ real_list_ [c, c_2]]";
5.487 +*)
5.488 + | stac2tac_ pt thy (stac as Const ("Script.SubProblem",_) $
5.489 + (Const ("Pair",_) $
5.490 + Free (dI',_) $
5.491 + (Const ("Pair",_) $ pI' $ mI')) $ ags') =
5.492 +(*compare "| assod _ (Subproblem'"*)
5.493 + let val dI = ((implode o drop_last(*.._*) o explode) dI')^".thy";
5.494 + val thy = maxthy (assoc_thy dI) (rootthy pt);
5.495 + val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI';
5.496 + val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI';
5.497 + val ags = isalist2list ags';
5.498 + val (pI, pors, mI) =
5.499 + if mI = ["no_met"]
5.500 + then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags)
5.501 + handle _ =>(match_ags_msg pI stac ags(*raise exn*);[])
5.502 + val pI' = refine_ori' pors pI;
5.503 + in (pI', pors (*refinement over models with diff.prec only*),
5.504 + (hd o #met o get_pbt) pI') end
5.505 + else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags)
5.506 + handle _ => (match_ags_msg pI stac ags(*raise exn*); []),
5.507 + mI);
5.508 + val (fmz_, vals) = oris2fmz_vals pors;
5.509 + val {cas,ppc,thy,...} = get_pbt pI
5.510 + val dI = theory2theory' thy (*.take dI from _refined_ pbl.*)
5.511 + val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt));
5.512 + val hdl = case cas of
5.513 + None => pblterm dI pI
5.514 + | Some t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t
5.515 + val f = subpbl (strip_thy dI) pI
5.516 + in (Subproblem (dI, pI),
5.517 + Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f))
5.518 + end
5.519 +
5.520 + | stac2tac_ pt thy t = raise error
5.521 + ("stac2tac_ TODO: no match for "^
5.522 + (Sign.string_of_term (sign_of thy) t));
5.523 +(*
5.524 +> val t = (term_of o the o (parse thy))
5.525 + "Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False (x=a+#1)";
5.526 +> stac2tac_ pt t;
5.527 +val it = Rewrite_Set_Inst ([(#,#)],"isolate_bdv") : tac
5.528 +
5.529 +> val t = (term_of o the o (parse SqRoot.thy))
5.530 +"(SubProblem (SqRoot_,[equation,univariate],(SqRoot_,solve_linear))\
5.531 + \ [bool_ e_, real_ v_])::bool list";
5.532 +> stac2tac_ pt SqRoot.thy t;
5.533 +val it = (Subproblem ("SqRoot.thy",[#,#]),Const (#,#) $ (# $ # $ (# $ #)))
5.534 +*)
5.535 +
5.536 +fun stac2tac pt thy t = (fst o stac2tac_ pt thy) t;
5.537 +
5.538 +
5.539 +
5.540 +
5.541 +(*test a term for being a _list_ (set ?) of constants; could be more rigorous*)
5.542 +fun list_of_consts (Const ("List.list.Cons",_) $ _ $ _) = true
5.543 + | list_of_consts (Const ("List.list.Nil",_)) = true
5.544 + | list_of_consts _ = false;
5.545 +(*val ttt = (term_of o the o (parse thy)) "[x=#1,x=#2,x=#3]";
5.546 +> list_of_consts ttt;
5.547 +val it = true : bool
5.548 +> val ttt = (term_of o the o (parse thy)) "[]";
5.549 +> list_of_consts ttt;
5.550 +val it = true : bool*)
5.551 +
5.552 +
5.553 +
5.554 +
5.555 +
5.556 +(* 15.1.01: evaluation of preds only works occasionally,
5.557 + but luckily for the 2 examples of root-equ:
5.558 +> val s = ((term_of o the o (parse thy)) "x",
5.559 + (term_of o the o (parse thy)) "-#5//#12");
5.560 +> val asm = (term_of o the o (parse thy))
5.561 + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)";
5.562 +> val pred = subst_atomic [s] asm;
5.563 +> rewrite_set_ thy false (cterm_of (sign_of thy) pred);
5.564 +val it = None : (cterm * cterm list) option !!!!!!!!!!!!!!!!!!!!!!!!!!!!
5.565 +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
5.566 +val it = false : bool
5.567 +
5.568 +> val s = ((term_of o the o (parse thy)) "x",
5.569 + (term_of o the o (parse thy)) "#4");
5.570 +> val asm = (term_of o the o (parse thy))
5.571 + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#5 + x)";
5.572 +> val pred = subst_atomic [s] asm;
5.573 +> rewrite_set_ thy false (cterm_of (sign_of thy) pred);
5.574 +val it = Some ("True & True",[]) : (cterm * cterm list) option
5.575 +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
5.576 +val it = true : bool`*)
5.577 +
5.578 +(*for check_elementwise: take apart the set, ev. instantiate assumptions
5.579 +fun rep_set thy pt p (set as Const ("Collect",_) $ Abs _) =
5.580 + let val (_ $ Abs (bdv,T,pred)) = inst_abs thy set;
5.581 + val bdv = Free (bdv,T);
5.582 + val pred = if pred <> Const ("Script.Assumptions",bool)
5.583 + then pred
5.584 + else (mk_and o (map fst)) (get_assumptions_ pt (p,Res))
5.585 + in (bdv, pred) end
5.586 + | rep_set thy _ _ set =
5.587 + raise error ("check_elementwise: no set "^ (*from script*)
5.588 + (Sign.string_of_term (sign_of thy) set));
5.589 +(*> val set = (term_of o the o (parse thy)) "{(x::real). Assumptions}";
5.590 +> val p = [];
5.591 +> val pt = union_asm pt p [("#0 <= sqrt x + sqrt (#5 + x)",[11]),
5.592 + ("#0 <= #9 + #4 * x",[22]),
5.593 + ("#0 <= x ^^^ #2 + #5 * x",[33]),
5.594 + ("#0 <= #2 + x",[44])];
5.595 +> val (bdv,pred) = rep_set thy pt p set;
5.596 +val bdv = Free ("x","RealDef.real") : term
5.597 +> writeln (Sign.string_of_term (sign_of thy) pred);
5.598 +((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) &
5.599 + #0 <= x ^^^ #2 + #5 * x) &
5.600 +#0 <= #2 + x
5.601 +*)
5.602 +--------------------------------------------11.6.03--was unused*)
5.603 +
5.604 +
5.605 +
5.606 +
5.607 +datatype ass =
5.608 + Ass of tac_ * (*SubProblem gets args instantiated in assod*)
5.609 + term (*for itr_arg,result in ets*)
5.610 +| AssWeak of tac_ *
5.611 + term (*for itr_arg,result in ets*)
5.612 +| NotAss;
5.613 +
5.614 +(*.assod: tac_ associated with stac w.r.t. d
5.615 +args
5.616 + pt:ptree for pushing the thy specified in rootpbl into subpbls
5.617 +returns
5.618 + Ass : associated: e.g. thmID in stac = thmID in m
5.619 + +++ arg in stac = arg in m
5.620 + AssWeak: weakly ass.:e.g. thmID in stac = thmID in m, //arg//
5.621 + NotAss : e.g. thmID in stac/=/thmID in m (not =)
5.622 +8.01:
5.623 + tac_ SubProblem with args completed from script
5.624 +.*)
5.625 +fun assod pt d (m as Rewrite_Inst' (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))
5.626 + (Const ("Script.Rewrite'_Inst",_) $ subs_ $ Free (thmID_,idT) $ b $ f_) =
5.627 + if thmID = thmID_ then
5.628 + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
5.629 + else ((*writeln"3### assod ..AssWeak";*)AssWeak(m, f'))
5.630 + else ((*writeln"3### assod ..NotAss";*)NotAss)
5.631 +
5.632 + | assod pt d (m as Rewrite' (thy,rod,rls,put,(thmID,thm),f,(f',asm)))
5.633 + (t as Const ("Script.Rewrite",_) $ Free (thmID_,idT) $ b $ f_) =
5.634 + ((*writeln("3### assod: stac = "^
5.635 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));
5.636 + writeln("3### assod: f(m)= "^
5.637 + (Sign.string_of_term (sign_of (assoc_thy thy)) f));*)
5.638 + if thmID = thmID_ then
5.639 + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
5.640 + else ((*writeln"### assod ..AssWeak";
5.641 + writeln("### assod: f(m) = "^
5.642 + (Sign.string_of_term (sign_of (assoc_thy thy)) f));
5.643 + writeln("### assod: f(stac)= "^
5.644 + (Sign.string_of_term (sign_of (assoc_thy thy)) f_));*)
5.645 + AssWeak (m,f'))
5.646 + else ((*writeln"3### assod ..NotAss";*)NotAss))
5.647 +
5.648 +(*val f = (term_of o the o (parse thy))"#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0";
5.649 +> val f'= (term_of o the o (parse thy))"#0+(sqrt(sqrt a))^^^#2=#0";
5.650 +> val m = Rewrite'("Script.thy","tless_true","eval_rls",false,
5.651 + ("rroot_square_inv",""),f,(f',[]));
5.652 +> val stac = (term_of o the o (parse thy))
5.653 + "Rewrite rroot_square_inv False (#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0)";
5.654 +> assod e_rls m stac;
5.655 +val it =
5.656 + (Some (Rewrite' (#,#,#,#,#,#,#)),Const ("empty","RealDef.real"),
5.657 + Const ("empty","RealDef.real")) : tac_ option * term * term*)
5.658 +
5.659 + | assod pt d (m as Rewrite_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
5.660 + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
5.661 + if id_rls rls = rls_ then
5.662 + if f = f_ then Ass (m,f') else AssWeak (m,f')
5.663 + else NotAss
5.664 +
5.665 + | assod pt d (m as Detail_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
5.666 + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
5.667 + if id_rls rls = rls_ then
5.668 + if f = f_ then Ass (m,f') else AssWeak (m,f')
5.669 + else NotAss
5.670 +
5.671 + | assod pt d (m as Rewrite_Set' (thy,put,rls,f,(f',asm)))
5.672 + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
5.673 + if id_rls rls = rls_ then
5.674 + if f = f_ then Ass (m,f') else AssWeak (m,f')
5.675 + else NotAss
5.676 +
5.677 + | assod pt d (m as Detail_Set' (thy,put,rls,f,(f',asm)))
5.678 + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
5.679 + if id_rls rls = rls_ then
5.680 + if f = f_ then Ass (m,f') else AssWeak (m,f')
5.681 + else NotAss
5.682 +
5.683 + | assod pt d (m as Calculate' (thy',op_,f,(f',thm')))
5.684 + (Const ("Script.Calculate",_) $ Free (op__,_) $ f_) =
5.685 + if op_ = op__ then
5.686 + if f = f_ then Ass (m,f') else AssWeak (m,f')
5.687 + else NotAss
5.688 +
5.689 + | assod pt _ (m as Check_elementwise' (consts,_,(consts_chkd,_)))
5.690 + (Const ("Script.Check'_elementwise",_) $ consts' $ _) =
5.691 + ((*writeln("### assod Check'_elementwise: consts= "^(term2str consts)^
5.692 + ", consts'= "^(term2str consts'));
5.693 + atomty consts; atomty consts';*)
5.694 + if consts = consts' then ((*writeln"### assod Check'_elementwise: Ass";*)
5.695 + Ass (m, consts_chkd))
5.696 + else ((*writeln"### assod Check'_elementwise: NotAss";*) NotAss))
5.697 +
5.698 + | assod pt _ (m as Or_to_List' (ors, list))
5.699 + (Const ("Script.Or'_to'_List",_) $ _) =
5.700 + Ass (m, list)
5.701 +
5.702 + | assod pt _ (m as Take' term)
5.703 + (Const ("Script.Take",_) $ _) =
5.704 + Ass (m, term)
5.705 +
5.706 + | assod pt _ (m as Substitute' (_, _, res))
5.707 + (Const ("Script.Substitute",_) $ _ $ _) =
5.708 + Ass (m, res)
5.709 +(* val t = str2term "Substitute [(x, 3)] (x^^^2 + x + 1)";
5.710 + val (Const ("Script.Substitute",_) $ _ $ _) = t;
5.711 + *)
5.712 +
5.713 + | assod pt _ (m as Tac_ (thy,f,id,f'))
5.714 + (Const ("Script.Tac",_) $ Free (id',_)) =
5.715 + if id = id' then Ass (m, ((term_of o the o (parse thy)) f'))
5.716 + else NotAss
5.717 +
5.718 +
5.719 +(* val t = str2term
5.720 + "SubProblem (DiffApp_,[make,function],[no_met]) \
5.721 + \[real_ m_, real_ v_, bool_list_ rs_]";
5.722 +
5.723 + val (Subproblem' ((domID,pblID,metID),_,_,_,f)) = m;
5.724 + val (Const ("Script.SubProblem",_) $
5.725 + (Const ("Pair",_) $
5.726 + Free (dI',_) $
5.727 + (Const ("Pair",_) $ pI' $ mI')) $ ags') = stac;
5.728 + *)
5.729 + | assod pt _ (Subproblem' ((domID,pblID,metID),_,_,_,f))
5.730 + (stac as Const ("Script.SubProblem",_) $
5.731 + (Const ("Pair",_) $
5.732 + Free (dI',_) $
5.733 + (Const ("Pair",_) $ pI' $ mI')) $ ags') =
5.734 +(*compare "| stac2tac_ thy (Const ("Script.SubProblem",_)"*)
5.735 + let val dI = ((implode o drop_last o explode) dI')^".thy";
5.736 + val thy = maxthy (assoc_thy dI) (rootthy pt);
5.737 + val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI';
5.738 + val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI';
5.739 + val ags = isalist2list ags';
5.740 + val (pI, pors, mI) =
5.741 + if mI = ["no_met"]
5.742 + then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags)
5.743 + handle _=>(match_ags_msg pI stac ags(*raise exn*);[]);
5.744 + val pI' = refine_ori' pors pI;
5.745 + in (pI', pors (*refinement over models with diff.prec only*),
5.746 + (hd o #met o get_pbt) pI') end
5.747 + else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags)
5.748 + handle _ => (match_ags_msg pI stac ags(*raise exn*);[]),
5.749 + mI);
5.750 + val (fmz_, vals) = oris2fmz_vals pors;
5.751 + val {cas, ppc,...} = get_pbt pI
5.752 + val {cas, ppc, thy,...} = get_pbt pI
5.753 + val dI = theory2theory' thy (*take dI from _refined_ pbl*)
5.754 + val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt))
5.755 + val hdl = case cas of
5.756 + None => pblterm dI pI
5.757 + | Some t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t
5.758 + val f = subpbl (strip_thy dI) pI
5.759 + in if domID = dI andalso pblID = pI
5.760 + then Ass (Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f), f)
5.761 + else NotAss
5.762 + end
5.763 +
5.764 + | assod pt d m t =
5.765 + (if (!trace_script)
5.766 + then writeln("@@@ the 'tac_' proposed to apply does NOT match the leaf found in the script:\n"^
5.767 + "@@@ tac_ = "^(tac_2str m))
5.768 + else ();
5.769 + NotAss);
5.770 +
5.771 +
5.772 +
5.773 +fun tac_2tac (Refine_Tacitly' (pI,_,_,_,_)) = Refine_Tacitly pI
5.774 + | tac_2tac (Model_Problem' (pI,_,_)) = Model_Problem
5.775 + | tac_2tac (Add_Given' (t,_)) = Add_Given t
5.776 + | tac_2tac (Add_Find' (t,_)) = Add_Find t
5.777 + | tac_2tac (Add_Relation' (t,_)) = Add_Relation t
5.778 +
5.779 + | tac_2tac (Specify_Theory' dI) = Specify_Theory dI
5.780 + | tac_2tac (Specify_Problem' (dI,_)) = Specify_Problem dI
5.781 + | tac_2tac (Specify_Method' (dI,_,_)) = Specify_Method dI
5.782 +
5.783 + | tac_2tac (Rewrite' (thy,rod,erls,put,(thmID,thm),f,(f',asm))) =
5.784 + Rewrite (thmID,thm)
5.785 +
5.786 + | tac_2tac (Rewrite_Inst' (thy,rod,erls,put,sub,(thmID,thm),f,(f',asm)))=
5.787 + Rewrite_Inst (subst2subs sub,(thmID,thm))
5.788 +
5.789 + | tac_2tac (Rewrite_Set' (thy,put,rls,f,(f',asm))) =
5.790 + Rewrite_Set (id_rls rls)
5.791 +
5.792 + | tac_2tac (Detail_Set' (thy,put,rls,f,(f',asm))) =
5.793 + Detail_Set (id_rls rls)
5.794 +
5.795 + | tac_2tac (Rewrite_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
5.796 + Rewrite_Set_Inst (subst2subs sub,id_rls rls)
5.797 +
5.798 + | tac_2tac (Detail_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
5.799 + Detail_Set_Inst (subst2subs sub,id_rls rls)
5.800 +
5.801 + | tac_2tac (Calculate' (thy,op_,t,(t',thm'))) = Calculate (op_)
5.802 +
5.803 + | tac_2tac (Check_elementwise' (consts,pred,consts')) =
5.804 + Check_elementwise pred
5.805 +
5.806 + | tac_2tac (Or_to_List' _) = Or_to_List
5.807 + | tac_2tac (Take' term) = Take (term2str term)
5.808 + | tac_2tac (Substitute' (subte, t, res)) = Substitute (subte2sube subte)
5.809 +
5.810 + | tac_2tac (Tac_ (_,f,id,f')) = Tac id
5.811 +
5.812 + | tac_2tac (Subproblem' ((domID, pblID, _), _, _,_,_)) =
5.813 + Subproblem (domID, pblID)
5.814 + | tac_2tac (Check_Postcond' (pblID, _)) =
5.815 + Check_Postcond pblID
5.816 + | tac_2tac Empty_Tac_ = Empty_Tac
5.817 +
5.818 + | tac_2tac m =
5.819 + raise error ("tac_2tac: not impl. for "^(tac_2str m));
5.820 +
5.821 +
5.822 +
5.823 +
5.824 +(** decompose tac_ to a rule and to (lhs,rhs)
5.825 + unly needed ~~~ **)
5.826 +
5.827 +val idT = Type ("Script.ID",[]);
5.828 +(*val tt = (term_of o the o (parse thy)) "square_equation_left::ID";
5.829 +type_of tt = idT;
5.830 +val it = true : bool
5.831 +*)
5.832 +(* 13.3.01
5.833 +v
5.834 +*)
5.835 +fun make_rule thy t =
5.836 + let val ct = cterm_of (sign_of thy) (Trueprop $ t)
5.837 + in Thm (string_of_cterm ct, make_thm ct) end;
5.838 +
5.839 +(* val (Rewrite_Inst'(thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))=m;
5.840 + *)
5.841 +(*decompose tac_ to a rule and to (lhs,rhs) for ets FIXME.12.03: obsolete!
5.842 + NOTE.12.03: also used for msg 'not locatable' ?!: 'Subproblem' missing !!!
5.843 +WN0508 only use in tac_2res, which uses only last return-value*)
5.844 +fun rep_tac_ (Rewrite_Inst'
5.845 + (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) =
5.846 + let val fT = type_of f;
5.847 + val b = if put then HOLogic.true_const else HOLogic.false_const;
5.848 + val sT = (type_of o fst o hd) subs;
5.849 + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
5.850 + (map HOLogic.mk_prod subs);
5.851 + val sT' = type_of subs';
5.852 + val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,(*fT*)bool,fT] ---> fT)
5.853 + $ subs' $ Free (thmID,idT) $ b $ f;
5.854 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
5.855 +(*Fehlersuche 25.4.01
5.856 +(a)----- als String zusammensetzen:
5.857 +ML> Sign.string_of_term (sign_of thy)f;
5.858 +val it = "d_d x #4 + d_d x (x ^^^ #2 + #3 * x)" : string
5.859 +ML> Sign.string_of_term (sign_of thy)f';
5.860 +val it = "#0 + d_d x (x ^^^ #2 + #3 * x)" : string
5.861 +ML> subs;
5.862 +val it = [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real"))] : subst
5.863 +> val tt = (term_of o the o (parse thy))
5.864 + "(Rewrite_Inst[(bdv,x)]diff_const False(d_d x #4 + d_d x (x ^^^ #2 + #3 * x)))=(#0 + d_d x (x ^^^ #2 + #3 * x))";
5.865 +> atomty tt;
5.866 +ML> writeln(Sign.string_of_term (sign_of thy)tt);
5.867 +(Rewrite_Inst [(bdv,x)] diff_const False d_d x #4 + d_d x (x ^^^ #2 + #3 * x)) =
5.868 + #0 + d_d x (x ^^^ #2 + #3 * x)
5.869 +
5.870 +(b)----- laut rep_tac_:
5.871 +> val ttt=HOLogic.mk_eq (lhs,f');
5.872 +> atomty ttt;
5.873 +
5.874 +
5.875 +(*Fehlersuche 1-2Monate vor 4.01:*)
5.876 +> val tt = (term_of o the o (parse thy))
5.877 + "Rewrite_Inst[(bdv,x)]square_equation_left True(x=#1+#2)";
5.878 +> atomty tt;
5.879 +
5.880 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
5.881 +> val f' = (term_of o the o (parse thy)) "x=#3";
5.882 +> val subs = [((term_of o the o (parse thy)) "bdv",
5.883 + (term_of o the o (parse thy)) "x")];
5.884 +> val sT = (type_of o fst o hd) subs;
5.885 +> val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
5.886 + (map HOLogic.mk_prod subs);
5.887 +> val sT' = type_of subs';
5.888 +> val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,fT,fT] ---> fT)
5.889 + $ subs' $ Free (thmID,idT) $ HOLogic.true_const $ f;
5.890 +> lhs = tt;
5.891 +val it = true : bool
5.892 +> rep_tac_ (Rewrite_Inst'
5.893 + ("Script.thy","tless_true","eval_rls",false,subs,
5.894 + ("square_equation_left",""),f,(f',[])));
5.895 +*)
5.896 + | rep_tac_ (Rewrite' (thy',rod,rls,put,(thmID,thm),f,(f',asm)))=
5.897 + let
5.898 + val fT = type_of f;
5.899 + val b = if put then HOLogic.true_const else HOLogic.false_const;
5.900 + val lhs = Const ("Script.Rewrite",[idT,HOLogic.boolT,fT] ---> fT)
5.901 + $ Free (thmID,idT) $ b $ f;
5.902 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
5.903 +(*
5.904 +> val tt = (term_of o the o (parse thy)) (*____ ____..test*)
5.905 + "Rewrite square_equation_left True (x=#1+#2) = (x=#3)";
5.906 +
5.907 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
5.908 +> val f' = (term_of o the o (parse thy)) "x=#3";
5.909 +> val Thm (id,thm) =
5.910 + rep_tac_ (Rewrite'
5.911 + ("Script.thy","tless_true","eval_rls",false,
5.912 + ("square_equation_left",""),f,(f',[])));
5.913 +> val Some ct = parse thy
5.914 + "Rewrite square_equation_left True (x=#1+#2)";
5.915 +> rewrite_ Script.thy tless_true eval_rls true thm ct;
5.916 +val it = Some ("x = #3",[]) : (cterm * cterm list) option
5.917 +*)
5.918 + | rep_tac_ (Rewrite_Set_Inst'
5.919 + (thy',put,subs,rls,f,(f',asm))) =
5.920 + (e_rule, (e_term, f'))
5.921 +(*WN050824: type error ...
5.922 + let val fT = type_of f;
5.923 + val sT = (type_of o fst o hd) subs;
5.924 + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
5.925 + (map HOLogic.mk_prod subs);
5.926 + val sT' = type_of subs';
5.927 + val b = if put then HOLogic.true_const else HOLogic.false_const
5.928 + val lhs = Const ("Script.Rewrite'_Set'_Inst",
5.929 + [sT',idT,fT,fT] ---> fT)
5.930 + $ subs' $ Free (id_rls rls,idT) $ b $ f;
5.931 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end*)
5.932 +(* ... vals from Rewrite_Inst' ...
5.933 +> rep_tac_ (Rewrite_Set_Inst'
5.934 + ("Script.thy",false,subs,
5.935 + "isolate_bdv",f,(f',[])));
5.936 +*)
5.937 +(* val (Rewrite_Set' (thy',put,rls,f,(f',asm)))=m;
5.938 +*)
5.939 + | rep_tac_ (Rewrite_Set' (thy',put,rls,f,(f',asm)))=
5.940 + let val fT = type_of f;
5.941 + val b = if put then HOLogic.true_const else HOLogic.false_const;
5.942 + val lhs = Const ("Script.Rewrite'_Set",[idT,bool,fT] ---> fT)
5.943 + $ Free (id_rls rls,idT) $ b $ f;
5.944 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
5.945 +(* 13.3.01:
5.946 +val thy = assoc_thy thy';
5.947 +val t = HOLogic.mk_eq (lhs,f');
5.948 +make_rule thy t;
5.949 +--------------------------------------------------
5.950 +val lll = (term_of o the o (parse thy))
5.951 + "Rewrite_Set SqRoot_simplify False (d_d x (x ^^^ #2 + #3 * x) + d_d x #4)";
5.952 +
5.953 +--------------------------------------------------
5.954 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
5.955 +> val f' = (term_of o the o (parse thy)) "x=#3";
5.956 +> val Thm (id,thm) =
5.957 + rep_tac_ (Rewrite_Set'
5.958 + ("Script.thy",false,"SqRoot_simplify",f,(f',[])));
5.959 +val id = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : string
5.960 +val thm = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : thm
5.961 +*)
5.962 + | rep_tac_ (Calculate' (thy',op_,f,(f',thm')))=
5.963 + let val fT = type_of f;
5.964 + val lhs = Const ("Script.Calculate",[idT,fT] ---> fT)
5.965 + $ Free (op_,idT) $ f
5.966 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
5.967 +(*
5.968 +> val lhs'=(term_of o the o (parse thy))"Calculate plus (#1+#2)";
5.969 + ... test-root-equ.sml: calculate ...
5.970 +> val Appl m'=applicable_in p pt (Calculate "plus");
5.971 +> val (lhs,_)=tac_2etac m';
5.972 +> lhs'=lhs;
5.973 +val it = true : bool*)
5.974 + | rep_tac_ (Check_elementwise' (t,str,(t',asm))) = (Erule, (e_term, t'))
5.975 + | rep_tac_ (Subproblem' (_,_,_,_,t')) = (Erule, (e_term, t'))
5.976 + | rep_tac_ (Take' (t')) = (Erule, (e_term, t'))
5.977 + | rep_tac_ (Substitute' (subst,t,t')) = (Erule, (t, t'))
5.978 + | rep_tac_ (Or_to_List' (t, t')) = (Erule, (t, t'))
5.979 + | rep_tac_ m = raise error ("rep_tac_: not impl.for "^
5.980 + (tac_2str m));
5.981 +
5.982 +(*"N.3.6.03------
5.983 +fun tac_2rule m = (fst o rep_tac_) m;
5.984 +fun tac_2etac m = (snd o rep_tac_) m;
5.985 +fun tac_2tac m = (fst o snd o rep_tac_) m;*)
5.986 +fun tac_2res m = (snd o snd o rep_tac_) m;(*ONLYuse of rep_tac_
5.987 + FIXXXXME: simplify rep_tac_*)
5.988 +
5.989 +
5.990 +(*.handle a leaf;
5.991 + a leaf is either a tactic or an 'exp' in 'let v = expr'
5.992 + where 'exp' does not contain a tactic.
5.993 + handling a leaf comprises
5.994 + (1) 'subst_stacexpr' substitute env and complete curried tactic
5.995 + (2) rewrite the leaf by 'srls'
5.996 +WN060906 quick and dirty fix: return a' too (for updating E later)
5.997 +.*)
5.998 +fun handle_leaf call thy srls E a v t =
5.999 + (*WN050916 'upd_env_opt' is a blind copy from previous version*)
5.1000 + case subst_stacexpr E a v t of
5.1001 + (a', STac stac) => (*script-tactic*)
5.1002 + let val stac' = eval_listexpr_ (assoc_thy thy) srls
5.1003 + (subst_atomic (upd_env_opt E (a,v)) stac)
5.1004 + in (if (!trace_script)
5.1005 + then writeln ("@@@ "^call^" leaf '"^term2str t^"' ---> STac '"^
5.1006 + term2str stac'^"'")
5.1007 + else ();
5.1008 + (a', STac stac'))
5.1009 + end
5.1010 + | (a', Expr lexpr) => (*leaf-expression*)
5.1011 + let val lexpr' = eval_listexpr_ (assoc_thy thy) srls
5.1012 + (subst_atomic (upd_env_opt E (a,v)) lexpr)
5.1013 + in (if (!trace_script)
5.1014 + then writeln("@@@ "^call^" leaf '"^term2str t^"' ---> Expr '"^
5.1015 + term2str lexpr'^"'")
5.1016 + else ();
5.1017 + (a', Expr lexpr'))
5.1018 + end;
5.1019 +
5.1020 +
5.1021 +
5.1022 +(** locate an applicable stactic in a script **)
5.1023 +
5.1024 +datatype assoc = (*ExprVal in the sense of denotational semantics*)
5.1025 + Assoc of (*the stac is associated, strongly or weakly*)
5.1026 + scrstate * (*the current; returned for next_tac etc. outside ass* *)
5.1027 + (step list) (*list of steps done until associated stac found;
5.1028 + initiated with the data for doing the 1st step,
5.1029 + thus the head holds these data further on,
5.1030 + while the tail holds steps finished (incl.scrstate in ptree)*)
5.1031 +| NasApp of (*stac not associated, but applicable, ptree-node generated*)
5.1032 + scrstate * (step list)
5.1033 +| NasNap of (*stac not associated, not applicable, nothing generated;
5.1034 + for distinction in Or, for leaving iterations, leaving Seq,
5.1035 + evaluate scriptexpressions*)
5.1036 + term * env;
5.1037 +fun assoc2str (Assoc _) = "Assoc"
5.1038 + | assoc2str (NasNap _) = "NasNap"
5.1039 + | assoc2str (NasApp _) = "NasApp";
5.1040 +
5.1041 +
5.1042 +datatype asap = (*arg. of assy _only_ for distinction w.r.t. Or*)
5.1043 + Aundef (*undefined: set only by (topmost) Or*)
5.1044 +| AssOnly (*do not execute appl stacs - there could be an associated
5.1045 + in parallel Or-branch*)
5.1046 +| AssGen; (*no Ass(Weak) found within Or, thus
5.1047 + search for _applicable_ stacs, execute and generate pt*)
5.1048 +(*this constructions doesnt allow arbitrary nesting of Or !!!*)
5.1049 +
5.1050 +
5.1051 +(*assy, ass_up, astep_up scanning for locate_gen at stactic in a script.
5.1052 + search is clearly separated into (1)-(2):
5.1053 + (1) assy is recursive descent;
5.1054 + (2) ass_up resumes interpretation at a location somewhere in the script;
5.1055 + astep_up does only get to the parentnode of the scriptexpr.
5.1056 + consequence:
5.1057 + * call of (2) means _always_ that in this branch below
5.1058 + there was an appl.stac (Repeat, Or e1, ...)
5.1059 +*)
5.1060 +fun assy ya (is as (E,l,a,v,S,b),ss)
5.1061 + (Const ("Let",_) $ e $ (Abs (id,T,body))) =
5.1062 +(* val (ya, (is as (E,l,a,v,S,b),ss),Const ("Let",_) $ e $ (Abs (id,T,body))) =
5.1063 + (*1*)(((ts,d),Aundef), ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]), body);
5.1064 + *)
5.1065 + ((*writeln("### assy Let$e$Abs: is=");
5.1066 + writeln(istate2str (ScrState is));*)
5.1067 + case assy ya ((E , l@[L,R], a,v,S,b),ss) e of
5.1068 + NasApp ((E',l,a,v,S,bb),ss) =>
5.1069 + let val id' = mk_Free (id, T);
5.1070 + val E' = upd_env E' (id', v);
5.1071 + (*val _=writeln("### assy Let -> NasApp");*)
5.1072 + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
5.1073 + | NasNap (v,E) =>
5.1074 + let val id' = mk_Free (id, T);
5.1075 + val E' = upd_env E (id', v);
5.1076 + (*val _=writeln("### assy Let -> NasNap");*)
5.1077 + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
5.1078 + | ay => ay)
5.1079 +
5.1080 + | assy (ya as (((thy,srls),_),_)) ((E,l,_,v,S,b),ss)
5.1081 + (Const ("Script.While",_) $ c $ e $ a) =
5.1082 + ((*writeln("### assy While $ c $ e $ a, upd_env= "^
5.1083 + (subst2str (upd_env E (a,v))));*)
5.1084 + if eval_true_ thy srls (subst_atomic (upd_env E (a,v)) c)
5.1085 + then assy ya ((E, l@[L,R], Some a,v,S,b),ss) e
5.1086 + else NasNap (v, E))
5.1087 +
5.1088 + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
5.1089 + (Const ("Script.While",_) $ c $ e) =
5.1090 + ((*writeln("### assy While, l= "^(loc_2str l));*)
5.1091 + if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
5.1092 + then assy ya ((E, l@[R], a,v,S,b),ss) e
5.1093 + else NasNap (v, E))
5.1094 +
5.1095 + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
5.1096 + (Const ("If",_) $ c $ e1 $ e2) =
5.1097 + (if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
5.1098 + then assy ya ((E, l@[L,R], a,v,S,b),ss) e1
5.1099 + else assy ya ((E, l@[ R], a,v,S,b),ss) e2)
5.1100 +
5.1101 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Try",_) $ e $ a) =
5.1102 + ((*writeln("### assy Try, l= "^(loc_2str l));*)
5.1103 + case assy ya ((E, l@[L,R], Some a,v,S,b),ss) e of
5.1104 + ay => ay)
5.1105 +
5.1106 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Try",_) $ e) =
5.1107 + ((*writeln("### assy Try, l= "^(loc_2str l));*)
5.1108 + case assy ya ((E, l@[R], a,v,S,b),ss) e of
5.1109 + ay => ay)
5.1110 +(* val (ya, ((E,l,_,v,S,b),ss), (Const ("Script.Seq",_) $e1 $ e2 $ a)) =
5.1111 + (*2*)(ya, ((E , l@[L,R], a,v,S,b),ss), e);
5.1112 + *)
5.1113 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2 $ a) =
5.1114 + ((*writeln("### assy Seq $e1 $ e2 $ a, E= "^(subst2str E));*)
5.1115 + case assy ya ((E, l@[L,L,R], Some a,v,S,b),ss) e1 of
5.1116 + NasNap (v, E) => assy ya ((E, l@[L,R], Some a,v,S,b),ss) e2
5.1117 + | NasApp ((E,_,_,v,_,_),ss) =>
5.1118 + assy ya ((E, l@[L,R], Some a,v,S,b),ss) e2
5.1119 + | ay => ay)
5.1120 +
5.1121 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2) =
5.1122 + (case assy ya ((E, l@[L,R], a,v,S,b),ss) e1 of
5.1123 + NasNap (v, E) => assy ya ((E, l@[R], a,v,S,b),ss) e2
5.1124 + | NasApp ((E,_,_,v,_,_),ss) =>
5.1125 + assy ya ((E, l@[R], a,v,S,b),ss) e2
5.1126 + | ay => ay)
5.1127 +
5.1128 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Repeat",_) $ e $ a) =
5.1129 + assy ya ((E,(l@[L,R]),Some a,v,S,b),ss) e
5.1130 +
5.1131 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Repeat",_) $ e) =
5.1132 + assy ya ((E,(l@[R]),a,v,S,b),ss) e
5.1133 +
5.1134 +(*15.6.02: ass,app Or nochmals "uberlegen FIXXXME*)
5.1135 + | assy (y, Aundef) ((E,l,_,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2 $ a) =
5.1136 + (case assy (y, AssOnly) ((E,(l@[L,L,R]),Some a,v,S,b),ss) e1 of
5.1137 + NasNap (v, E) =>
5.1138 + (case assy (y, AssOnly) ((E,(l@[L,R]),Some a,v,S,b),ss) e2 of
5.1139 + NasNap (v, E) =>
5.1140 + (case assy (y, AssGen) ((E,(l@[L,L,R]),Some a,v,S,b),ss) e1 of
5.1141 + NasNap (v, E) =>
5.1142 + assy (y, AssGen) ((E, (l@[L,R]), Some a,v,S,b),ss) e2
5.1143 + | ay => ay)
5.1144 + | ay =>(ay))
5.1145 + | NasApp _ => raise error ("assy: FIXXXME ///must not return NasApp///")
5.1146 + | ay => (ay))
5.1147 +
5.1148 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2) =
5.1149 + (case assy ya ((E,(l@[L,R]),a,v,S,b),ss) e1 of
5.1150 + NasNap (v, E) =>
5.1151 + assy ya ((E,(l@[R]),a,v,S,b),ss) e2
5.1152 + | ay => (ay))
5.1153 +(* val ((m,_,pt,(p,p_),c)::ss) = [(m,EmptyMout,pt,p,[])];
5.1154 + val t = (term_of o the o (parse Isac.thy)) "Rewrite rmult_1 False";
5.1155 +
5.1156 + val (ap,(p,p_),c,ss) = (Aundef,p,[],[]);
5.1157 + assy (((thy',srls),d),ap) ((E,l,a,v,S,b), (m,EmptyMout,pt,(p,p_),c)::ss) t;
5.1158 +val ((((thy',sr),d),ap), (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss), t) =
5.1159 + ();
5.1160 + *)
5.1161 +
5.1162 + | assy (((thy',sr),d),ap) (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss) t =
5.1163 + ((*writeln("### assy, m = "^tac_2str m);
5.1164 + writeln("### assy, (p,p_) = "^pos'2str (p,p_));
5.1165 + writeln("### assy, is= ");
5.1166 + writeln(istate2str (ScrState is));*)
5.1167 + case handle_leaf "locate" thy' sr E a v t of
5.1168 + (a', Expr s) =>
5.1169 + ((*writeln("### assy: listexpr t= "^(term2str t));
5.1170 + writeln("### assy, E= "^(env2str E));
5.1171 + writeln("### assy, eval(..)= "^(term2str
5.1172 + (eval_listexpr_ (assoc_thy thy') sr
5.1173 + (subst_atomic (upd_env_opt E (a',v)) t))));*)
5.1174 + NasNap (eval_listexpr_ (assoc_thy thy') sr
5.1175 + (subst_atomic (upd_env_opt E (a',v)) t), E))
5.1176 + (* val (_,STac stac) = subst_stacexpr E a v t;
5.1177 + *)
5.1178 + | (a', STac stac) =>
5.1179 + let (*val _=writeln("### assy, stac = "^term2str stac);*)
5.1180 + val p' = case p_ of Frm => p | Res => lev_on p
5.1181 + | _ => raise error ("assy: call by "^
5.1182 + (pos'2str (p,p_)));
5.1183 + in case assod pt d m stac of
5.1184 + Ass (m,v') =>
5.1185 + let (*val _=writeln("### assy: Ass ("^tac_2str m^",
5.1186 + "^term2str v'^")");*)
5.1187 + val (p'',c',f',pt') = generate1 (assoc_thy thy') m
5.1188 + (ScrState (E,l,a',v',S,true)) (p',p_) pt;
5.1189 + in Assoc ((E,l,a',v',S,true), (m,f',pt',p'',c @ c')::ss) end
5.1190 + | AssWeak (m,v') =>
5.1191 + let val (p'',c',f',pt') = generate1 (assoc_thy thy') m
5.1192 + (ScrState (E,l,a',v',S,false)) (p',p_) pt;
5.1193 + in Assoc ((E,l,a',v',S,false), (m,f',pt',p'',c @ c')::ss) end
5.1194 + | NotAss =>
5.1195 + ((*writeln("### assy, NotAss");*)
5.1196 + case ap of (*switch for Or: 1st AssOnly, 2nd AssGen*)
5.1197 + AssOnly => (NasNap (v, E))
5.1198 + | gen => (case applicable_in (p,p_) pt
5.1199 + (stac2tac pt (assoc_thy thy') stac) of
5.1200 + Appl m' =>
5.1201 + let val is = (E,l,a',tac_2res m',S,false(*FIXXXME*))
5.1202 + val (p'',c',f',pt') =
5.1203 + generate1 (assoc_thy thy') m' (ScrState is) (p',p_) pt;
5.1204 + in NasApp (is,(m,f',pt',p'',c @ c')::ss) end
5.1205 + | Notappl _ =>
5.1206 + (NasNap (v, E))
5.1207 + )
5.1208 + )
5.1209 + end);
5.1210 +(* (astep_up ((thy',scr,d),NasApp_) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])) handle e => print_exn_G e;
5.1211 + *)
5.1212 +
5.1213 +
5.1214 +(* val (ys as (y,s,Script sc,d),(is as (E,l,a,v,S,b),ss),Const ("Let",_) $ _) =
5.1215 + (ys, ((E,up,a,v,S,b),ss), go up sc);
5.1216 + *)
5.1217 +fun ass_up (ys as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss)
5.1218 + (Const ("Let",_) $ _) =
5.1219 + let (*val _= writeln("### ass_up1 Let$e: is=")
5.1220 + val _= writeln(istate2str (ScrState is))*)
5.1221 + val l = drop_last l; (*comes from e, goes to Abs*)
5.1222 + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go l sc;
5.1223 + val i = mk_Free (i, T);
5.1224 + val E = upd_env E (i, v);
5.1225 + (*val _=writeln("### ass_up2 Let$e: E="^(subst2str E));*)
5.1226 + in case assy (((y,s),d),Aundef) ((E, l@[R,D], a,v,S,b),ss) body of
5.1227 + Assoc iss => Assoc iss
5.1228 + | NasApp iss => astep_up ys iss
5.1229 + | NasNap (v, E) => astep_up ys ((E,l,a,v,S,b),ss) end
5.1230 +
5.1231 + | ass_up ys iss (Abs (_,_,_)) =
5.1232 + astep_up ys iss (*TODO 5.9.00: env ?*)
5.1233 +
5.1234 + | ass_up ys (iss as (is,_)) (Const ("Let",_) $ e $ (Abs (i,T,b)))=
5.1235 + ((*writeln("### ass_up Let$e$Abs: is=");
5.1236 + writeln(istate2str (ScrState is));*)
5.1237 + astep_up ys iss) (*TODO 5.9.00: env ?*)
5.1238 +
5.1239 +
5.1240 + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _ $ _) =
5.1241 + (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _ $ _)) =
5.1242 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
5.1243 + *)
5.1244 + astep_up ysa iss (*all has been done in (*2*) below*)
5.1245 +
5.1246 + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _) =
5.1247 + (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _)) =
5.1248 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
5.1249 + *)
5.1250 + astep_up ysa iss (*2*: comes from e2*)
5.1251 +
5.1252 + | ass_up (ysa as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss)
5.1253 + (Const ("Script.Seq",_) $ _ ) = (*2*: comes from e1, goes to e2*)
5.1254 + (* val ((ysa as (y,s,Script sc,d)), (is as (E,l,a,v,S,b),ss),
5.1255 + (Const ("Script.Seq",_) $ _ )) =
5.1256 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
5.1257 + *)
5.1258 + let val up = drop_last l;
5.1259 + val Const ("Script.Seq",_) $ _ $ e2 = go up sc
5.1260 + (*val _= writeln("### ass_up Seq$e: is=")
5.1261 + val _= writeln(istate2str (ScrState is))*)
5.1262 + in case assy (((y,s),d),Aundef) ((E, up@[R], a,v,S,b),ss) e2 of
5.1263 + NasNap (v,E) => astep_up ysa ((E,up,a,v,S,b),ss)
5.1264 + | NasApp iss => astep_up ysa iss
5.1265 + | ay => ay end
5.1266 +
5.1267 + | ass_up ysa iss (Const ("Script.Try",_) $ e $ _) =
5.1268 + (* val (ysa, iss, (Const ("Script.Try",_) $ e $ _)) =
5.1269 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
5.1270 + *)
5.1271 + astep_up ysa iss
5.1272 +
5.1273 + | ass_up ysa iss (Const ("Script.Try",_) $ e) =
5.1274 + (* val (ysa, iss, (Const ("Script.Try",_) $ e)) =
5.1275 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
5.1276 + *)
5.1277 + astep_up ysa iss
5.1278 +
5.1279 + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
5.1280 + (*(Const ("Script.While",_) $ c $ e $ a) = WN050930 blind fix*)
5.1281 + (t as Const ("Script.While",_) $ c $ e $ a) =
5.1282 + ((*writeln("### ass_up: While c= "^
5.1283 + (term2str (subst_atomic (upd_env E (a,v)) c)));*)
5.1284 + if eval_true_ y s (subst_atomic (upd_env E (a,v)) c)
5.1285 + then (case assy (((y,s),d),Aundef) ((E, l@[L,R], Some a,v,S,b),ss) e of
5.1286 + NasNap (v,E') => astep_up ys ((E',l, Some a,v,S,b),ss)
5.1287 + | NasApp ((E',l,a,v,S,b),ss) =>
5.1288 + ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*)
5.1289 + | ay => ay)
5.1290 + else astep_up ys ((E,l, Some a,v,S,b),ss)
5.1291 + )
5.1292 +
5.1293 + | ass_up (ys as (y,s,_,d)) ((E,l,a,v,S,b),ss)
5.1294 + (*(Const ("Script.While",_) $ c $ e) = WN050930 blind fix*)
5.1295 + (t as Const ("Script.While",_) $ c $ e) =
5.1296 + if eval_true_ y s (subst_atomic (upd_env_opt E (a,v)) c)
5.1297 + then (case assy (((y,s),d),Aundef) ((E, l@[R], a,v,S,b),ss) e of
5.1298 + NasNap (v,E') => astep_up ys ((E',l, a,v,S,b),ss)
5.1299 + | NasApp ((E',l,a,v,S,b),ss) =>
5.1300 + ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*)
5.1301 + | ay => ay)
5.1302 + else astep_up ys ((E,l, a,v,S,b),ss)
5.1303 +
5.1304 + | ass_up y iss (Const ("If",_) $ _ $ _ $ _) = astep_up y iss
5.1305 +
5.1306 + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
5.1307 + (t as Const ("Script.Repeat",_) $ e $ a) =
5.1308 + (case assy (((y,s),d), Aundef) ((E, (l@[L,R]), Some a,v,S,b),ss) e of
5.1309 + NasNap (v,E') => astep_up ys ((E',l, Some a,v,S,b),ss)
5.1310 + | NasApp ((E',l,a,v,S,b),ss) =>
5.1311 + ass_up ys ((E',l,a,v,S,b),ss) t
5.1312 + | ay => ay)
5.1313 +
5.1314 + | ass_up (ys as (y,s,_,d)) (is as ((E,l,a,v,S,b),ss))
5.1315 + (t as Const ("Script.Repeat",_) $ e) =
5.1316 + (case assy (((y,s),d), Aundef) ((E, (l@[R]), a,v,S,b),ss) e of
5.1317 + NasNap (v', E') => astep_up ys ((E',l,a,v',S,b),ss)
5.1318 + | NasApp ((E',l,a,v',S,bb),ss) =>
5.1319 + ass_up ys ((E',l,a,v',S,b),ss) t
5.1320 + | ay => ay)
5.1321 +
5.1322 + | ass_up y iss (Const ("Script.Or",_) $ _ $ _ $ _) = astep_up y iss
5.1323 +
5.1324 + | ass_up y iss (Const ("Script.Or",_) $ _ $ _) = astep_up y iss
5.1325 +
5.1326 + | ass_up y ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $ _ ) =
5.1327 + astep_up y ((E, (drop_last l), a,v,S,b),ss)
5.1328 +
5.1329 + | ass_up y iss t =
5.1330 + raise error ("ass_up not impl for t= "^(term2str t))
5.1331 +(* 9.6.03
5.1332 + val (ys as (_,_,Script sc,_), ss) =
5.1333 + ((thy',srls,scr,d), [(m,EmptyMout,pt,p,[])]:step list);
5.1334 + astep_up ys ((E,l,a,v,S,b),ss);
5.1335 +
5.1336 + val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) =
5.1337 + ((thy',srls,scr,d), ((E,l,a,v,S,b), [(m,EmptyMout,pt,p,[])]));
5.1338 +
5.1339 + val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) =
5.1340 + (ysa, iss);
5.1341 + *)
5.1342 +and astep_up (ys as (_,_,Script sc,_)) ((E,l,a,v,S,b),ss) =
5.1343 + if 1 < length l
5.1344 + then
5.1345 + let val up = drop_last l;
5.1346 + (*val _= writeln("### astep_up: E= "env2str E);*)
5.1347 + in ass_up ys ((E,up,a,v,S,b),ss) (go up sc) end
5.1348 + else (NasNap (v, E))
5.1349 +;
5.1350 +
5.1351 +
5.1352 +
5.1353 +
5.1354 +
5.1355 +(* use"ME/script.sml";
5.1356 + use"script.sml";
5.1357 + term2str (go up sc);
5.1358 +
5.1359 + *)
5.1360 +
5.1361 +(*check if there are tacs for rewriting only*)
5.1362 +fun rew_only ([]:step list) = true
5.1363 + | rew_only (((Rewrite' _ ,_,_,_,_))::ss) = rew_only ss
5.1364 + | rew_only (((Rewrite_Inst' _ ,_,_,_,_))::ss) = rew_only ss
5.1365 + | rew_only (((Rewrite_Set' _ ,_,_,_,_))::ss) = rew_only ss
5.1366 + | rew_only (((Rewrite_Set_Inst' _ ,_,_,_,_))::ss) = rew_only ss
5.1367 + | rew_only (((Calculate' _ ,_,_,_,_))::ss) = rew_only ss
5.1368 + | rew_only (((Begin_Trans' _ ,_,_,_,_))::ss) = rew_only ss
5.1369 + | rew_only (((End_Trans' _ ,_,_,_,_))::ss) = rew_only ss
5.1370 + | rew_only _ = false;
5.1371 +
5.1372 +
5.1373 +datatype locate =
5.1374 + Steps of istate (*producing hd of step list (which was latest)
5.1375 + for next_tac, for reporting Safe|Unsafe to DG*)
5.1376 + * step (*(scrstate producing this step is in ptree !)*)
5.1377 + list (*locate_gen may produce intermediate steps*)
5.1378 +| NotLocatable; (*no (m Ass m') or (m AssWeak m') found*)
5.1379 +
5.1380 +
5.1381 +
5.1382 +(* locate_gen tries to locate an input tac m in the script.
5.1383 + pursuing this goal the script is executed until an (m' equiv m) is found,
5.1384 + or the end of the script
5.1385 +args
5.1386 + m : input by the user, already checked by applicable_in,
5.1387 + (to be searched within Or; and _not_ an m doing the step on ptree !)
5.1388 + p,pt: (incl ets) at the time of input
5.1389 + scr : the script
5.1390 + d : canonical simplifier for locating Take, Substitute, Subproblems etc.
5.1391 + ets : ets at the time of input
5.1392 + l : the location (in scr) of the stac which generated the current formula
5.1393 +returns
5.1394 + Steps: pt,p (incl. ets) with m done
5.1395 + pos' list of proofobjs cut (from generate)
5.1396 + safe: implied from last proofobj
5.1397 + ets:
5.1398 + ///ToDo : ets contains a list of tacs to be done before m can be done
5.1399 + NOT IMPL. -- "error: do other step before"
5.1400 + NotLocatable: thus generate_hard
5.1401 +*)
5.1402 +(* val (Rewrite'(_,ro,er,pa,(id,str),f,_), p, Rfuns {locate_rule=lo,...},
5.1403 + RrlsState (_,f'',rss,rts)) = (m, (p,p_), sc, is);
5.1404 + *)
5.1405 +fun locate_gen (thy',_) (Rewrite'(_,ro,er,pa,(id,str),f,_)) (pt,p)
5.1406 + (Rfuns {locate_rule=lo,...}, d) (RrlsState (_,f'',rss,rts)) =
5.1407 + (case lo rss f (Thm (id, mk_thm (assoc_thy thy') str)) of
5.1408 + [] => NotLocatable
5.1409 + | rts' =>
5.1410 + Steps (rts2steps [] ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) rts'))
5.1411 +(* val p as(p',p_)=(p,p_);val scr as Script(h $ body)=sc;val (E,l,a,v,S,bb)=is;
5.1412 + locate_gen (thy':theory') (m:tac_) ((pt,p):ptree * pos')
5.1413 + (scr,d) (E,l,a,v,S,bb);
5.1414 + 9.6.03
5.1415 + val ts = (thy',srls);
5.1416 + val p = (p,p_);
5.1417 + val (scr as Script (h $ body)) = (sc);
5.1418 + val ScrState (E,l,a,v,S,b) = (is);
5.1419 +
5.1420 + val (ts as (thy',srls), m, (pt,p),
5.1421 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
5.1422 + ((thy',srls), m, (pt,(p,p_)), (sc,d), is);
5.1423 + locate_gen (thy',srls) m (pt,p) (Script(h $ body),d)(ScrState(E,l,a,v,S,b));
5.1424 +
5.1425 + val (ts as (thy',srls), m, (pt,p),
5.1426 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
5.1427 + ((thy',srls), m', (pt,(lev_on p,Frm)), (sc,d), is');
5.1428 +
5.1429 + val (ts as (thy',srls), m, (pt,p),
5.1430 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
5.1431 + ((thy',srls), m', (pt,(p, Res)), (sc,d), is');
5.1432 +
5.1433 + val (ts as (thy',srls), m, (pt,p),
5.1434 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
5.1435 + ((thy',srls), m, (pt,(p, p_)), (sc,d), is);
5.1436 + *)
5.1437 + | locate_gen (ts as (thy',srls)) (m:tac_) ((pt,p):ptree * pos')
5.1438 + (scr as Script (h $ body),d) (ScrState (E,l,a,v,S,b)) =
5.1439 + let (*val _= writeln("### locate_gen-----------------: is=");
5.1440 + val _= writeln( istate2str (ScrState (E,l,a,v,S,b)));
5.1441 + val _= writeln("### locate_gen: l= "^loc_2str l^", p= "^pos'2str p)*)
5.1442 + val thy = assoc_thy thy';
5.1443 + in case if l=[] orelse ((*init.in solve..Apply_Method...*)
5.1444 + (last_elem o fst) p = 0 andalso snd p = Res)
5.1445 + then (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),
5.1446 + [(m,EmptyMout,pt,p,[])]) body)
5.1447 +(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =
5.1448 + (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])]));
5.1449 + (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]) body);
5.1450 + *)
5.1451 + else (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),
5.1452 + [(m,EmptyMout,pt,p,[])]) ) of
5.1453 + Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =>
5.1454 + ((*writeln("### locate_gen Assoc: p'="^(pos'2str p'));*)
5.1455 + if bb then Steps (ScrState is, ss)
5.1456 + else if rew_only ss (*andalso 'not bb'= associated weakly*)
5.1457 + then let (*val _=writeln("### locate_gen, bef g1: p="^(pos'2str p));*)
5.1458 + val (po,p_) = p;
5.1459 + val po' = case p_ of Frm => po | Res => lev_on po
5.1460 + (*WN.12.03: noticed, that pos is also updated in assy !?!
5.1461 + instead take p' from Assoc ?????????????????????????????*)
5.1462 + val (p'',c'',f'',pt'') =
5.1463 + generate1 thy m (ScrState is) (po',p_) pt;
5.1464 + (*val _=writeln("### locate_gen, aft g1: p''="^(pos'2str p''));*)
5.1465 + (*drop the intermediate steps !*)
5.1466 + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
5.1467 + else Steps (ScrState is, ss))
5.1468 +
5.1469 + | NasApp _ (*[((E,l,a,v,S,bb),(m',f',pt',p',c'))] =>
5.1470 + raise error ("locate_gen: should not have got NasApp, ets =")*)
5.1471 + => NotLocatable
5.1472 + | NasNap (_,_) =>
5.1473 + if l=[] then NotLocatable
5.1474 + else (*scan from begin of script for rew_only*)
5.1475 + (case assy ((ts,d),Aundef) ((E,[R],a,v,Unsafe,b),
5.1476 + [(m,EmptyMout,pt,p,[])]) body of
5.1477 + Assoc (iss as (is as (_,_,_,_,_,bb),
5.1478 + ss as ((m',f',pt',p',c')::_))) =>
5.1479 + ((*writeln"4### locate_gen Assoc after Fini";*)
5.1480 + if rew_only ss
5.1481 + then let val(p'',c'',f'',pt'') =
5.1482 + generate1 thy m (ScrState is) p' pt;
5.1483 + (*drop the intermediate steps !*)
5.1484 + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
5.1485 + else NotLocatable)
5.1486 + | _ => ((*writeln ("#### locate_gen: after Fini");*)
5.1487 + NotLocatable))
5.1488 + end
5.1489 + | locate_gen _ m _ (sc,_) is =
5.1490 + raise error ("locate_gen: wrong arguments,\n tac= "^(tac_2str m)^
5.1491 + ",\n scr= "^(scr2str sc)^",\n istate= "^(istate2str is));
5.1492 +
5.1493 +
5.1494 +
5.1495 +(** find the next stactic in a script **)
5.1496 +
5.1497 +datatype appy = (*ExprVal in the sense of denotational semantics*)
5.1498 + Appy of (*applicable stac found, search stalled*)
5.1499 + tac_ * (*tac_ associated (fun assod) with stac*)
5.1500 + scrstate (*after determination of stac WN.18.8.03*)
5.1501 + | Napp of (*stac found was not applicable;
5.1502 + this mode may become Skip in Repeat, Try and Or*)
5.1503 + env (*stack*) (*popped while nxt_up*)
5.1504 + | Skip of (*for restart after Appy, for leaving iterations,
5.1505 + for passing the value of scriptexpressions,
5.1506 + and for finishing the script successfully*)
5.1507 + term * env (*stack*);
5.1508 +
5.1509 +(*appy, nxt_up, nstep_up scanning for next_tac.
5.1510 + search is clearly separated into (1)-(2):
5.1511 + (1) appy is recursive descent;
5.1512 + (2) nxt_up resumes interpretation at a location somewhere in the script;
5.1513 + nstep_up does only get to the parentnode of the scriptexpr.
5.1514 + consequence:
5.1515 + * call of (2) means _always_ that in this branch below
5.1516 + there was an applicable stac (Repeat, Or e1, ...)
5.1517 +*)
5.1518 +
5.1519 +
5.1520 +datatype appy_ = (*as argument in nxt_up, nstep_up, from appy*)
5.1521 + (* Appy is only (final) returnvalue, not argument during search
5.1522 + |*) Napp_ (*ev. detects 'script is not appropriate for this example'*)
5.1523 + | Skip_; (*detects 'script successfully finished'
5.1524 + also used as init-value for resuming; this works,
5.1525 + because 'nxt_up Or e1' treats as Appy*)
5.1526 +
5.1527 +fun appy thy ptp E l
5.1528 + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
5.1529 +(* val (thy, ptp, E, l, t as Const ("Let",_) $ e $ (Abs (i,T,b)),a, v)=
5.1530 + (thy, ptp, E, up@[R,D], body, a, v);
5.1531 + appy thy ptp E l t a v;
5.1532 + *)
5.1533 + ((*writeln("### appy Let$e$Abs: is=");
5.1534 + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
5.1535 + case appy thy ptp E (l@[L,R]) e a v of
5.1536 + Skip (res, E) =>
5.1537 + let (*val _= writeln("### appy Let "^(term2str t));
5.1538 + val _= writeln("### appy Let: Skip res ="^(term2str res));*)
5.1539 + (*val (i',b') = variant_abs (i,T,b); WN.15.5.03
5.1540 + val i = mk_Free(i',T); WN.15.5.03 *)
5.1541 + val E' = upd_env E (Free (i,T), res);
5.1542 + in appy thy ptp E' (l@[R,D]) b a v end
5.1543 + | ay => ay)
5.1544 +
5.1545 + | appy (thy as (th,sr)) ptp E l
5.1546 + (t as Const ("Script.While"(*1*),_) $ c $ e $ a) _ v = (*ohne n. 28.9.00*)
5.1547 + ((*writeln("### appy While $ c $ e $ a, upd_env= "^
5.1548 + (subst2str (upd_env E (a,v))));*)
5.1549 + if eval_true_ th sr (subst_atomic (upd_env E (a,v)) c)
5.1550 + then appy thy ptp E (l@[L,R]) e (Some a) v
5.1551 + else Skip (v, E))
5.1552 +
5.1553 + | appy (thy as (th,sr)) ptp E l
5.1554 + (t as Const ("Script.While"(*2*),_) $ c $ e) a v =(*ohne nachdenken 28.9.00*)
5.1555 + ((*writeln("### appy While $ c $ e, upd_env= "^
5.1556 + (subst2str (upd_env_opt E (a,v))));*)
5.1557 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
5.1558 + then appy thy ptp E (l@[R]) e a v
5.1559 + else Skip (v, E))
5.1560 +
5.1561 + | appy (thy as (th,sr)) ptp E l (t as Const ("If",_) $ c $ e1 $ e2) a v =
5.1562 + ((*writeln("### appy If: t= "^(term2str t));
5.1563 + writeln("### appy If: c= "^(term2str(subst_atomic(upd_env_opt E(a,v))c)));
5.1564 + writeln("### appy If: thy= "^(fst thy));*)
5.1565 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
5.1566 + then ((*writeln("### appy If: true");*)appy thy ptp E (l@[L,R]) e1 a v)
5.1567 + else ((*writeln("### appy If: false");*)appy thy ptp E (l@[ R]) e2 a v))
5.1568 +(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e $ a), _, v) =
5.1569 + (thy, ptp, E, (l@[R]), e, a, v);
5.1570 + *)
5.1571 + | appy thy ptp E (*env*) l
5.1572 + (Const ("Script.Repeat"(*1*),_) $ e $ a) _ v =
5.1573 + ((*writeln("### appy Repeat a: ");*)
5.1574 + appy thy ptp E (*env*) (l@[L,R]) e (Some a) v)
5.1575 +(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e), _, v) =
5.1576 + (thy, ptp, E, (l@[R]), e, a, v);
5.1577 + *)
5.1578 + | appy thy ptp E (*env*) l
5.1579 + (Const ("Script.Repeat"(*2*),_) $ e) a v =
5.1580 + ((*writeln("3### appy Repeat: a= "^
5.1581 + (Sign.string_of_term (sign_of (assoc_thy thy)) a));*)
5.1582 + appy thy ptp E (*env*) (l@[R]) e a v)
5.1583 +(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e $ a), _, v)=
5.1584 + (thy, ptp, E, (l@[R]), e2, a, v);
5.1585 + *)
5.1586 + | appy thy ptp E l
5.1587 + (t as Const ("Script.Try",_) $ e $ a) _ v =
5.1588 + (case appy thy ptp E (l@[L,R]) e (Some a) v of
5.1589 + Napp E => ((*writeln("### appy Try "^
5.1590 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
5.1591 + Skip (v, E))
5.1592 + | ay => ay)
5.1593 +(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)=
5.1594 + (thy, ptp, E, (l@[R]), e2, a, v);
5.1595 + val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)=
5.1596 + (thy, ptp, E, (l@[L,R]), e1, a, v);
5.1597 + *)
5.1598 + | appy thy ptp E l
5.1599 + (t as Const ("Script.Try",_) $ e) a v =
5.1600 + (case appy thy ptp E (l@[R]) e a v of
5.1601 + Napp E => ((*writeln("### appy Try "^
5.1602 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
5.1603 + Skip (v, E))
5.1604 + | ay => ay)
5.1605 +
5.1606 +
5.1607 + | appy thy ptp E l
5.1608 + (Const ("Script.Or"(*1*),_) $e1 $ e2 $ a) _ v =
5.1609 + (case appy thy ptp E (l@[L,L,R]) e1 (Some a) v of
5.1610 + Appy lme => Appy lme
5.1611 + | _ => appy thy ptp E (*env*) (l@[L,R]) e2 (Some a) v)
5.1612 +
5.1613 + | appy thy ptp E l
5.1614 + (Const ("Script.Or"(*2*),_) $e1 $ e2) a v =
5.1615 + (case appy thy ptp E (l@[L,R]) e1 a v of
5.1616 + Appy lme => Appy lme
5.1617 + | _ => appy thy ptp E (l@[R]) e2 a v)
5.1618 +
5.1619 +(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)=
5.1620 + (thy, ptp, E,(up@[R]),e2, a, v);
5.1621 + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)=
5.1622 + (thy, ptp, E,(up@[R,D]),body, a, v);
5.1623 + *)
5.1624 + | appy thy ptp E l
5.1625 + (Const ("Script.Seq"(*1*),_) $ e1 $ e2 $ a) _ v =
5.1626 + ((*writeln("### appy Seq $ e1 $ e2 $ a, upd_env= "^
5.1627 + (subst2str (upd_env E (a,v))));*)
5.1628 + case appy thy ptp E (l@[L,L,R]) e1 (Some a) v of
5.1629 + Skip (v,E) => appy thy ptp E (l@[L,R]) e2 (Some a) v
5.1630 + | ay => ay)
5.1631 +
5.1632 +(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
5.1633 + (thy, ptp, E,(up@[R]),e2, a, v);
5.1634 + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
5.1635 + (thy, ptp, E,(l@[R]), e2, a, v);
5.1636 + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
5.1637 + (thy, ptp, E,(up@[R,D]),body, a, v);
5.1638 + *)
5.1639 + | appy thy ptp E l
5.1640 + (Const ("Script.Seq",_) $ e1 $ e2) a v =
5.1641 + (case appy thy ptp E (l@[L,R]) e1 a v of
5.1642 + Skip (v,E) => appy thy ptp E (l@[R]) e2 a v
5.1643 + | ay => ay)
5.1644 +
5.1645 + (*.a leaf has been found*)
5.1646 + | appy (thy as (th,sr)) (pt, p) E l t a v =
5.1647 +(* val (thy as (th,sr),(pt, p),E, l, t, a, v) =
5.1648 + (thy, ptp, E, up@[R,D], body, a, v);
5.1649 + val (thy as (th,sr),(pt, p),E, l, t, a, v) =
5.1650 + (thy, ptp, E, l@[L,R], e, a, v);
5.1651 + val (thy as (th,sr),(pt, p),E, l, t, a, v) =
5.1652 + (thy, ptp, E,(l@[R]), e, a, v);
5.1653 + *)
5.1654 + (case handle_leaf "next " th sr E a v t of
5.1655 +(* val (a', Expr s) = handle_leaf "next " th sr E a v t;
5.1656 + *)
5.1657 + (a', Expr s) => Skip (s, E)
5.1658 +(* val (a', STac stac) = handle_leaf "next " th sr E a v t;
5.1659 + *)
5.1660 + | (a', STac stac) =>
5.1661 + let
5.1662 + (*val _= writeln("### appy t, vor stac2tac_ is=");
5.1663 + val _= writeln(istate2str (ScrState (E,l,a',v,Sundef,false)));*)
5.1664 + val (m,m') = stac2tac_ pt (assoc_thy th) stac
5.1665 + in case m of
5.1666 + Subproblem _ => Appy (m', (E,l,a',tac_2res m',Sundef,false))
5.1667 + | _ => (case applicable_in p pt m of
5.1668 +(* val Appl m' = applicable_in p pt m;
5.1669 + *)
5.1670 + Appl m' =>
5.1671 + ((*writeln("### appy: Appy");*)
5.1672 + Appy (m', (E,l,a',tac_2res m',Sundef,false)))
5.1673 + | _ => ((*writeln("### appy: Napp");*)Napp E))
5.1674 + end);
5.1675 +
5.1676 +
5.1677 +(* val (scr as Script sc, l, t as Const ("Let",_) $ _) =
5.1678 + (Script sc, up, go up sc);
5.1679 + nxt_up thy ptp (Script sc) E l ay t a v;
5.1680 +
5.1681 + val (thy,ptp,scr as (Script sc),E,l, ay, t as Const ("Let",_) $ _, a, v)=
5.1682 + (thy,ptp,Script sc, E,up,ay, go up sc, a, v);
5.1683 + nxt_up thy ptp scr E l ay t a v;
5.1684 + *)
5.1685 +fun nxt_up thy ptp (scr as (Script sc)) E l ay
5.1686 + (t as Const ("Let",_) $ _) a v = (*comes from let=...*)
5.1687 + ((*writeln("### nxt_up1 Let$e: is=");
5.1688 + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
5.1689 + if ay = Napp_
5.1690 + then nstep_up thy ptp scr E (drop_last l) Napp_ a v
5.1691 + else (*Skip_*)
5.1692 + let val up = drop_last l;
5.1693 + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go up sc;
5.1694 + val i = mk_Free (i, T);
5.1695 + val E = upd_env E (i, v);
5.1696 + (*val _= writeln("### nxt_up2 Let$e: is=");
5.1697 + val _= writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
5.1698 + in case appy thy ptp (E) (up@[R,D]) body a v of
5.1699 + Appy lre => Appy lre
5.1700 + | Napp E => nstep_up thy ptp scr E up Napp_ a v
5.1701 + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end)
5.1702 +
5.1703 + | nxt_up thy ptp scr E l ay
5.1704 + (t as Abs (_,_,_)) a v =
5.1705 + ((*writeln("### nxt_up Abs: "^
5.1706 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
5.1707 + nstep_up thy ptp scr E (*enr*) l ay a v)
5.1708 +
5.1709 + | nxt_up thy ptp scr E l ay
5.1710 + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
5.1711 + ((*writeln("### nxt_up Let$e$Abs: is=");
5.1712 + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
5.1713 + (*writeln("### nxt_up Let e Abs: "^
5.1714 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
5.1715 + nstep_up thy ptp scr (*upd_env*) E (*a,v)*)
5.1716 + (*eno,upd_env env (iar,res),iar,res,saf*) l ay a v)
5.1717 +
5.1718 + (*no appy_: never causes Napp -> Helpless*)
5.1719 + | nxt_up (thy as (th,sr)) ptp scr E l _
5.1720 + (Const ("Script.While"(*1*),_) $ c $ e $ _) a v =
5.1721 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
5.1722 + then case appy thy ptp E (l@[L,R]) e a v of
5.1723 + Appy lr => Appy lr
5.1724 + | Napp E => nstep_up thy ptp scr E l Skip_ a v
5.1725 + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
5.1726 + else nstep_up thy ptp scr E l Skip_ a v
5.1727 +
5.1728 + (*no appy_: never causes Napp - Helpless*)
5.1729 + | nxt_up (thy as (th,sr)) ptp scr E l _
5.1730 + (Const ("Script.While"(*2*),_) $ c $ e) a v =
5.1731 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
5.1732 + then case appy thy ptp E (l@[R]) e a v of
5.1733 + Appy lr => Appy lr
5.1734 + | Napp E => nstep_up thy ptp scr E l Skip_ a v
5.1735 + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
5.1736 + else nstep_up thy ptp scr E l Skip_ a v
5.1737 +
5.1738 +(* val (scr, l) = (Script sc, up);
5.1739 + *)
5.1740 + | nxt_up thy ptp scr E l ay (Const ("If",_) $ _ $ _ $ _) a v =
5.1741 + nstep_up thy ptp scr E l ay a v
5.1742 +
5.1743 + | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*)
5.1744 + (Const ("Script.Repeat"(*1*),T) $ e $ _) a v =
5.1745 + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[L,R]):loc_) e a v of
5.1746 + Appy lr => Appy lr
5.1747 + | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
5.1748 + nstep_up thy ptp scr E l Skip_ a v)
5.1749 + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
5.1750 + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
5.1751 + nstep_up thy ptp scr E l Skip_ a v))
5.1752 +
5.1753 + | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*)
5.1754 + (Const ("Script.Repeat"(*2*),T) $ e) a v =
5.1755 + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[R]):loc_) e a v of
5.1756 + Appy lr => Appy lr
5.1757 + | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
5.1758 + nstep_up thy ptp scr E l Skip_ a v)
5.1759 + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
5.1760 + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
5.1761 + nstep_up thy ptp scr E l Skip_ a v))
5.1762 +(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e $ _), a, v) =
5.1763 + (thy, ptp, (Script sc),
5.1764 + E, up, ay,(go up sc), a, v);
5.1765 + *)
5.1766 + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
5.1767 + (t as Const ("Script.Try",_) $ e $ _) a v =
5.1768 + ((*writeln("### nxt_up Try "^
5.1769 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
5.1770 + nstep_up thy ptp scr E l Skip_ a v )
5.1771 +(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e), a, v) =
5.1772 + (thy, ptp, (Script sc),
5.1773 + E, up, ay,(go up sc), a, v);
5.1774 + *)
5.1775 + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
5.1776 + (t as Const ("Script.Try"(*2*),_) $ e) a v =
5.1777 + ((*writeln("### nxt_up Try "^
5.1778 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
5.1779 + nstep_up thy ptp scr E l Skip_ a v)
5.1780 +
5.1781 +
5.1782 + | nxt_up thy ptp scr E l ay
5.1783 + (Const ("Script.Or",_) $ _ $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
5.1784 +
5.1785 + | nxt_up thy ptp scr E l ay
5.1786 + (Const ("Script.Or",_) $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
5.1787 +
5.1788 + | nxt_up thy ptp scr E l ay
5.1789 + (Const ("Script.Or",_) $ _ ) a v =
5.1790 + nstep_up thy ptp scr E (drop_last l) ay a v
5.1791 +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ _ $ _), a, v) =
5.1792 + (thy, ptp, (Script sc),
5.1793 + E, up, ay,(go up sc), a, v);
5.1794 + *)
5.1795 + | nxt_up thy ptp scr E l ay (*all has been done in (*2*) below*)
5.1796 + (Const ("Script.Seq"(*1*),_) $ _ $ _ $ _) a v =
5.1797 + nstep_up thy ptp scr E l ay a v
5.1798 +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ e2), a, v) =
5.1799 + (thy, ptp, (Script sc),
5.1800 + E, up, ay,(go up sc), a, v);
5.1801 + *)
5.1802 + | nxt_up thy ptp scr E l ay (*comes from e2*)
5.1803 + (Const ("Script.Seq"(*2*),_) $ _ $ e2) a v =
5.1804 + nstep_up thy ptp scr E l ay a v
5.1805 +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _), a, v) =
5.1806 + (thy, ptp, (Script sc),
5.1807 + E, up, ay,(go up sc), a, v);
5.1808 + *)
5.1809 + | nxt_up thy ptp (scr as Script sc) E l ay (*comes from e1*)
5.1810 + (Const ("Script.Seq",_) $ _) a v =
5.1811 + if ay = Napp_
5.1812 + then nstep_up thy ptp scr E (drop_last l) Napp_ a v
5.1813 + else (*Skip_*)
5.1814 + let val up = drop_last l;
5.1815 + val Const ("Script.Seq"(*2*),_) $ _ $ e2 = go up sc;
5.1816 + in case appy thy ptp E (up@[R]) e2 a v of
5.1817 + Appy lr => Appy lr
5.1818 + | Napp E => nstep_up thy ptp scr E up Napp_ a v
5.1819 + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end
5.1820 +
5.1821 + | nxt_up (thy,_) ptp scr E l ay t a v =
5.1822 + raise error ("nxt_up not impl for "^
5.1823 + (Sign.string_of_term (sign_of (assoc_thy thy)) t))
5.1824 +
5.1825 +(* val (thy, ptp, (Script sc), E, l, ay, a, v)=
5.1826 + (thy, ptp, scr, E, l, Skip_, a, v);
5.1827 + val (thy, ptp, (Script sc), E, l, ay, a, v)=
5.1828 + (thy, ptp, sc, E, l, Skip_, a, v);
5.1829 + *)
5.1830 +and nstep_up thy ptp (Script sc) E l ay a v =
5.1831 + ((*writeln("### nstep_up from: "^(loc_2str l));
5.1832 + writeln("### nstep_up from: "^
5.1833 + (Sign.string_of_term (sign_of (assoc_thy thy)) (go l sc)));*)
5.1834 + if 1 < length l
5.1835 + then
5.1836 + let
5.1837 + val up = drop_last l;
5.1838 + in ((*writeln("### nstep_up to: "^
5.1839 + (Sign.string_of_term (sign_of (assoc_thy thy)) (go up sc)));*)
5.1840 + nxt_up thy ptp (Script sc) E up ay (go up sc) a v ) end
5.1841 + else (*interpreted to end*)
5.1842 + if ay = Skip_ then Skip (v, E) else Napp E
5.1843 +);
5.1844 +
5.1845 +(* decide for the next applicable stac in the script;
5.1846 + returns (stactic, value) - the value in case the script is finished
5.1847 + 12.8.02: ~~~~~ and no assumptions ??? FIXME ???
5.1848 + 20.8.02: must return p in case of finished, because the next script
5.1849 + consulted need not be the calling script:
5.1850 + in case of detail ie. _inserted_ PrfObjs, the next stac
5.1851 + has to searched in a script with PblObj.status<>Complete !
5.1852 + (.. not true for other details ..PrfObj ??????????????????
5.1853 + 20.8.02: do NOT return safe (is only changed in locate !!!)
5.1854 +*)
5.1855 +(* val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
5.1856 + (thy', (pt,p), sc, RrlsState (ii t));
5.1857 + val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
5.1858 + (thy', (pt',p'), sc, is');
5.1859 + *)
5.1860 +fun next_tac (thy,_) (pt,p) (Rfuns {next_rule,...}) (RrlsState(f,f',rss,_))=
5.1861 + if f = f' then (End_Detail' (f',[])(*8.6.03*), Uistate,
5.1862 + (f', Sundef(*FIXME is no value of next_tac! vor 8.6.03*)))
5.1863 + (*finished*)
5.1864 + else (case next_rule rss f of
5.1865 + None => (Empty_Tac_, Uistate, (e_term, Sundef)) (*helpless*)
5.1866 +(* val Some (Thm (id,thm)) = next_rule rss f;
5.1867 + *)
5.1868 + | Some (Thm (id,thm))(*8.6.03: muss auch f' liefern ?!!*) =>
5.1869 + (Rewrite' (thy, "e_rew_ord", e_rls,(*!?!8.6.03*) false,
5.1870 + (id, string_of_thmI thm), f,(e_term,[(*!?!8.6.03*)])),
5.1871 + Uistate, (e_term, Sundef))) (*next stac*)
5.1872 +
5.1873 +(* val(thy, ptp as (pt,(p,_)), sc as Script (h $ body),ScrState (E,l,a,v,s,b))=
5.1874 + ((thy',srls), (pt,pos), sc, is);
5.1875 + *)
5.1876 + | next_tac thy (ptp as (pt,(p,_)):ptree * pos') (sc as Script (h $ body))
5.1877 + (ScrState (E,l,a,v,s,b)) =
5.1878 + ((*writeln("### next_tac-----------------: E= ");
5.1879 + writeln( istate2str (ScrState (E,l,a,v,s,b)));*)
5.1880 + case if l=[] then appy thy ptp E [R] body None v
5.1881 + else nstep_up thy ptp sc E l Skip_ a v of
5.1882 + Skip (v,_) => (*finished*)
5.1883 + (case par_pbl_det pt p of
5.1884 + (true, p', _) =>
5.1885 + let val (_,pblID,_) = get_obj g_spec pt p';
5.1886 + in (Check_Postcond' (pblID, (v, [(*8.6.03 NO asms???*)])),
5.1887 + e_istate, (v,s)) end
5.1888 + | (_,p',rls') => (End_Detail' (e_term,[])(*8.6.03*), e_istate, (v,s)))
5.1889 + | Napp _ => (Empty_Tac_, e_istate, (e_term, Sundef)) (*helpless*)
5.1890 + | Appy (m', scrst as (_,_,_,v,_,_)) => (m', ScrState scrst,
5.1891 + (v, Sundef))) (*next stac*)
5.1892 +
5.1893 + | next_tac _ _ _ is = raise error ("next_tac: not impl for "^
5.1894 + (istate2str is));
5.1895 +
5.1896 +
5.1897 +
5.1898 +
5.1899 +(*.create the initial interpreter state from the items of the guard.*)
5.1900 +(* val (thy, itms, metID) = (thy, itms, mI);
5.1901 + *)
5.1902 +fun init_scrstate thy itms metID =
5.1903 + let val actuals = itms2args thy metID itms;
5.1904 + val scr as Script sc = (#scr o get_met) metID;
5.1905 + val formals = formal_args sc
5.1906 + (*expects same sequence of (actual) args in itms
5.1907 + and (formal) args in met*)
5.1908 + fun relate_args env [] [] = env
5.1909 + | relate_args env _ [] =
5.1910 + raise error ("ERROR in creating the environment for '"
5.1911 + ^id_of_scr sc^"' from \nthe items of the guard of "
5.1912 + ^metID2str metID^",\n\
5.1913 + \formal arg(s), from the script,\
5.1914 + \ miss actual arg(s), from the guards env:\n"
5.1915 + ^(string_of_int o length) formals
5.1916 + ^" formals: "^terms2str formals^"\n"
5.1917 + ^(string_of_int o length) actuals
5.1918 + ^" actuals: "^terms2str actuals)
5.1919 + | relate_args env [] actual_finds = env (*may drop Find!*)
5.1920 + | relate_args env (a::aa) (f::ff) =
5.1921 + if type_of a = type_of f
5.1922 + then relate_args (env @ [(a, f)]) aa ff else
5.1923 + raise error ("ERROR in creating the environment for '"
5.1924 + ^id_of_scr sc^"' from \nthe items of the guard of "
5.1925 + ^metID2str metID^",\n\
5.1926 + \different types of formal arg, from the script,\
5.1927 + \ and actual arg, from the guards env:'\n\
5.1928 + \formal: '"^term2str a^"::"^(type2str o type_of) a^"'\n\
5.1929 + \actual: '"^term2str f^"::"^(type2str o type_of) f^"'\n\
5.1930 + \in\n\
5.1931 + \formals: "^terms2str formals^"\n\
5.1932 + \actuals: "^terms2str actuals)
5.1933 + val env = relate_args [] formals actuals;
5.1934 + in (ScrState (env,[],None,e_term,Safe,true), scr):istate * scr end;
5.1935 +
5.1936 +(*.decide, where to get script/istate from:
5.1937 + (*1*) from PblObj.env: at begin of script if no init_form
5.1938 + (*2*) from PblObj/PrfObj: if stac is in the middle of the script
5.1939 + (*3*) from rls/PrfObj: in case of detail a ruleset.*)
5.1940 +(* val (thy', (p,p_), pt) = (thy', (p,p_), pt);
5.1941 + *)
5.1942 +fun from_pblobj_or_detail' thy' (p,p_) pt =
5.1943 + if p_ mem [Pbl,Met]
5.1944 + then case get_obj g_env pt p of
5.1945 + None => raise error "from_pblobj_or_detail': no istate"
5.1946 + | Some is =>
5.1947 + let val metID = get_obj g_metID pt p
5.1948 + val {srls,...} = get_met metID
5.1949 + in (srls, is, (#scr o get_met) metID) end
5.1950 + else
5.1951 + let val (pbl,p',rls') = par_pbl_det pt p
5.1952 + in if pbl
5.1953 + then (*2*)
5.1954 + let val thy = assoc_thy thy'
5.1955 + val PblObj{meth=itms,...} = get_obj I pt p'
5.1956 + val metID = get_obj g_metID pt p'
5.1957 + val {srls,...} = get_met metID
5.1958 + in (*if last_elem p = 0 (*nothing written to pt yet*)
5.1959 + then let val (is, sc) = init_scrstate thy itms metID
5.1960 + in (srls, is, sc) end
5.1961 + else*) (srls, get_istate pt (p,p_), (#scr o get_met) metID)
5.1962 + end
5.1963 + else (*3*)
5.1964 + (e_rls, (*FIXME: get from pbl or met !!!
5.1965 + unused for Rrls in locate_gen, next_tac*)
5.1966 + get_istate pt (p,p_),
5.1967 + case rls' of
5.1968 + Rls {scr=scr,...} => scr
5.1969 + | Seq {scr=scr,...} => scr
5.1970 + | Rrls {scr=rfuns,...} => rfuns)
5.1971 + end;
5.1972 +
5.1973 +(*.get script and istate from PblObj, see (*1*) above.*)
5.1974 +fun from_pblobj' thy' (p,p_) pt =
5.1975 + let val p' = par_pblobj pt p
5.1976 + val thy = assoc_thy thy'
5.1977 + val PblObj{meth=itms,...} = get_obj I pt p'
5.1978 + val metID = get_obj g_metID pt p'
5.1979 + val {srls,scr,...} = get_met metID
5.1980 + in if last_elem p = 0 (*nothing written to pt yet*)
5.1981 + then let val (is, scr) = init_scrstate thy itms metID
5.1982 + in (srls, is, scr) end
5.1983 + else (srls, get_istate pt (p,p_), scr)
5.1984 + end;
5.1985 +
5.1986 +(*.get the stactics and problems of a script as tacs
5.1987 + instantiated with the current environment;
5.1988 + l is the location which generated the given formula.*)
5.1989 +(*WN.12.5.03: quick-and-dirty repair for listexpressions*)
5.1990 +fun is_spec_pos Pbl = true
5.1991 + | is_spec_pos Met = true
5.1992 + | is_spec_pos _ = false;
5.1993 +
5.1994 +(*. fetch _all_ tactics from script .*)
5.1995 +fun sel_rules _ (([],Res):pos') =
5.1996 + raise PTREE "no tactics applicable at the end of a calculation"
5.1997 +| sel_rules pt (p,p_) =
5.1998 + if is_spec_pos p_
5.1999 + then [get_obj g_tac pt p]
5.2000 + else
5.2001 + let val pp = par_pblobj pt p;
5.2002 + val thy' = (get_obj g_domID pt pp):theory';
5.2003 + val thy = assoc_thy thy';
5.2004 + val metID = get_obj g_metID pt pp;
5.2005 + val metID' =if metID =e_metID then(thd3 o snd3)(get_obj g_origin pt pp)
5.2006 + else metID
5.2007 + val {scr=Script sc,srls,...} = get_met metID'
5.2008 + val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_);
5.2009 + in map ((stac2tac pt thy) o rep_stacexpr o #2 o
5.2010 + (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) end;
5.2011 +(*
5.2012 +> val Script sc = (#scr o get_met) ("SqRoot.thy","sqrt-equ-test");
5.2013 +> val env = [((term_of o the o (parse Isac.thy)) "bdv",
5.2014 + (term_of o the o (parse Isac.thy)) "x")];
5.2015 +> map ((stac2tac pt thy) o #2 o(subst_stacexpr env None e_term)) (stacpbls sc);
5.2016 +*)
5.2017 +
5.2018 +(*. filter applicable tactics while recursively decompose rule-sets
5.2019 + to atomic (Rewrite*, Calculate) tactics .*)
5.2020 +(*
5.2021 +fun @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@2
5.2022 +*)
5.2023 +
5.2024 +
5.2025 +(*
5.2026 +end
5.2027 +open Interpreter;
5.2028 +*)
5.2029 +
5.2030 +(* use"ME/script.sml";
5.2031 + use"script.sml";
5.2032 + *)
6.1 --- a/src/sml/ME/solve.sml Mon Dec 31 09:55:43 2007 +0100
6.2 +++ b/src/sml/ME/solve.sml Mon Dec 31 14:18:53 2007 +0100
6.3 @@ -523,7 +523,7 @@
6.4 *)
6.5 fun rul_terms_2nds nds t [] = nds
6.6 | rul_terms_2nds nds t ((rule, res as (t', _)) :: rts) =
6.7 - (append_atomic [] e_istate t (rule2tac rule) res Complete EmptyPtree) ::
6.8 + (append_atomic [] e_istate t (rule2tac [] rule) res Complete EmptyPtree) ::
6.9 (rul_terms_2nds nds t' rts);
6.10
6.11
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/src/sml/calcelems.sml Mon Dec 31 14:18:53 2007 +0100
7.3 @@ -0,0 +1,623 @@
7.4 +(* elements of calculations.
7.5 + they are partially held in association lists as ref's for
7.6 + switching language levels (meta-string, object-values).
7.7 + in order to keep these ref's during re-evaluation of code,
7.8 + they are defined here at the beginning of the code.
7.9 + author: Walther Neuper
7.10 + (c) isac-team 2003
7.11 +
7.12 +use"calcelems.sml";
7.13 +*)
7.14 +
7.15 +val linefeed = (curry op^) "\n";
7.16 +type authors = string list;
7.17 +
7.18 +type cterm' = string;
7.19 +val empty_cterm' = "empty_cterm'";
7.20 +type thmID = string;
7.21 +type thm' = thmID * cterm';(*WN060610 deprecated in favour of thm''*)
7.22 +type thm'' = thmID * term;
7.23 +type rls' = string;
7.24 +(*.a 'guh'='globally unique handle' is a string unique for each element
7.25 + of isac's KEStore and persistent over time
7.26 + (in particular under shifts within the respective hierarchy);
7.27 + specialty for thys:
7.28 + # guh NOT resistant agains shifts from one thy to another
7.29 + (which is the price for Isabelle's design: thy's overwrite ids of subthy's)
7.30 + # requirement for matchTheory: induce guh from tac + current thy
7.31 + (see 'fun thy_containing_thm', 'fun thy_containing_rls' etc.)
7.32 + TODO: introduce to pbl, met.*)
7.33 +type guh = string;
7.34 +val e_guh = "e_guh":guh;
7.35 +
7.36 +type xml = string;
7.37 +
7.38 +(*. eval function calling sml code during rewriting.*)
7.39 +type eval_fn = (string -> term -> theory -> (string * term) option);
7.40 +fun e_evalfn (_:'a) (_:term) (_:theory) = None:(string * term) option;
7.41 +(*. op in isa-term 'Const(op,_)' .*)
7.42 +type cal = (string * eval_fn);
7.43 +(*. fun calculate_ fetches the evaluation-function via this list. *)
7.44 +type calc = (string * cal);
7.45 +
7.46 +type subs' = (cterm' * cterm') list; (*16.11.00 for FE-KE*)
7.47 +type subst = (term * term) list; (*here for ets2str*)
7.48 +val e_subst = []:(term * term) list;
7.49 +
7.50 +(*TODO.WN060610 make use of "type rew_ord" total*)
7.51 +type rew_ord' = string;
7.52 +fun dummy_ord (_:subst) (_:term,_:term) = true;
7.53 +type rew_ord_ = subst -> Term.term * Term.term -> bool;
7.54 +type rew_ord = rew_ord' * rew_ord_;
7.55 +val e_rew_ord = dummy_ord;
7.56 +
7.57 +datatype rule =
7.58 + Erule (*WN.3.6.03 for rep_tac_ Check_elementwise*)
7.59 +| Thm of (string * thm)
7.60 +| Calc of string * (*check for equality*)
7.61 + (string -> term -> theory -> (string * term) option)
7.62 +| Rls_ of rls (*.ie. rule sets may be nested.*)
7.63 +and scr =
7.64 + EmptyScr
7.65 + | Script of term (*for met*)
7.66 + | Rfuns of {init_state : term ->
7.67 + (term * (*the current formula:
7.68 + goes locate_gen -> next_tac via istate*)
7.69 + term * (*the final formula*)
7.70 + rule list (*of reverse rewrite set (#1#)*)
7.71 + list * (*may be serveral, eg. in norm_rational*)
7.72 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
7.73 + (term * (*... rewrite with ...*)
7.74 + term list)) (*... assumptions*)
7.75 + list), (*derivation from given term to normalform
7.76 + in reverse order with sym_thm;
7.77 + (#1#) could be extracted from here #1*)
7.78 +
7.79 + normal_form: term -> (term * term list) option,
7.80 + locate_rule: rule list list -> term -> rule
7.81 + -> (rule * (term * term list)) list,
7.82 + next_rule : rule list list -> term -> rule option,
7.83 + attach_form: rule list list -> term -> term
7.84 + -> (rule * (term * term list)) list}
7.85 +and rls =
7.86 + Erls (*for init e_rls*)
7.87 +
7.88 + | Rls of (*a confluent and terminating ruleset, in general *)
7.89 + {id : string, (*for trace_rewrite:=true *)
7.90 + preconds : term list, (*unused WN020820 *)
7.91 + (*WN060616 for efficiency...
7.92 + bdvs : false, (*set in prep_rls for get_bdvs *)*)
7.93 + rew_ord : rew_ord, (*for rules*)
7.94 + erls : rls, (*for the conditions in rules *)
7.95 + srls : rls, (*for evaluation of list_fns in script *)
7.96 + calc : calc list, (*for Calculate in scr, set by prep_rls *)
7.97 + rules : rule list,
7.98 + scr : scr} (*Script term: generating intermed.steps *)
7.99 + | Seq of (*a sequence of rules to be tried only once *)
7.100 + {id : string, (*for trace_rewrite:=true *)
7.101 + preconds : term list, (*unused 20.8.02 *)
7.102 + (*WN060616 for efficiency...
7.103 + bdvs : false, (*set in prep_rls for get_bdvs *)*)
7.104 + rew_ord : rew_ord, (*for rules *)
7.105 + erls : rls, (*for the conditions in rules *)
7.106 + srls : rls, (*for evaluation of list_fns in script *)
7.107 + calc : calc list, (*for Calculate in scr, set by prep_rls *)
7.108 + rules : rule list,
7.109 + scr : scr} (*Script term (how to restrict type ???)*)
7.110 + (*Rrls call SML-code and simulate an rls
7.111 + difference: there is always _ONE_ redex rewritten in 1 call,
7.112 + thus wrap Rrls by: Rls (Rls_ ...)*)
7.113 +
7.114 + | Rrls of (*for 'reverse rewriting' by SML-functions instead Script*)
7.115 + {id : string, (*for trace_rewrite:=true *)
7.116 + prepat : (term list *(*preconds, eval with subst from pattern *)
7.117 + term ) (*pattern matched in subterms *)
7.118 + list, (*meta-conjunction is or *)
7.119 + rew_ord : rew_ord, (*for rules *)
7.120 + erls : rls, (*for the conditions in rules and pat *)
7.121 + (* '^ because of rewrite in applicable_in
7.122 + compare type met*)
7.123 + calc : calc list, (*for Calculate in scr, set by prep_rls *)
7.124 + scr : scr}; (*Rfuns {...} (how to restrict type ???)*)
7.125 +(*1.8.02 ad (how to restrict type ???): scr should be usable indepentently
7.126 + from rls, and then contain both Script _AND_ Rfuns !!!*)
7.127 +
7.128 +val e_rule = Thm ("refl",refl) : rule;
7.129 +fun id_of_thm (Thm (id, _)) = id
7.130 + | id_of_thm _ = raise error "id_of_thm";
7.131 +fun thm_of_thm (Thm (_, thm)) = thm
7.132 + | thm_of_thm _ = raise error "thm_of_thm";
7.133 +fun rep_thm_G' (Thm (thmid, thm)) = (thmid, thm);
7.134 +fun eq_thmI ((thmid1 : thmID, _ : thm), (thmid2 : thmID, _ : thm)) =
7.135 + (strip_thy thmid1) = (strip_thy thmid2);
7.136 +
7.137 +(*check for [.] as caused by "fun assoc_thm'"*)
7.138 +fun string_of_thmI thm =
7.139 + let val ct' = (de_quote o string_of_thm) thm
7.140 + val (a, b) = split_nlast (5, explode ct')
7.141 + in case b of
7.142 + [" ", " ","[", ".", "]"] => implode a
7.143 + | _ => ct'
7.144 + end;
7.145 +
7.146 +
7.147 +
7.148 +
7.149 +(*.id requested for all, Rls,Seq,Rrls.*)
7.150 +fun id_rls Erls = "e_rls" (*WN060714 quick and dirty: recursive defs!*)
7.151 + | id_rls (Rls {id,...}) = id
7.152 + | id_rls (Seq {id,...}) = id
7.153 + | id_rls (Rrls {id,...}) = id;
7.154 +val rls2str = id_rls;
7.155 +fun id_rule (Thm (id, _)) = id
7.156 + | id_rule (Calc (id, _)) = id
7.157 + | id_rule (Rls_ rls) = id_rls rls;
7.158 +
7.159 +fun get_rules (Rls {rules,...}) = rules
7.160 + | get_rules (Seq {rules,...}) = rules
7.161 + | get_rules (Rrls _) = [];
7.162 +
7.163 +fun rule2str Erule = "Erule"
7.164 + | rule2str (Thm (str, thm)) = "Thm (\""^str^"\","^(string_of_thmI thm)^")"
7.165 + | rule2str (Calc (str,f)) = "Calc (\""^str^"\",fn)"
7.166 + | rule2str (Rls_ rls) = "Rls_ (\""^id_rls rls^"\")";
7.167 +fun rule2str' Erule = "Erule"
7.168 + | rule2str' (Thm (str, thm)) = "Thm (\""^str^"\",\"\")"
7.169 + | rule2str' (Calc (str,f)) = "Calc (\""^str^"\",fn)"
7.170 + | rule2str' (Rls_ rls) = "Rls_ (\""^id_rls rls^"\")";
7.171 +
7.172 +fun eqrule (Thm (id1,_), Thm (id2,_)) = id1 = id2
7.173 + | eqrule (Calc (id1,_), Calc (id2,_)) = id1 = id2
7.174 + | eqrule (Rls_ _, Rls_ _) = false (*{id=id1}{id=id2} = id1 = id2 FIXXME*)
7.175 + | eqrule _ = false;
7.176 +
7.177 +
7.178 +type rrlsstate = (*state for reverse rewriting*)
7.179 + (term * (*the current formula:
7.180 + goes locate_gen -> next_tac via istate*)
7.181 + term * (*the final formula*)
7.182 + rule list (*of reverse rewrite set (#1#)*)
7.183 + list * (*may be serveral, eg. in norm_rational*)
7.184 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
7.185 + (term * (*... rewrite with ...*)
7.186 + term list)) (*... assumptions*)
7.187 + list); (*derivation from given term to normalform
7.188 + in reverse order with sym_thm;
7.189 + (#1#) could be extracted from here #1*)
7.190 +val e_type = Type("empty",[]);
7.191 +val a_type = TFree("'a",[]);
7.192 +val e_term = Const("empty",e_type);
7.193 +val a_term = Free("empty",a_type);
7.194 +val e_rrlsstate = (e_term,e_term,[[e_rule]],[(e_rule,(e_term,[]))]):rrlsstate;
7.195 +
7.196 +
7.197 +
7.198 +
7.199 +(*22.2.02: ging auf Linux nicht (Stefan)
7.200 +val e_scr = Script ((term_of o the o (parse thy)) "e_script");*)
7.201 +val e_term = Const("empty", Type("'a", []));
7.202 +val e_scr = Script e_term;
7.203 +
7.204 +
7.205 +(*ad thm':
7.206 + there are two kinds of theorems ...
7.207 + (1) known by isabelle
7.208 + (2) not known, eg. calc_thm, instantiated rls
7.209 + the latter have a thmid "#..."
7.210 + and thus outside isa we ALWAYS transport both (thmid,string_of_thmI)
7.211 + and have a special assoc_thm / assoc_rls in this interface *)
7.212 +type theory' = string; (* = domID ^".thy" *)
7.213 +type domID = string; (* domID ^".thy" = theory' TODO.11.03replace by thyID*)
7.214 +type thyID = string; (*WN.3.11.03 TODO: replace domID with thyID*)
7.215 +
7.216 +fun string_of_thy thy =
7.217 +((last_elem (Sign.stamp_names_of (sign_of thy)))^".thy"):theory';
7.218 +val theory2domID = string_of_thy;
7.219 +val theory2thyID = (get_thy o string_of_thy) : theory -> thyID;
7.220 +val theory2theory' = string_of_thy;
7.221 +val theory2str = string_of_thy; (*WN050903 ..most consistent naming*)
7.222 +val theory2str' = implode o (drop_last_n 4) o explode o string_of_thy;
7.223 +(*> theory2str' Isac.thy;
7.224 +al it = "Isac" : string
7.225 +*)
7.226 +
7.227 +fun thyID2theory' (thyID:thyID) =
7.228 + let val ss = explode thyID
7.229 + val ext = implode (takelast (4, ss))
7.230 + in if ext = ".thy" then thyID : theory' (*disarm abuse of thyID*)
7.231 + else thyID ^ ".thy"
7.232 + end;
7.233 +(* thyID2theory' "Isac" (*ok*);
7.234 +val it = "Isac.thy" : theory'
7.235 + > thyID2theory' "Isac.thy" (*abuse, goes ok...*);
7.236 +val it = "Isac.thy" : theory'
7.237 +*)
7.238 +
7.239 +fun theory'2thyID (theory':theory') =
7.240 + let val ss = explode theory'
7.241 + val ext = implode (takelast (4, ss))
7.242 + in if ext = ".thy" then ((implode o (drop_last_n 4)) ss) : thyID
7.243 + else theory' (*disarm abuse of theory'*)
7.244 + end;
7.245 +(* theory'2thyID "Isac.thy";
7.246 +val it = "Isac" : thyID
7.247 +> theory'2thyID "Isac";
7.248 +val it = "Isac" : thyID*)
7.249 +
7.250 +
7.251 +(*. WN0509 discussion:
7.252 +#############################################################################
7.253 +# How to manage theorys in subproblems wrt. the requirement, #
7.254 +# that scripts should be re-usable ? #
7.255 +#############################################################################
7.256 +
7.257 + eg. 'Script Solve_rat_equation' calls 'SubProblem (RatEq_,..'
7.258 + which would not allow to 'solve (y'' = -M_b / EI, M_b)' by this script
7.259 + because Biegelinie.thy is subthy of RatEq.thy and thus Biegelinie.M_b
7.260 + is unknown in RatEq.thy and M_b cannot be parsed into the scripts guard
7.261 + (see match_ags).
7.262 +
7.263 + Preliminary solution:
7.264 + # the thy in 'SubProblem (thy_, pbl, arglist)' is not taken automatically,
7.265 + # instead the 'maxthy (rootthy pt) thy_' is taken for each subpbl
7.266 + # however, a thy specified by the user in the rootpbl may lead to
7.267 + errors in far-off subpbls (which are not yet reported properly !!!)
7.268 + and interactively specifiying thys in subpbl is not very relevant.
7.269 +
7.270 + Other solutions possible:
7.271 + # always parse and type-check with Isac.thy
7.272 + (rejected tue to the vague idea eg. to re-use equations for R in C etc.)
7.273 + # regard the subthy-relation in specifying thys of subpbls
7.274 + # specifically handle 'SubProblem (undefined_, pbl, arglist)'
7.275 + # ???
7.276 +.*)
7.277 +(*WN0509 TODO "ProtoPure" ... would be more consistent
7.278 + with assoc_thy <--> theory2theory' +FIXME assoc_thy "e_domID" -> Script.thy*)
7.279 +val e_domID = "e_domID":domID;
7.280 +
7.281 +(*the key into the hierarchy ob theory elements*)
7.282 +type theID = string list;
7.283 +val e_theID = ["e_theID"];
7.284 +val theID2str = strs2str;
7.285 +(*theID eg. is ["IsacKnowledge", "Test", "Rulesets", "ac_plus_times"]*)
7.286 +fun theID2thyID (theID:theID) =
7.287 + if length theID >= 3 then (last_elem o (drop_last_n 2)) theID : thyID
7.288 + else raise error ("theID2thyID called with "^ theID2str theID);
7.289 +
7.290 +(*the key into the hierarchy ob problems*)
7.291 +type pblID = string list; (* domID::...*)
7.292 +val e_pblID = ["e_pblID"]:pblID;
7.293 +val pblID2str = strs2str;
7.294 +
7.295 +(*the key into the hierarchy ob methods*)
7.296 +type metID = string list;
7.297 +val e_metID = ["e_metID"]:metID;
7.298 +val metID2str = strs2str;
7.299 +
7.300 +(*either theID or pblID or metID*)
7.301 +type kestoreID = string list;
7.302 +val e_kestoreID = ["e_kestoreID"];
7.303 +val kestoreID2str = strs2str;
7.304 +
7.305 +(*for distinction of contexts*)
7.306 +datatype ketype = Exp_ | Thy_ | Pbl_ | Met_;
7.307 +fun ketype2str Exp_ = "Exp_"
7.308 + | ketype2str Thy_ = "Thy_"
7.309 + | ketype2str Pbl_ = "Pbl_"
7.310 + | ketype2str Met_ = "Met_";
7.311 +fun ketype2str' Exp_ = "Example"
7.312 + | ketype2str' Thy_ = "Theory"
7.313 + | ketype2str' Pbl_ = "Problem"
7.314 + | ketype2str' Met_ = "Method";
7.315 +
7.316 +(*see 'How to manage theorys in subproblems' at 'type thyID'*)
7.317 +val theory' = ref ([]:(theory' * theory) list);
7.318 +
7.319 +(*.all theories defined for Scripts, recorded in Scripts/Script.ML;
7.320 + in order to distinguish them from general IsacKnowledge defined later on.*)
7.321 +val script_thys = ref ([] : (theory' * theory) list);
7.322 +
7.323 +
7.324 +(*rewrite orders, also stored in 'type met' and type 'and rls'
7.325 + The association list is required for 'rewrite.."rew_ord"..'
7.326 + WN0509 tests not well-organized: see smltest/IsacKnowledge/termorder.sml*)
7.327 +val rew_ord' =
7.328 + ref ([]:(rew_ord' * (*the key for the association list *)
7.329 + (subst (*the bound variables - they get high order*)
7.330 + -> (term * term) (*(t1, t2) to be compared *)
7.331 + -> bool)) (*if t1 <= t2 then true else false *)
7.332 + list); (*association list *)
7.333 +rew_ord' := overwritel (!rew_ord', [("e_rew_ord", e_rew_ord),
7.334 + ("dummy_ord", dummy_ord)]);
7.335 +
7.336 +
7.337 +(*WN060120 a hack to get alltogether run again with minimal effort:
7.338 + theory' is inserted for creating thy_hierarchy; calls for assoc_rls
7.339 + need not be called*)
7.340 +val ruleset' = ref ([]:(rls' * (theory' * rls)) list);
7.341 +
7.342 +(*FIXME.040207 calclist': used by prep_rls, NOT in met*)
7.343 +val calclist'= ref ([]: calc list);
7.344 +
7.345 +(*.the hierarchy of thydata.*)
7.346 +
7.347 +(*.'a is for pbt | met.*)
7.348 +(*WN.24.4.03 -"- ... type parameters; afterwards naming inconsistent*)
7.349 +datatype 'a ptyp =
7.350 + Ptyp of string * (*element within pblID*)
7.351 + 'a list * (*several pbts with different domIDs/thy
7.352 + TODO: select by subthy (isaref.p.69)
7.353 + presently only _ONE_ elem*)
7.354 + ('a ptyp) list; (*the children nodes*)
7.355 +
7.356 +(*.datatype for collecting thydata for hierarchy.*)
7.357 +(*WN060720 more consistent naming would be 'type thyelem' or 'thelem'*)
7.358 +(*WN0606 Htxt contains html which does not belong to the sml-kernel*)
7.359 +datatype thydata = Html of {guh: guh,
7.360 + coursedesign: authors,
7.361 + mathauthors: authors,
7.362 + html: string} (*html; for demos before database*)
7.363 + | Hthm of {guh: guh,
7.364 + coursedesign: authors,
7.365 + mathauthors: authors,
7.366 + thm: Thm.thm}
7.367 + | Hrls of {guh: guh,
7.368 + coursedesign: authors,
7.369 + mathauthors: authors,
7.370 + (*like vvvvvvvvvvvvv val ruleset'
7.371 + WN060711 redesign together !*)
7.372 + thy_rls: (thyID * rls)}
7.373 + | Hcal of {guh: guh,
7.374 + coursedesign: authors,
7.375 + mathauthors: authors,
7.376 + calc: calc}
7.377 + | Hord of {guh: guh,
7.378 + coursedesign: authors,
7.379 + mathauthors: authors,
7.380 + ord: (subst -> (term * term) -> bool)};
7.381 +val e_thydata = Html {guh="e_guh", coursedesign=[], mathauthors=[], html=""};
7.382 +
7.383 +type thehier = (thydata ptyp) list;
7.384 +val thehier = ref ([] : thehier);
7.385 +
7.386 +(*.an association list, gets the value once in Isac.ML.*)
7.387 +val isab_thm_thy = ref ([] : (thmID * (thyID * thm)) list);
7.388 +
7.389 +
7.390 +type path = string;
7.391 +type filename = string;
7.392 +
7.393 +(*val xxx = fn: a b => (a,b); ??? fun-definition ???*)
7.394 +local
7.395 + fun ii (_:term) = e_rrlsstate;
7.396 + fun no (_:term) = Some (e_term,[e_term]);
7.397 + fun lo (_:rule list list) (_:term) (_:rule) = [(e_rule,(e_term,[e_term]))];
7.398 + fun ne (_:rule list list) (_:term) = Some e_rule;
7.399 + fun fo (_:rule list list) (_:term) (_:term) = [(e_rule,(e_term,[e_term]))];
7.400 +in
7.401 +val e_rfuns = Rfuns {init_state=ii,normal_form=no,locate_rule=lo,
7.402 + next_rule=ne,attach_form=fo};
7.403 +end;
7.404 +
7.405 +val e_rls =
7.406 + Rls{id = "e_rls",
7.407 + preconds = [],
7.408 + rew_ord = ("dummy_ord", dummy_ord),
7.409 + erls = Erls,srls = Erls,
7.410 + calc = [],
7.411 + rules = [], scr = EmptyScr}:rls;
7.412 +val e_rrls = Rrls {id = "e_rrls",
7.413 + prepat = [],
7.414 + rew_ord = ("dummy_ord", dummy_ord),
7.415 + erls = Erls,
7.416 + calc = [],
7.417 + (*asm_thm=[],*)
7.418 + scr=e_rfuns}:rls;
7.419 +ruleset' := overwritel (!ruleset', [("e_rls",("Tools",e_rls)),
7.420 + ("e_rrls",("Tools",e_rrls))
7.421 + ]);
7.422 +
7.423 +fun rep_rls (Rls {id,preconds,rew_ord,erls,srls,calc,(*asm_thm,*)rules,scr}) =
7.424 + {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls,srls=srls,calc=calc,
7.425 + (*asm_thm=asm_thm,*)rules=rules,scr=scr}
7.426 + | rep_rls (Seq {id,preconds,rew_ord,erls,srls,calc,(*asm_thm,*)rules,scr}) =
7.427 + {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls,srls=srls,calc=calc,
7.428 + (*asm_thm=asm_thm,*)rules=rules,scr=scr}
7.429 + | rep_rls Erls = rep_rls e_rls
7.430 + | rep_rls (Rrls {id,...}) = rep_rls e_rls
7.431 + (*raise error("rep_rls doesn't take apart reverse-rewrite-rule-sets: "^id)*);
7.432 +(*| rep_rls (Seq {id,...}) =
7.433 + raise error("rep_rls doesn't take apart reverse-rewrite-rule-sets: "^id);
7.434 +--1.7.03*)
7.435 +fun rep_rrls
7.436 + (Rrls {id,(*asm_thm,*) calc, erls, prepat, rew_ord,
7.437 + scr=Rfuns
7.438 + {attach_form,init_state,locate_rule,
7.439 + next_rule,normal_form}}) =
7.440 + {id=id,(*asm_thm=asm_thm,*) calc=calc, erls=erls, prepat=prepat,
7.441 + rew_ord=rew_ord, attach_form=attach_form, init_state=init_state,
7.442 + locate_rule=locate_rule, next_rule=next_rule, normal_form=normal_form}
7.443 + | rep_rrls (Rls {id,...}) =
7.444 + raise error ("rep_rrls doesn't take apart (normal) rule-sets: "^id)
7.445 + | rep_rrls (Seq {id,...}) =
7.446 + raise error ("rep_rrls doesn't take apart (normal) rule-sets: "^id);
7.447 +
7.448 +fun append_rls id (Rls {id=_,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.449 + rules =rs,scr=sc}) r =
7.450 + (Rls{id=id,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.451 + rules = rs @ r,scr=sc}:rls)
7.452 + | append_rls id (Seq {id=_,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.453 + rules =rs,scr=sc}) r =
7.454 + (Seq{id=id,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.455 + rules = rs @ r,scr=sc}:rls)
7.456 + | append_rls id (Rrls _) _ =
7.457 + raise error ("append_rls: not for reverse-rewrite-rule-set "^id);
7.458 +
7.459 +fun eq_rule (Thm (thm1,_), Thm (thm2,_)) = thm1 = thm2
7.460 + | eq_rule (Calc (id1,_), Calc (id2,_)) = id1 = id2
7.461 + | eq_rule _ = false;
7.462 +
7.463 +fun merge_rls _ Erls rls = rls
7.464 + | merge_rls _ rls Erls = rls
7.465 + | merge_rls id
7.466 + (Rls {id=id1,preconds=pc1,rew_ord=ro1,erls=er1,srls=sr1,calc=ca1,
7.467 + (*asm_thm=at1,*)rules =rs1,scr=sc1})
7.468 + (r2 as Rls {id=id2,preconds=pc2,rew_ord=ro2,erls=er2,srls=sr2,calc=ca2,
7.469 + (*asm_thm=at2,*)rules =rs2,scr=sc2}) =
7.470 + (Rls {id=id,preconds=pc1 @ ((#preconds o rep_rls) r2),
7.471 + rew_ord=ro1,erls=merge_rls "" er1 er2(*er1*),
7.472 + srls=merge_rls ("merged_"^id1^"_"^((#id o rep_rls) r2)) sr1
7.473 + ((#srls o rep_rls) r2),
7.474 + calc=ca1 @ ((#calc o rep_rls) r2),
7.475 + (*asm_thm=at1 @ ((#asm_thm o rep_rls) r2),*)
7.476 + rules = gen_union eq_rule rule2str (rs1, (#rules o rep_rls) r2),
7.477 + scr=sc1}:rls)
7.478 + | merge_rls id
7.479 + (Seq {id=id1,preconds=pc1,rew_ord=ro1,erls=er1,srls=sr1,calc=ca1,
7.480 + (*asm_thm=at1,*)rules =rs1,scr=sc1})
7.481 + (r2 as Seq {id=id2,preconds=pc2,rew_ord=ro2,erls=er2,srls=sr2,calc=ca2,
7.482 + (*asm_thm=at2,*)rules =rs2,scr=sc2}) =
7.483 + (Seq {id=id,preconds=pc1 @ ((#preconds o rep_rls) r2),
7.484 + rew_ord=ro1,erls=merge_rls "" er1 er2(*er1*),
7.485 + srls=merge_rls ("merged_"^id1^"_"^((#id o rep_rls) r2)) sr1
7.486 + ((#srls o rep_rls) r2),
7.487 + calc=ca1 @ ((#calc o rep_rls) r2),
7.488 + (*asm_thm=at1 @ ((#asm_thm o rep_rls) r2),*)
7.489 + rules = gen_union eq_rule rule2str (rs1, (#rules o rep_rls) r2),
7.490 + scr=sc1}:rls)
7.491 + | merge_rls _ _ _ =
7.492 + raise error "merge_rls: not for reverse-rewrite-rule-sets\
7.493 + \and not for mixed Rls -- Seq";
7.494 +fun remove_rls id (Rls {id=_,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.495 + (*asm_thm=at,*)rules =rs,scr=sc}) r =
7.496 + (Rls{id=id,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.497 + (*asm_thm=at,*)rules = gen_rems eq_rule (rs, r),
7.498 + scr=sc}:rls)
7.499 + | remove_rls id (Seq {id=_,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.500 + (*asm_thm=at,*)rules =rs,scr=sc}) r =
7.501 + (Seq{id=id,preconds=pc,rew_ord=ro,erls=er,srls=sr,calc=ca,
7.502 + (*asm_thm=at,*)rules = gen_rems eq_rule (rs, r),
7.503 + scr=sc}:rls)
7.504 + | remove_rls id (Rrls _) _ = raise error
7.505 + ("remove_rls: not for reverse-rewrite-rule-set "^id);
7.506 +
7.507 +(*!!!*)gen_rems (op=) ([1,2,3,4], [3,4,5]);
7.508 +
7.509 +(*elder version...*)
7.510 +fun mem_rls id rls =
7.511 + case find_first ((curry op=) id) (map id_rule ((#rules o rep_rls) rls)) of
7.512 + Some _ => true | None => false;
7.513 +fun memrls r (Rls {rules,...}) = gen_mem eqrule (r, rules)
7.514 + | memrls r (Seq {rules,...}) = gen_mem eqrule (r, rules)
7.515 + | memrls r _ = raise error ("memrls: incomplete impl. r= "^(rule2str r));
7.516 +
7.517 +fun rls_get_thm rls id =
7.518 + case find_first (curry eq_rule (Thm (id, refl(*dummy*))))
7.519 + ((#rules o rep_rls) rls) of
7.520 + Some thm => Some thm | None => None;
7.521 +
7.522 +
7.523 +
7.524 +fun assoc' ([], key) = raise error ("ME_Isa: '"^key^"' not known")
7.525 + | assoc' ((keyi, xi) :: pairs, key) =
7.526 + if key = keyi then Some xi else assoc' (pairs, key);
7.527 +
7.528 +fun assoc_thy (thy:theory') = ((the o assoc')(!theory',thy))
7.529 + handle _ => raise error ("ME_Isa: thy '"^thy^"' not in system");
7.530 +(*.associate an rls-identifier with an rls; related to 'fun assoc_rls';
7.531 + these are NOT compatible to "fun assoc_thm'" in that they do NOT handle
7.532 + overlays by re-using an identifier in different thys.*)
7.533 +fun assoc_rls (rls:rls') = ((#2 o the o assoc')(!ruleset',rls))
7.534 + handle _ => raise error ("ME_Isa: '"^rls^"' not in system");
7.535 +(*fun assoc_rls (rls:rls') = ((the o assoc')(!ruleset',rls))
7.536 + handle _ => raise error ("ME_Isa: '"^rls^"' not in system");*)
7.537 +
7.538 +(*.overwrite an element in an association list and pair it with a thyID
7.539 + in order to create the thy_hierarchy;
7.540 + overwrites existing rls' even if they are defined in a different thy;
7.541 + this is related to assoc_rls, TODO.WN060120: assoc_rew_ord, assoc_calc;.*)
7.542 +(*WN060120 ...these are NOT compatible to "fun assoc_thm'" in that
7.543 + they do NOT handle overlays by re-using an identifier in different thys;
7.544 + "thyID.rlsID" would be a good solution, if the "." would be possible
7.545 + in scripts...
7.546 + actually a hack to get alltogether run again with minimal effort*)
7.547 +fun insthy thy' (rls', rls) = (rls', (thy', rls));
7.548 +fun overwritelthy thy (al, bl:(rls' * rls) list) =
7.549 + let val bl' = map (insthy ((get_thy o theory2theory') thy)) bl
7.550 + in overwritel (al, bl') end;
7.551 +
7.552 +fun assoc_rew_ord ro = ((the o assoc') (!rew_ord',ro))
7.553 + handle _ => raise error ("ME_Isa: rew_ord '"^ro^"' not in system");
7.554 +(*get the string for stac from rule*)
7.555 +fun assoc_calc ([], key) = raise error ("assoc_calc: '"^ key ^"' not found")
7.556 + | assoc_calc ((calc, (keyi, xi)) :: pairs, key) =
7.557 + if key = keyi then calc else assoc_calc (pairs, key);
7.558 +(*only used for !calclist'*)
7.559 +fun assoc1 ([], key) = raise error ("assoc1 (for met.calc=): '"^ key
7.560 + ^"' not found")
7.561 + | assoc1 ((all as (keyi, _)) :: pairs, key) =
7.562 + if key = keyi then all else assoc1 (pairs, key);
7.563 +(*fun assoc_thm' requires mk_thm, num_str; see Scripts/rewrite.sml*)
7.564 +
7.565 +
7.566 +fun termopt2str (Some t) =
7.567 + "Some " ^ (Sign.string_of_term (sign_of(assoc_thy "Isac.thy")) t)
7.568 + | termopt2str None = "None";
7.569 +fun term2str t = Sign.string_of_term (sign_of(assoc_thy "Isac.thy")) t;
7.570 +(*for tests only*)
7.571 +fun terms2str ts= (strs2str o (map (Sign.string_of_term
7.572 + (sign_of (assoc_thy "Isac.thy"))))) ts;
7.573 +fun terms2strs ts= ((map (Sign.string_of_term
7.574 + (sign_of (assoc_thy "Isac.thy"))))) ts;
7.575 +fun type2str typ = Sign.string_of_typ (sign_of (assoc_thy "Isac.thy")) typ;
7.576 +
7.577 +fun subst2str (s:subst) =
7.578 + (strs2str o
7.579 + (map (linefeed o pair2str o
7.580 + (apsnd term2str) o
7.581 + (apfst term2str)))) s;
7.582 +fun subst2str' (s:subst) =
7.583 + (strs2str' o
7.584 + (map (pair2str o
7.585 + (apsnd term2str) o
7.586 + (apfst term2str)))) s;
7.587 +(*> subst2str' [(str2term "bdv", str2term "x"),
7.588 + (str2term "bdv_2", str2term "y")];
7.589 +val it = "[(bdv, x)]" : string
7.590 +*)
7.591 +val env2str = subst2str;
7.592 +
7.593 +
7.594 +(*recursive defs:*)
7.595 +fun scr2str (Script s) = "Script "^(term2str s)
7.596 + | scr2str (Rfuns _) = "Rfuns";
7.597 +
7.598 +
7.599 +fun maxthy thy1 thy2 = if subthy (thy1, thy2) then thy2 else thy1;
7.600 +
7.601 +
7.602 +(*.trace internal steps of isac's rewriter*)
7.603 +val trace_rewrite = ref false;
7.604 +(*.depth of recursion in traces of the rewriter, if trace_rewrite:=true.*)
7.605 +val depth = ref 99999;
7.606 +(*.no of rewrites exceeding this int -> NO rewrite.*)
7.607 +(*WN060829 still unused...*)
7.608 +val lim_rewrite = ref 99999;
7.609 +(*.no of derivation-elements exceeding this int -> SOME derivation-elements.*)
7.610 +val lim_deriv = ref 100;
7.611 +(*.switch for checking guhs unique before storing a pbl or met;
7.612 + set true at startup (done at begin of ROOT.ML)
7.613 + set false for editing IsacKnowledge (done at end of ROOT.ML).*)
7.614 +val check_guhs_unique = ref false;
7.615 +
7.616 +
7.617 +datatype lrd = (*elements of a path (=loc_) into an Isabelle term*)
7.618 + L (*go left at $*)
7.619 + | R (*go right at $*)
7.620 + | D; (*go down at Abs*)
7.621 +type loc_ = lrd list;
7.622 +fun ldr2str L = "L"
7.623 + | ldr2str R = "R"
7.624 + | ldr2str D = "D";
7.625 +fun loc_2str (k:loc_) = (strs2str' o (map ldr2str)) k;
7.626 +
8.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2 +++ b/src/sml/xmlsrc/thy-hierarchy.sml Mon Dec 31 14:18:53 2007 +0100
8.3 @@ -0,0 +1,361 @@
8.4 +(*.export theory-data to xml
8.5 + author: Walther Neuper 0601
8.6 + (c) isac-team
8.7 +
8.8 + FIXME.WN0602: re-engineer this file for analogy to pbl-met-hierarchy
8.9 + as follows:
8.10 + # 'fun collect_thydata': unit -> string list * thydata list
8.11 + ^^^^^^^^^^^ hierarchy-key
8.12 + # 'fun thys2file': from this ^^^ datastructure (^^^^^^^^^^^ for free!)
8.13 + # map 'fun store_pbt' (NEW!) over ^^^ into 'thy_data ptyp'
8.14 + # from 'thy_data ptyp' create 'thy_hierarchy'
8.15 +
8.16 +use"xmlsrc/thy-hierarchy.sml";
8.17 +use"thy-hierarchy.sml";
8.18 +.*)
8.19 +
8.20 +
8.21 +(**.collect data and build intermediate structure for hierarchy:
8.22 + theorems, rulesets and Calc's, (TODO rew_ord's etc) defined in isac
8.23 + and Isabelle-thms used in rulesets;
8.24 + this code binds ref-var's and must be after IsacKnowledge .**)
8.25 +
8.26 +(*.collect all theorems defined in in a theory and insert the guh.*)
8.27 +fun makeHthm (part:string, thyID:thyID) (thmID:thmID, thm:thm) =
8.28 + let val theID = [part, thyID, "Theorems"] @ [strip_thy thmID] : theID
8.29 + in (theID, Hthm {guh = theID2guh theID, coursedesign = [],
8.30 + mathauthors = ["isac-team"], thm = thm})
8.31 + end;
8.32 +fun makeHrls (part:string) (rls':rls', thy_rls as (thyID, rls): thyID * rls) =
8.33 + let val theID = [part, thyID,"Rulesets"] @ [rls'] : theID
8.34 + in (theID, Hrls {guh = theID2guh theID, coursedesign=[],
8.35 + mathauthors=["isac-team"], thy_rls = thy_rls})
8.36 + end;
8.37 +fun makeHcal (part:string, thyID:thyID) (calID, cal) =
8.38 + let val theID = [part, thyID,"Operations"] @ [calID] : theID
8.39 + in (theID, Hcal {guh = theID2guh theID, coursedesign=[],
8.40 + mathauthors=["isac-team"], calc = cal})
8.41 + end;
8.42 +fun makeHord (part:string, thyID:thyID) (ordID, ord) =
8.43 + let val theID = [part, thyID,"TODO-Orders"] @ [ordID] : theID
8.44 + in (theID, Hord {guh = theID2guh theID, coursedesign=[],
8.45 + mathauthors=["isac-team"], ord = ord})
8.46 + end;
8.47 +
8.48 +
8.49 +fun collect_thms' (part, thy') =
8.50 + let val thy = assoc_thy (thyID2theory' thy')
8.51 + in map (makeHthm (part, thy')) (thms_of thy) end;
8.52 +
8.53 +(*.collect all rulesets defined in in a theory and insert the guh.*)
8.54 +fun collect_rlss (part, thy') =
8.55 + let val rlss = filter ((curry op= thy') o
8.56 + ((#1 o #2):(rls' * (theory' * rls)) -> theory'))
8.57 + (!ruleset')
8.58 + in map (makeHrls part) rlss end;
8.59 +
8.60 +(*.collect all calcs defined in in a theory.*)
8.61 +fun collect_cals (part, thy') =
8.62 + let val cals = [] (*FIXXXXXXXXXXME.WN060713 add thyID: (thyID, cal)*)
8.63 + in map (makeHcal (part, thy')) cals end;
8.64 +
8.65 +
8.66 +(*.collect all rew_ord's defined in in a theory.*)
8.67 +fun collect_ords (part, thy') =
8.68 + let val thy = assoc_thy (thyID2theory' thy')
8.69 + in [(*TODO.WN060120 rew_ord, Calc*)]:(theID * thydata) list end;
8.70 +
8.71 +(*.collect all data for a thy TODO.WN060120 rew_ord, Calc.*)
8.72 +(* val thy' = nth 1 scri_thys;
8.73 + *)
8.74 +fun collect_thy part(*IsacScripts|IsacKnowledge*) (thy': theory') =
8.75 + ((collect_thms' (part, thy')) @ (collect_rlss (part, thy')) @
8.76 + (collect_cals (part, thy')) @ (collect_ords (part, thy')))
8.77 + : (theID * thydata) list;
8.78 +
8.79 +(*.collect theorems defined in Isabelle (before Isac is evaluated above).*)
8.80 +fun collect_isab isa (thyID, (thmID, thm)) =
8.81 + let val theID = [isa, thyID, "Theorems", thmID]
8.82 + in (theID:theID, Hthm {guh = theID2guh theID,
8.83 + mathauthors = ["Isabelle team, TU Munich"],
8.84 + coursedesign = [],
8.85 + thm = thm}) end;
8.86 +
8.87 +val isabelle_page = (["Isabelle"] : theID,
8.88 + Html {guh = theID2guh ["Isabelle"],
8.89 + html = "",
8.90 + mathauthors = ["Isabelle team, TU Munich"],
8.91 + coursedesign = []});
8.92 +
8.93 +(*.create a list with all thydata=thyelements=the;
8.94 + this list is used by 'fun the_hier' to create the hierarchy .*)
8.95 +fun collect_thydata () =
8.96 + let val isab_thms = map rearrange_inv (!isab_thm_thy)
8.97 + val scri_thys = (map (get_thy o #1) (!script_thys))
8.98 + \\ ["e_domID"]
8.99 + val isac_thys = (map (get_thy o #1)
8.100 + (!theory')) \\ scri_thys \\ ["e_domID"]
8.101 + in [isabelle_page] @
8.102 + (map (collect_isab "Isabelle") isab_thms) @
8.103 + ((flat o (map (collect_thy "IsacScripts"))) scri_thys) @
8.104 + ((flat o (map (collect_thy "IsacKnowledge"))) isac_thys)
8.105 + : (theID * thydata) list
8.106 + end;
8.107 +
8.108 +fun show_thes () = (writeln o format_pblIDl o (scan [])) (!thehier);
8.109 +
8.110 +
8.111 +
8.112 +(***.create the xml-format for the hierarchy.***)
8.113 +
8.114 +(**.make a hierarchy from (theID * thydata) list created by 'fun collect_thy';
8.115 + use the same mechanism as for pbl_hierarchy and met_hierarchy;
8.116 + but check, if a thydata is already there (for auto-gen. Isabelle).**)
8.117 +
8.118 +(*.for preserving elements created by 'fun store_thy'.*)
8.119 +fun exist_the (theID:theID) (thy_hie:thehier) =
8.120 + let fun node theID ids (Ptyp (id,_,ns)) =
8.121 + if theID = ids @ [id] then true
8.122 + else nodes theID (ids @ [id]) ns
8.123 + and nodes _ _ [] = false
8.124 + | nodes theID ids (n::ns) = if node theID ids n then true
8.125 + else nodes theID ids ns
8.126 + in nodes theID [] thy_hie end;
8.127 +
8.128 +(*.insrt requires a parent; see 'fun fill_parents'.*)
8.129 +fun can_insert (theID:theID) (thy_hie:thehier) =
8.130 + (insrt theID e_thydata theID thy_hie; true)
8.131 + handle _ => false;
8.132 +
8.133 +(*.cut 'theID', the ID of theory elements from tail to head
8.134 + until insertion into the hierarchy of theory elements 'th' is possible
8.135 + (the hierarchy requires the parentnode to exist for insertion).*)
8.136 +fun cut_theID th ([]:theID) =
8.137 + raise error "could not insert into thy-hierarchy"
8.138 + | cut_theID th theID =
8.139 + if can_insert theID th
8.140 + then theID else cut_theID th (drop_last theID);
8.141 +
8.142 +(*.insert empty parents 'Html' into the hierarchy of theory elements 'th'
8.143 + until the actual node can be inserted with key 'theID'.*)
8.144 +(* val (th, cutID, theID) = (th, theID, theID);
8.145 + val (th, cutID, theID) = (th', cutID_, theID);
8.146 + *)
8.147 +fun fill_parents th cutID theID =
8.148 + let val cutID' = cut_theID th cutID
8.149 + in if cutID' = theID
8.150 + then th
8.151 + else let val th' = insrt cutID' (Html {guh=theID2guh theID,
8.152 + coursedesign=["isac team 2006"],
8.153 + mathauthors=[],
8.154 + html=""}) cutID' th
8.155 + val cutID_ = cutID' @ [nth ((length cutID') + 1) theID]
8.156 + in fill_parents th' cutID_ theID end
8.157 + end;
8.158 +
8.159 +(*.create the hierarchy from a list (generated automatically);
8.160 + thus, missing parents of list-elems are inserted
8.161 + (causing msgs '*** insert: not found');
8.162 + elemes already store_*d in some *.ML are NOT overwritten.*)
8.163 +fun the_hier th ([]: (theID * thydata) list) = th
8.164 +(* val (th, (theID, thydata)::ths) = (!thehier, collect_thydata ());
8.165 + *)
8.166 + | the_hier th ((theID, thydata)::ths) =
8.167 + if can_insert theID th
8.168 + then let val th' = if exist_the theID th
8.169 + then (writeln ("*** insert: preserved "^strs2str theID);
8.170 + th)
8.171 + else insrt theID thydata theID th
8.172 + in the_hier th' ths end
8.173 + else let val th' = fill_parents th theID theID (*..*** insert: not found*)
8.174 + val th' = insrt theID thydata theID th'
8.175 + in the_hier th' ths end;
8.176 +
8.177 +
8.178 +(*these files shall contain 'invisible' html
8.179 +val thydatafilename = "thy_datafile.xml"; (*for "Theorems"|...*)
8.180 +fun partfilename str = "thy_" ^ str ^ ".xml"; (*for "Isabelle"|...*)*)
8.181 +
8.182 +(*.create an xml-hierarchy where the filname is created from the guh.*)
8.183 +(*ad DTD: a NODE contains an ID and zero or more NODEs*)
8.184 +fun hierarchy_guh h =
8.185 + let val i = indentation
8.186 + val j = indentation
8.187 + fun node i p theID (Ptyp (id,_,ns)) =
8.188 + let val p' = lev_on p
8.189 + val theID' = theID @ [id]
8.190 + in (indt i) ^ "<NODE>\n" ^
8.191 + (indt (i+j)) ^ "<ID> " ^ id ^ " </ID>\n" ^
8.192 + (indt (i+j)) ^ "<NO> " (*on this level*) ^
8.193 + (string_of_int o last_elem) p' ^ " </NO>\n" ^
8.194 + (indt (i+j)) ^ "<CONTENTREF> " ^ theID2guh theID' ^
8.195 + " </CONTENTREF>\n" ^
8.196 + (nodes (i+j) (lev_dn p') theID' ns) ^
8.197 + (indt i) ^ "</NODE>\n"
8.198 + end
8.199 + and nodes _ _ _ [] = ""
8.200 + | nodes i p theID (n::ns) = (node i p theID n)
8.201 + ^ (nodes i (lev_on p) theID ns);
8.202 + in nodes j [0] [] h end;
8.203 +
8.204 +fun thy_hierarchy2file (path:path) =
8.205 + str2file (path ^ "thy_hierarchy.xml")
8.206 + ("<NODE>\n" ^
8.207 + " <ID> theory hierarchy </ID>\n" ^
8.208 + " <NO> 1 </NO>\n" ^
8.209 + " <CONTENTREF> thy_ROOT </CONTENTREF>\n" ^
8.210 + (hierarchy_guh (!thehier)) ^
8.211 + "</NODE>");
8.212 +
8.213 +
8.214 +(**.create the xml-files for the theory-data from the hierarchy.**)
8.215 +
8.216 +val i = indentation;
8.217 +(*analoguous to 'fun met2xml'*)
8.218 +fun thydata2xml (theID:theID, Html {guh, coursedesign, mathauthors, html}) =
8.219 + "<HTMLDATA>\n" ^
8.220 + indt i ^ "<GUH> "^ guh ^" </GUH>\n" ^
8.221 + id2xml i theID ^
8.222 + indt i ^ "<EXPLANATIONS> " ^ html ^ "</EXPLANATIONS>\n" ^
8.223 + authors2xml i "MATHAUTHORS" mathauthors ^
8.224 + authors2xml i "COURSEDESIGNS" coursedesign ^
8.225 + "</HTMLDATA>\n" : xml
8.226 + | thydata2xml (theID:theID, Hthm {guh, coursedesign, mathauthors, thm}) =
8.227 + "<THEOREMDATA>\n" ^
8.228 + indt i ^ "<GUH> "^ guh ^" </GUH>\n" ^
8.229 + id2xml i theID ^
8.230 + thm''2xml i thm ^
8.231 + indt i ^ "<PROOF>\n" ^
8.232 + extref2xml (i+i) "Proof of the theorem"
8.233 + ("http://www.ist.tugraz.at/projects/isac/www/\
8.234 + \kbase/thy/browser_info/HOL/HOL-Real/Isac/" ^
8.235 + nth 2 theID ^ ".html") ^
8.236 + indt i ^ "</PROOF>\n" ^
8.237 + indt i ^ "<EXPLANATIONS> </EXPLANATIONS>\n" ^
8.238 + authors2xml i "MATHAUTHORS" mathauthors ^
8.239 + authors2xml i "COURSEDESIGNS" coursedesign ^
8.240 + "</THEOREMDATA>\n"
8.241 +(* val (theID:theID, Hrls {guh, coursedesign, mathauthors, thy_rls}) =
8.242 + (theID, rlsdata);
8.243 + *)
8.244 + | thydata2xml (theID, Hrls {guh, coursedesign, mathauthors, thy_rls}) =
8.245 + "<RULESETDATA>\n" ^
8.246 + indt i ^ "<GUH> "^ guh ^" </GUH>\n" ^
8.247 + id2xml i theID ^
8.248 + rls2xml i thy_rls ^
8.249 + indt i ^ "<EXPLANATIONS> </EXPLANATIONS>\n" ^
8.250 + authors2xml i "MATHAUTHORS" mathauthors ^
8.251 + authors2xml i "COURSEDESIGNS" coursedesign ^
8.252 + "</RULESETDATA>\n"
8.253 +(* val (theID:theID, Hcal {guh, coursedesign, mathauthors, calc}) =
8.254 + (theID, rlsdata);
8.255 + *)
8.256 + | thydata2xml (theID, Hcal {guh, coursedesign, mathauthors, calc}) =
8.257 + "<RULESETDATA>\n" ^
8.258 + indt i ^ "<GUH> "^ guh ^" </GUH>\n" ^
8.259 + id2xml i theID ^
8.260 + calc2xml i (theID2thyID theID, calc) ^
8.261 + indt i ^ "<EXPLANATIONS> </EXPLANATIONS>\n" ^
8.262 + authors2xml i "MATHAUTHORS" mathauthors ^
8.263 + authors2xml i "COURSEDESIGNS" coursedesign ^
8.264 + "</RULESETDATA>\n"
8.265 + | thydata2xml (theID, _) =
8.266 + raise error ("thydata2xml: not implemented for "^ strs2str' theID);
8.267 +
8.268 +(*.analoguous to 'fun met2file'.*)
8.269 +fun thydata2file (xmldata:path) (pos:pos) (theID:theID) thydata =
8.270 + (writeln ("### thes2file: id = " ^ strs2str theID);
8.271 + str2file (xmldata ^ theID2filename theID)
8.272 + (thydata2xml (theID:theID, thydata)));
8.273 +
8.274 +(*.analoguous to 'fun node'; here we scan ??????????.*)
8.275 +(* val (pa, ids, po, wfn, (Ptyp (id,[n],ns))) =
8.276 + (pa, ids, po, wfn, n);
8.277 + *)
8.278 +fun thenode (pa:path) ids po wfn (Ptyp (id,[n],ns)) =
8.279 + let val po' = lev_on po
8.280 + in wfn pa po' (ids@[id]) n;
8.281 + thenodes pa (ids@[id]) ((lev_dn po'):pos) wfn ns end
8.282 +(* val (pa, ids, po, wfn, (n::ns)) =
8.283 + (path, []:string list, [0], thydata2file, (!thehier));
8.284 + *)
8.285 +and thenodes _ _ _ _ [] = ()
8.286 + | thenodes pa ids po wfn (n::ns) = (thenode pa ids po wfn n;
8.287 + thenodes pa ids (lev_on po) wfn ns);
8.288 +
8.289 +(*..analoguous to 'fun mets2file'*)
8.290 +fun thes2file (p : path) =
8.291 + thenodes p [] [0] thydata2file (!thehier);
8.292 +
8.293 +
8.294 +(***.store a single theory element in the hierarchy.***)
8.295 +
8.296 +(*.for mathauthors only, other html is added to xml exported from here.*)
8.297 +(* val (theID, mathauthors) =
8.298 + (["IsacKnowledge", theory2thyID Biegelinie.thy, "Theorems"],
8.299 + ["Walther Neuper 2005 supported by a grant from NMI Austria"]);
8.300 + *)
8.301 +fun store_isa (theID : theID) (mathauthors : authors) =
8.302 + let val guh = case theID of
8.303 + [part] => part2guh theID
8.304 + | [part, thyID, thypart] => thypart2guh theID
8.305 + val theID = guh2theID guh
8.306 + val the = Html {guh = guh,
8.307 + coursedesign = [],
8.308 + mathauthors = mathauthors,
8.309 + html = ""}
8.310 + in (*needs no (!check_guhs_unique) because guh is generated automatically*)
8.311 + thehier := insrt theID the theID (!thehier) end;
8.312 +
8.313 +fun store_thy thy (mathauthors : authors) =
8.314 + let val guh = thy2guh ["IsacKnowledge", theory2thyID thy]
8.315 + val theID = guh2theID guh
8.316 + val the = Html {guh = guh,
8.317 + coursedesign = [],
8.318 + mathauthors = mathauthors,
8.319 + html = ""}
8.320 + in (*needs no (!check_guhs_unique) because guh is generated automatically*)
8.321 + thehier := insrt theID the theID (!thehier) end;
8.322 +
8.323 +fun store_thm thy (thmID : thmID, thm) (mathauthors : authors) =
8.324 + let val guh = thm2guh ("IsacKnowledge", theory2thyID thy) thmID
8.325 + val theID = guh2theID guh
8.326 + val the = Hthm {guh = guh,
8.327 + coursedesign = [], (*done at xml exported from here*)
8.328 + mathauthors=mathauthors,
8.329 + thm = thm}
8.330 + in (*needs no (!check_guhs_unique) because guh is generated automatically*)
8.331 + thehier := insrt theID the theID (!thehier) end;
8.332 +
8.333 +fun store_rls thy rls (mathauthors : authors) =
8.334 + let val guh = rls2guh ("IsacKnowledge", theory2thyID thy)
8.335 + ((#id o rep_rls) rls)
8.336 + val theID = guh2theID guh
8.337 + val the = Hrls {guh = guh,
8.338 + coursedesign = [],
8.339 + mathauthors = mathauthors,
8.340 + thy_rls=(theory2thyID thy, rls)}
8.341 + in (*needs no (!check_guhs_unique) because guh is generated automatically*)
8.342 + thehier := insrt theID the theID (!thehier) end;
8.343 +
8.344 +fun store_cal thy cal (mathauthors : authors) =
8.345 + let val guh = cal2guh ("IsacKnowledge", theory2thyID thy)
8.346 + ("TODO store_cal")
8.347 + val theID = guh2theID guh
8.348 + val the = Hcal {guh = guh,
8.349 + coursedesign = [],
8.350 + mathauthors = mathauthors,
8.351 + calc = cal}
8.352 + in (*needs no (!check_guhs_unique) because guh is generated automatically*)
8.353 + thehier := insrt theID the theID (!thehier) end;
8.354 +
8.355 +fun store_ord thy ord (mathauthors : authors) =
8.356 + let val guh = ord2guh ("IsacKnowledge", theory2thyID thy)
8.357 + ("TODO store_ord")
8.358 + val theID = guh2theID guh
8.359 + val the = Hord {guh = guh,
8.360 + coursedesign = [],
8.361 + mathauthors = mathauthors,
8.362 + ord = ord}
8.363 + in (*needs no (!check_guhs_unique) because guh is generated automatically*)
8.364 + thehier := insrt theID the theID (!thehier) end;
9.1 --- a/src/smltest/IsacKnowledge/polyminus.sml Mon Dec 31 09:55:43 2007 +0100
9.2 +++ b/src/smltest/IsacKnowledge/polyminus.sml Mon Dec 31 14:18:53 2007 +0100
9.3 @@ -245,8 +245,8 @@
9.4 autoCalculate 1 CompleteCalc;
9.5 val ((pt,p),_) = get_calc 1;
9.6 if p = ([], Res) andalso
9.7 - term2str (get_obj g_res pt (fst p)) = "3 - 2 * e + 2 * f + 2 * g"
9.8 -then () else raise error "polyminus.sml: Vereinfache (3 - 2 * e + 2 * f...";
9.9 + term2str (get_obj g_res pt (fst p)) = "1 + 14 * u"
9.10 +then () else raise error "polyminus.sml: Vereinfache (2*u - 5 - (3 - ...";
9.11 show_pt pt;
9.12
9.13 "----- probe p.34 -----";
10.1 --- a/src/smltest/ME/rewtools.sml Mon Dec 31 09:55:43 2007 +0100
10.2 +++ b/src/smltest/ME/rewtools.sml Mon Dec 31 14:18:53 2007 +0100
10.3 @@ -25,6 +25,8 @@
10.4 "----------- fun string_of_thmI for_[.]_) ------------------------";
10.5 "----------- (sym_real_minus_eq_cancel, (?b1 = ?a1) ..._[.]_)-----";
10.6 "-----------------------------------------------------------------";
10.7 +"----------- fun filter_appl_rews --------------------------------";
10.8 +"-----------------------------------------------------------------";
10.9 "-----------------------------------------------------------------";
10.10
10.11
10.12 @@ -495,3 +497,23 @@
10.13
10.14 getTactic 1 ([1],Frm);
10.15
10.16 +"----------- fun filter_appl_rews --------------------------------";
10.17 +"----------- fun filter_appl_rews --------------------------------";
10.18 +"----------- fun filter_appl_rews --------------------------------";
10.19 +val f = str2term "a + z + 2*3*x + 4*a + 5+6";
10.20 +val thy = assoc_thy "Isac.thy";
10.21 +val subst = [(*TODO.WN071231 test Rewrite_Inst*)];
10.22 +val rls = Test_simplify;
10.23 +val Rls {rew_ord = ro, erls, rules,...} = rls;
10.24 +
10.25 +(*
10.26 +
10.27 +rewrite_ thy ro erls false thm f;
10.28 +
10.29 +rewrite_inst_ thy ro erls false subst thm f;
10.30 +
10.31 +print_depth 19;
10.32 + Test_simplify;
10.33 +print_depth 3;
10.34 +
10.35 +*)
10.36 \ No newline at end of file