1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/sml/ME/appl.sml Thu Apr 17 18:01:03 2003 +0200
1.3 @@ -0,0 +1,733 @@
1.4 +(* use"ME/appl.sml";
1.5 + *)
1.6 +val e_cterm' = empty_cterm';
1.7 +
1.8 +val e_rew_ord = dummy_ord;
1.9 +rew_ord' := overwritel (!rew_ord',
1.10 +[("e_rew_ord", e_rew_ord)]);
1.11 +
1.12 +(*bis 10.9.02 verwendet (nur cancel_binom)----------------------------*)
1.13 +fun rew_info (Rls {asm_thm, erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
1.14 + (rew_ord':rew_ord',erls,asm_thm,ca)
1.15 + | rew_info (Rrls {asm_thm, erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
1.16 + (rew_ord',erls,asm_thm,ca);
1.17 +
1.18 +(*FIXME.3.4.03:re-organize from_pblobj_or_detail_thm after rls' --> rls*)
1.19 +fun from_pblobj_or_detail_thm thm' p pt =
1.20 + let val (pbl,p',rls') = par_pbl_det pt p
1.21 + in if pbl
1.22 + then let (*val _= writeln("### from_pblobj_or_detail_thm: pbl=true")*)
1.23 + val thy' = get_obj g_domID pt p'
1.24 + val {rew_ord',erls,asm_thm,...} =
1.25 + get_met (get_obj g_metID pt p')
1.26 + val put_asm = (fst thm') mem (map fst asm_thm)
1.27 + (*val _= writeln("### from_pblobj_or_detail_thm: metID= "^
1.28 + (metID2str(get_obj g_metID pt p')))
1.29 + val _= writeln("### from_pblobj_or_detail_thm: erls= "^erls)*)
1.30 + in ("OK",thy',rew_ord',erls,put_asm)
1.31 + end
1.32 + else ((*writeln("### from_pblobj_or_detail_thm: pbl=false");*)
1.33 + (*case assoc(!ruleset', rls') of !!!FIXME.3.4.03:re-organize !!!
1.34 + None => ("unknown ruleset '"^rls'^"'","","",Erls,false)
1.35 + | Some rls =>*)
1.36 + let val thy' = get_obj g_domID pt (par_pblobj pt p)
1.37 + val (rew_ord',erls,asm_thm,_) = rew_info rls'
1.38 + val put_asm = (fst thm') mem (map fst asm_thm);
1.39 + in ("OK",thy',rew_ord',erls,put_asm) end)
1.40 + end;
1.41 +(*FIXME.3.4.03:re-organize from_pblobj_or_detail_calc after rls' --> rls*)
1.42 +fun from_pblobj_or_detail_calc scrop p pt =
1.43 + let val (pbl,p',rls') = par_pbl_det pt p
1.44 + in if pbl
1.45 + then let val thy' = get_obj g_domID pt p'
1.46 + val {calc = scr_isa_fns,...} =
1.47 + get_met (get_obj g_metID pt p')
1.48 + val opt = assoc (scr_isa_fns, scrop)
1.49 + in case opt of
1.50 + Some isa_fn => ("OK",thy',isa_fn)
1.51 + | None => ("applicable_in Calculate: unknown '"^scrop^"'",
1.52 + "",("",e_evalfn)) end
1.53 + else (*case assoc(!ruleset', rls') of
1.54 + None => ("unknown ruleset '"^rls'^"'","",("",e_evalfn))
1.55 + | Some rls => !!!FIXME.3.4.03:re-organize from_pblobj_or_detai*)
1.56 + (* val Some rls = assoc(!ruleset', rls');
1.57 + *)
1.58 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
1.59 + val (_,_,_,scr_isa_fns) = rew_info rls'(*rls*)
1.60 + in case assoc (scr_isa_fns, scrop) of
1.61 + Some isa_fn => ("OK",thy',isa_fn)
1.62 + | None => ("applicable_in Calculate: unknown '"^scrop^"'",
1.63 + "",("",e_evalfn)) end
1.64 + end;
1.65 +(*------------------------------------------------------------------*)
1.66 +
1.67 +val op_and = Const ("op &", [bool, bool] ---> bool);
1.68 +(*> cterm_of (sign_of thy) (op_and $ Free("a",bool) $ Free("b",bool));
1.69 +val it = "a & b" : cterm
1.70 +*)
1.71 +fun mk_and a b = op_and $ a $ b;
1.72 +(*> cterm_of (sign_of thy)
1.73 + (mk_and (Free("a",bool)) (Free("b",bool)));
1.74 +val it = "a & b" : cterm*)
1.75 +
1.76 +fun mk_and [] = HOLogic.true_const
1.77 + | mk_and (t::[]) = t
1.78 + | mk_and (t::ts) =
1.79 + let fun mk t' (t::[]) = op_and $ t' $ t
1.80 + | mk t' (t::ts) = mk (op_and $ t' $ t) ts
1.81 + in mk t ts end;
1.82 +(*> val pred = map (term_of o the o (parse thy))
1.83 + ["#0 <= #9 + #4 * x","#0 <= sqrt x + sqrt (#-3 + x)"];
1.84 +> cterm_of (sign_of thy) (mk_and pred);
1.85 +val it = "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)" : cterm*)
1.86 +
1.87 +
1.88 +
1.89 +
1.90 +(*for Check_elementwise in applicable_in: [x=1,..] Assumptions -> (x,0<=x&..)*)
1.91 +fun mk_set thy pt p (Const ("List.list.Nil",_)) pred =
1.92 + (e_term, HOLogic.true_const)
1.93 +(* val pred = (term_of o the o (parse thy)) pred;
1.94 + val consts as Const ("List.list.Cons",_) $ eq $ _ = ft;
1.95 + mk_set thy pt p consts pred;
1.96 + *)
1.97 + | mk_set thy pt p (consts as Const ("List.list.Cons",_) $ eq $ _) pred =
1.98 + let val (bdv,_) = HOLogic.dest_eq eq;
1.99 + val pred = if pred <> Const ("Script.Assumptions",bool)
1.100 + then pred
1.101 + else (mk_and o (map (term_of o the o (parse thy))) o
1.102 + (map fst)) (get_obj g_asm pt (par_pblobj pt p))
1.103 + in (bdv, pred) end
1.104 + | mk_set thy _ _ l _ =
1.105 + raise error ("check_elementwise: no set "^
1.106 + (Sign.string_of_term (sign_of thy) l));
1.107 +(*> val consts = (term_of o the o (parse thy)) "[x=#4]";
1.108 +> val pred = (term_of o the o (parse thy)) "Assumptions";
1.109 +> val pt = union_asm pt p
1.110 + [("#0 <= sqrt x + sqrt (#5 + x)",[11]),("#0 <= #9 + #4 * x",[22]),
1.111 + ("#0 <= x ^^^ #2 + #5 * x",[33]),("#0 <= #2 + x",[44])];
1.112 +> val p = [];
1.113 +> val (sss,ttt) = mk_set thy pt p consts pred;
1.114 +> (Sign.string_of_term (sign_of thy) sss,Sign.string_of_term(sign_of thy) ttt);
1.115 +val it = ("x","((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & ...*)
1.116 +
1.117 +
1.118 +
1.119 +(*check a list (/set) of constants [c_1,..,c_n] for c_i:set (: in)*)
1.120 +(* val (erls,consts,(bdv,pred)) = (erl,ft,vp);
1.121 + *)
1.122 +fun check_elementwise thy erls (consts:term) (bdv:term, pred:term) =
1.123 + let
1.124 + fun check thy pred ss' [] = ss'
1.125 + | check thy pred ss' (s::ss) =
1.126 + if eval_true_ (string_of_thy thy) erls (subst_atomic [s] pred)
1.127 + then check thy pred (ss' @ [s]) ss
1.128 + else check thy pred ss' ss;
1.129 + val c' = isalist2list consts;
1.130 + val c'' = map (snd o HOLogic.dest_eq) c'; (*assumes [x=1,x=2,..]*)
1.131 + val subs = map (pair bdv) c'';
1.132 + (*val _= writeln("### check_ele: consts= "^
1.133 + (Sign.string_of_term (sign_of thy) consts));*)
1.134 + (*val _= writeln("### check_ele: bdv = "^
1.135 + (Sign.string_of_term (sign_of thy) bdv));*)
1.136 + (*val _= writeln("### check_ele: pred = "^
1.137 + (Sign.string_of_term (sign_of thy) pred));*)
1.138 + in ((list2isalist bool) o (map HOLogic.mk_eq) o (map (pair bdv)) o
1.139 + (map snd))(check thy pred [] subs) end;
1.140 +
1.141 +(*
1.142 +val s::ss = subs;
1.143 +val s::_ = ss;
1.144 +
1.145 + val xxx = check thy pred [] subs;
1.146 + trace_rewrite:=true;
1.147 + trace_rewrite:=false;
1.148 + *)
1.149 +(*
1.150 +> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #3) + sqrt (#5 - #3)) &\
1.151 + \ #0 <= #25 + #-1 * #3 ^^^ #2) & #0 <= #4";
1.152 +> val Some(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct;
1.153 +val ct' = "True" : cterm'
1.154 +
1.155 +> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #-3) + sqrt (#5 - #-3)) &\
1.156 + \ #0 <= #25 + #-1 * #-3 ^^^ #2) & #0 <= #4";
1.157 +> val Some(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct;
1.158 +val ct' = "True" : cterm'
1.159 +
1.160 +
1.161 +> val const = (term_of o the o (parse thy)) "(#3::real)";
1.162 +> val pred' = subst_atomic [(bdv,const)] pred;
1.163 +
1.164 +
1.165 +> val consts = (term_of o the o (parse thy)) "[x = #-3, x = #3]";
1.166 +> val bdv = (term_of o the o (parse thy)) "(x::real)";
1.167 +> val pred = (term_of o the o (parse thy))
1.168 + "((#0 <= #18 & #0 <= sqrt (#5 + x) + sqrt (#5 - x)) & #0 <= #25 + #-1 * x ^^^ #2) & #0 <= #4";
1.169 +> val ttt = check_elementwise thy consts (bdv, pred);
1.170 +> cterm_of (sign_of thy) ttt;
1.171 +val it = "[x = #-3, x = #3]" : cterm
1.172 +
1.173 +> val consts = (term_of o the o (parse thy)) "[x = #4]";
1.174 +> val bdv = (term_of o the o (parse thy)) "(x::real)";
1.175 +> val pred = (term_of o the o (parse thy))
1.176 + "#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #5 * x & #0 <= #2 + x";
1.177 +> val ttt = check_elementwise thy consts (bdv,pred);
1.178 +> cterm_of (sign_of thy) ttt;
1.179 +val it = "[x = #4]" : cterm
1.180 +
1.181 +> val consts = (term_of o the o (parse thy)) "[x = #-12 // #5]";
1.182 +> val bdv = (term_of o the o (parse thy)) "(x::real)";
1.183 +> val pred = (term_of o the o (parse thy))
1.184 + " #0 <= sqrt x + sqrt (#-3 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #-3 * x & #0 <= #6 + x";
1.185 +> val ttt = check_elementwise thy consts (bdv,pred);
1.186 +> cterm_of (sign_of thy) ttt;
1.187 +val it = "[]" : cterm*)
1.188 +
1.189 +
1.190 +(* 14.1.01: for Mstep-dummies in root-equ only: skip str until "("*)
1.191 +fun split_dummy str =
1.192 +let fun scan s' [] = (implode s', "")
1.193 + | scan s' (s::ss) = if s=" " then (implode s', implode ss)
1.194 + else scan (s'@[s]) ss;
1.195 +in ((scan []) o explode) str end;
1.196 +(* split_dummy "subproblem_equation_dummy (x=-#5//#12)";
1.197 +val it = ("subproblem_equation_dummy","(x=-#5//#12)") : string * string
1.198 +> split_dummy "x=-#5//#12";
1.199 +val it = ("x=-#5//#12","") : string * string*)
1.200 +
1.201 +
1.202 +
1.203 +
1.204 +(* applicability of an mstep wrt ptree and pos
1.205 + (containing the form, msteps should be applied to);
1.206 + returns the _current_ pos, !!! _NO_ 12.4.00: pos of given formula !!!
1.207 + where the newly created formula should be written to
1.208 + ('hard' by generate1, ev.modified in generate by script
1.209 +8.01:
1.210 + for Rewrite...: calculates all what needed for generate1 (True for asm?)
1.211 + for SubProblem: what needed for generate1 must come from script (assy)
1.212 +*)
1.213 +fun applicable_in (_:pos') _ (Init_Proof (ct', spec)) =
1.214 + Appl (Init_Proof' (ct', spec))
1.215 +
1.216 + | applicable_in (p,p_) _ (Model_Problem pblID) =
1.217 + if p_ mem [Frm,Res]
1.218 + then Notappl ((mstep2str (Model_Problem pblID))^
1.219 + " not for pos "^(pos'2str (p,p_)))
1.220 + else Appl (Model_Problem' pblID)
1.221 +(* val Refine_Tacitly pI = m;
1.222 + *)
1.223 + | applicable_in (p,p_) pt (Refine_Tacitly pI) =
1.224 + if p_ mem [Frm,Res]
1.225 + then Notappl ((mstep2str (Refine_Tacitly pI))^
1.226 + " not for pos "^(pos'2str (p,p_)))
1.227 + else (* val Refine_Tacitly pI = m;
1.228 + *)
1.229 + let val (PblObj {origin = (oris, (dI',_,_)), ...}) = get_obj I pt p;
1.230 + val opt = refine_ori oris pI;
1.231 + in case opt of
1.232 + Some pblID => Appl (Refine_Tacitly' (pI, pblID))
1.233 + | None => Notappl ((mstep2str (Refine_Tacitly pI))^
1.234 + " not applicable") end
1.235 +(* val Refine_Problem pI = m;
1.236 + *)
1.237 + | applicable_in (p,p_) pt (Refine_Problem pI) =
1.238 + if p_ mem [Frm,Res]
1.239 + then Notappl ((mstep2str (Refine_Problem pI))^
1.240 + " not for pos "^(pos'2str (p,p_)))
1.241 + else
1.242 + let val (PblObj {origin=(_,(dI,_,_)),spec=(dI',_,_),
1.243 + probl=itms, ...}) = get_obj I pt p;
1.244 + val thy = if dI' = e_domID then dI else dI';
1.245 + val ms = refine_pbl (assoc_thy thy) pI itms;
1.246 + in if refined ms = pI
1.247 + then Notappl ((mstep2str (Refine_Problem pI))^" not applicable")
1.248 + else Appl (Refine_Problem' ms) end
1.249 +
1.250 + (*the specify-msteps have cterm' instead term:
1.251 + parse+error here!!!: see appl_add*)
1.252 + | applicable_in (p,p_) _ (Add_Given ct') =
1.253 + if p_ mem [Frm,Res]
1.254 + then Notappl ((mstep2str (Add_Given ct'))^
1.255 + " not for pos "^(pos'2str (p,p_)))
1.256 + else Appl (Add_Given' ct')
1.257 + (*Add_.. should reject (dsc //) (see fmz=[] in sqrt*)
1.258 +
1.259 + | applicable_in (p,p_) _ (Del_Given ct') =
1.260 + if p_ mem [Frm,Res]
1.261 + then Notappl ((mstep2str (Del_Given ct'))^
1.262 + " not for pos "^(pos'2str (p,p_)))
1.263 + else Appl (Del_Given' ct')
1.264 +
1.265 + | applicable_in (p,p_) _ (Add_Find ct') =
1.266 + if p_ mem [Frm,Res]
1.267 + then Notappl ((mstep2str (Add_Find ct'))^
1.268 + " not for pos "^(pos'2str (p,p_)))
1.269 + else Appl (Add_Find' ct')
1.270 +
1.271 + | applicable_in (p,p_) _ (Del_Find ct') =
1.272 + if p_ mem [Frm,Res]
1.273 + then Notappl ((mstep2str (Del_Find ct'))^
1.274 + " not for pos "^(pos'2str (p,p_)))
1.275 + else Appl (Del_Find' ct')
1.276 +
1.277 + | applicable_in (p,p_) _ (Add_Relation ct') =
1.278 + if p_ mem [Frm,Res]
1.279 + then Notappl ((mstep2str (Add_Relation ct'))^
1.280 + " not for pos "^(pos'2str (p,p_)))
1.281 + else Appl (Add_Relation' ct')
1.282 +
1.283 + | applicable_in (p,p_) _ (Del_Relation ct') =
1.284 + if p_ mem [Frm,Res]
1.285 + then Notappl ((mstep2str (Del_Relation ct'))^
1.286 + " not for pos "^(pos'2str (p,p_)))
1.287 + else Appl (Del_Relation' ct')
1.288 +
1.289 + | applicable_in (p,p_) _ (Specify_Domain dI) =
1.290 + if p_ mem [Frm,Res]
1.291 + then Notappl ((mstep2str (Specify_Domain dI))^
1.292 + " not for pos "^(pos'2str (p,p_)))
1.293 + else Appl (Specify_Domain' dI)
1.294 +(* val (p,p_) = p; val Specify_Problem pID = m;
1.295 + *)
1.296 + | applicable_in (p,p_) pt (Specify_Problem pID) =
1.297 + if p_ mem [Frm,Res]
1.298 + then Notappl ((mstep2str (Specify_Problem pID))^
1.299 + " not for pos "^(pos'2str (p,p_)))
1.300 + else
1.301 + let val (PblObj {origin=(oris,(dI,pI,_)),spec=(dI',pI',_),
1.302 + probl=itms, ...}) = get_obj I pt p;
1.303 + val thy = assoc_thy (if dI' = e_domID then dI else dI');
1.304 + val {ppc,where_,prls,...} = get_pbt pID;
1.305 + val pbl = if pI'=e_pblID andalso pI=e_pblID
1.306 + then (false, (init_pbl ppc, []))
1.307 + else match_itms_oris thy itms (ppc,where_,prls) oris;
1.308 + in Appl (Specify_Problem' (pID, pbl)) end
1.309 +(* val Specify_Method mID = nxt; val (p,p_) = p;
1.310 + *)
1.311 + | applicable_in (p,p_) pt (Specify_Method mID) =
1.312 + if p_ mem [Frm,Res]
1.313 + then Notappl ((mstep2str (Specify_Method mID))^
1.314 + " not for pos "^(pos'2str (p,p_)))
1.315 + else Appl (Specify_Method' mID)
1.316 +
1.317 + | applicable_in (p,p_) _ (Apply_Method mI) =
1.318 + if p_ mem [Frm,Res]
1.319 + then Notappl ((mstep2str (Apply_Method mI))^
1.320 + " not for pos "^(pos'2str (p,p_)))
1.321 + else Appl (Apply_Method' mI)
1.322 +
1.323 + | applicable_in (p,p_) pt (Check_Postcond pI) =
1.324 + if p_ mem [Pbl,Met]
1.325 + then Notappl ((mstep2str (Check_Postcond pI))^
1.326 + " not for pos "^(pos'2str (p,p_)))
1.327 + else Appl (Check_Postcond' (pI,e_term))
1.328 + (* in solve -"- gets for ^^^^ the return-value of script*)
1.329 +
1.330 + | applicable_in (p,p_) _ (Free_Solve) = Appl (Free_Solve')
1.331 +
1.332 +(*20.8.02 FIXXXXXME insert/cut ptree: to be decided in applicable_in*)
1.333 +(* val m as Rewrite_Inst (subs, thm') = m;
1.334 + *)
1.335 + | applicable_in (p,p_) pt (m as Rewrite_Inst (subs, thm')) =
1.336 + if p_ mem [Pbl,Met]
1.337 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.338 + else
1.339 + let
1.340 + val pp = par_pblobj pt p;
1.341 + val thy' = (get_obj g_domID pt pp):theory';
1.342 + val {rew_ord'=rew_ord',erls=erls,asm_thm=asm_thm,...} =
1.343 + get_met (get_obj g_metID pt pp);
1.344 + val put_asm = (fst thm') mem (map fst asm_thm);
1.345 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
1.346 + Frm => (get_obj g_form pt p, p)
1.347 + | Res => (get_obj g_result pt p, lev_on p)
1.348 + | _ => raise error ("applicable_in: call by "^
1.349 + (pos'2str (p,p_)));
1.350 + in
1.351 + let val subst = subs2subst (assoc_thy thy') subs;
1.352 + val subs' = subst2subs' subst;
1.353 + in case rewrite_inst thy' rew_ord' (id_rls erls)
1.354 + put_asm subs' thm' f of
1.355 + Some (f',asm) => Appl (
1.356 + Rewrite_Inst' (thy',rew_ord',erls,put_asm,subst,thm',
1.357 + (term_of o the o (parse (assoc_thy thy'))) f,
1.358 + ((term_of o the o (parse (assoc_thy thy'))) f',
1.359 + map (term_of o the o (parse (assoc_thy thy'))) asm)))
1.360 + | None => Notappl ((fst thm')^" not applicable") end
1.361 + handle _ => Notappl ("syntax error in "^(subs2str subs)) end
1.362 +
1.363 +(* val ((p,p_),m as Rewrite thm') = (p,nx);
1.364 +
1.365 + val m as Rewrite thm' = m;
1.366 + *)
1.367 +| applicable_in (p,p_) pt (m as Rewrite thm') =
1.368 + if p_ mem [Pbl,Met]
1.369 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.370 + else
1.371 + let
1.372 + (*val _= writeln("### applicable_in Rewrite");*)
1.373 + val (msg,thy',rew_ord',rls',put_asm) = from_pblobj_or_detail_thm thm' p pt;
1.374 + val f = case p_ of (*27.8.02 (f,p) = ... p discarded*)
1.375 + Frm => get_obj g_form pt p
1.376 + | Res => get_obj g_result pt p
1.377 + | _ => raise error ("applicable_in Rewrite: call by "^
1.378 + (pos'2str (p,p_)));
1.379 + in if msg = "OK"
1.380 + then
1.381 + ((*writeln("### applicable_in rls'= "^rls');*)
1.382 + case rewrite thy' rew_ord' (id_rls rls') put_asm thm' f of
1.383 + Some (f',asm) => Appl (
1.384 + Rewrite' (thy',rew_ord',rls',put_asm,thm',
1.385 + (term_of o the o (parse (assoc_thy thy'))) f,
1.386 + ((term_of o the o (parse (assoc_thy thy')))f',
1.387 + map (term_of o the o (parse (assoc_thy thy'))) asm)))
1.388 + | None => Notappl ("'"^(fst thm')^"' not applicable") )
1.389 + else Notappl msg
1.390 + end
1.391 +
1.392 +| applicable_in (p,p_) pt (m as Rewrite_Asm thm') =
1.393 + if p_ mem [Pbl,Met]
1.394 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.395 + else
1.396 + let
1.397 + val pp = par_pblobj pt p;
1.398 + val thy' = (get_obj g_domID pt pp):theory';
1.399 + val {rew_ord'=rew_ord',erls=erls,...} =
1.400 + get_met (get_obj g_metID pt pp);
1.401 + val put_asm = true;
1.402 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
1.403 + Frm => (get_obj g_form pt p, p)
1.404 + | Res => (get_obj g_result pt p, lev_on p)
1.405 + | _ => raise error ("applicable_in: call by "^
1.406 + (pos'2str (p,p_)));
1.407 + in case rewrite thy' rew_ord' (id_rls erls) put_asm thm' f of
1.408 + Some (f',asm) => Appl (
1.409 + Rewrite' (thy',rew_ord',erls,put_asm,thm',
1.410 + (term_of o the o (parse (assoc_thy thy'))) f,
1.411 + ((term_of o the o (parse (assoc_thy thy')))f',
1.412 + map (term_of o the o (parse (assoc_thy thy'))) asm)))
1.413 + | None => Notappl ("'"^(fst thm')^"' not applicable") end
1.414 +(* val (m as Rewrite_Set_Inst (subs, rls))=m;
1.415 + *)
1.416 + | applicable_in (p,p_) pt (m as Rewrite_Set_Inst (subs, rls)) =
1.417 + if p_ mem [Pbl,Met]
1.418 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.419 + else
1.420 + let
1.421 + val pp = par_pblobj pt p;
1.422 + val thy' = (get_obj g_domID pt pp):theory';
1.423 + val {rew_ord'=rew_ord',asm_rls=asm_rls,...} =
1.424 + get_met (get_obj g_metID pt pp);
1.425 + val put_asm = rls mem asm_rls;
1.426 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
1.427 + Frm => (get_obj g_form pt p, p)
1.428 + | Res => (get_obj g_result pt p, lev_on p)
1.429 + | _ => raise error ("applicable_in: call by "^
1.430 + (pos'2str (p,p_)));
1.431 + in
1.432 + let val subst = subs2subst (assoc_thy thy') subs;
1.433 + val subs' = subst2subs' subst;
1.434 + in case rewrite_set_inst thy' put_asm subs' rls f of
1.435 + Some (f',asm) => Appl (
1.436 + Rewrite_Set_Inst' (thy',put_asm,subst,assoc_rls rls,
1.437 + (term_of o the o (parse (assoc_thy thy'))) f,
1.438 + ((term_of o the o (parse (assoc_thy thy')))f',
1.439 + map (term_of o the o (parse (assoc_thy thy'))) asm)))
1.440 + | None => Notappl (rls^" not applicable") end
1.441 + handle _ => Notappl ("syntax error in "^(subs2str subs)) end
1.442 +
1.443 + | applicable_in (p,p_) pt (m as Rewrite_Set rls) =
1.444 + if p_ mem [Pbl,Met]
1.445 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.446 + else
1.447 + let
1.448 + val pp = par_pblobj pt p;
1.449 + val thy' = (get_obj g_domID pt pp):theory';
1.450 + val {asm_rls=asm_rls,...} = get_met (get_obj g_metID pt pp);
1.451 + val put_asm = rls mem asm_rls;
1.452 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
1.453 + Frm => (get_obj g_form pt p, p)
1.454 + | Res => (get_obj g_result pt p, lev_on p)
1.455 + | _ => raise error ("applicable_in: call by "^
1.456 + (pos'2str (p,p_)));
1.457 + in case rewrite_set thy' put_asm rls f of
1.458 + Some (f',asm) =>
1.459 + ((*writeln("#.# applicable_in Rewrite_Set,2f'= "^f');*)
1.460 + Appl (Rewrite_Set' (thy',put_asm,assoc_rls rls,
1.461 + (term_of o the o (parse (assoc_thy thy'))) f,
1.462 + ((term_of o the o (parse (assoc_thy thy'))) f',
1.463 + map(term_of o the o(parse (assoc_thy thy')))asm)))
1.464 + )
1.465 + | None => Notappl (rls^" not applicable") end
1.466 +
1.467 + | applicable_in (p,p_) pt (m as Detail) =
1.468 + if p_ mem [Pbl,Met]
1.469 + then Notappl ("Detail not YET impl. for pos "^(pos'2str (p,p_)))
1.470 + else
1.471 + (case get_obj g_mstep pt p of
1.472 + Rewrite_Set rls =>
1.473 + let
1.474 + val thy' = get_obj g_domID pt (par_pblobj pt p)
1.475 + val f = (term_of o the o (parse (assoc_thy thy')))
1.476 + (get_obj g_form pt p);
1.477 + in Appl (Detail_Set'(thy', assoc_rls rls, f)) end
1.478 + | Rewrite_Set_Inst(*append*) (subs,rls) =>
1.479 + let
1.480 + val thy' = get_obj g_domID pt (par_pblobj pt p)
1.481 + val f = (term_of o the o (parse (assoc_thy thy')))
1.482 + (get_obj g_form pt p);
1.483 + val subst = subs2subst (assoc_thy thy') subs;
1.484 + in Appl (Detail_Set_Inst'(thy', subst, assoc_rls rls, f)) end
1.485 + | _ => Notappl ("Detail not YET impl. for "^
1.486 + (mstep2str (get_obj g_mstep pt p))))
1.487 +
1.488 + | applicable_in (p,p_) pt (m as End_Detail) =
1.489 + if p_ mem [Pbl,Met,Frm]
1.490 + then Notappl ("applicable_in: End_Detail not for pos "^(pos'2str (p,p_)))
1.491 + else (case get_obj g_mstep pt (lev_up p) of
1.492 + Detail_Set _ =>
1.493 + Appl (End_Detail' ((term_of o the o
1.494 + (parse (assoc_thy "Isac.thy")))
1.495 + (get_obj g_result pt p)))
1.496 + | _ => Notappl "applicable_in: End_Detail not in a Detail-branch")
1.497 +
1.498 + | applicable_in p pt (End_Ruleset) =
1.499 + raise error ("applicable_in: not impl. for "^
1.500 + (mstep2str End_Ruleset))
1.501 +
1.502 +(* val Calculate op_ = m;
1.503 + *)
1.504 +| applicable_in (p,p_) pt (m as Calculate op_) =
1.505 + if p_ mem [Pbl,Met]
1.506 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.507 + else
1.508 + let
1.509 + val (msg,thy',isa_fn) = from_pblobj_or_detail_calc op_ p pt;
1.510 + val f = case p_ of
1.511 + Frm => get_obj g_form pt p
1.512 + | Res => get_obj g_result pt p
1.513 + in if msg = "OK" then
1.514 + case calculate thy' isa_fn f of
1.515 + Some (f',thm') =>
1.516 + Appl (Calculate' (thy',op_,
1.517 + (term_of o the o (parse (assoc_thy thy'))) f,
1.518 + ((term_of o the o (parse (assoc_thy thy')))f',
1.519 + thm')))
1.520 + | None => Notappl ("'calculate "^op_^"' not applicable")
1.521 + else Notappl msg
1.522 + end
1.523 +
1.524 + | applicable_in (p,p_) pt (m as Substitute subs) =
1.525 + if p_ mem [Pbl,Met]
1.526 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.527 + else
1.528 + let
1.529 + val pp = par_pblobj pt p;
1.530 + val thy' = (get_obj g_domID pt pp):theory';
1.531 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
1.532 + Frm => (get_obj g_form pt p, p)
1.533 + | Res => (get_obj g_result pt p, lev_on p)
1.534 + | _ => raise error ("applicable_in: call by "^
1.535 + (pos'2str (p,p_)));
1.536 + val ft = (term_of o the o (parse (assoc_thy thy'))) f;
1.537 + in
1.538 + let val subst = subs2subst (assoc_thy thy') subs;
1.539 + val subs' = subst2subs' subst;
1.540 + val f' = subst_atomic subst ft;
1.541 + in if ft = f'
1.542 + then Notappl ((subs2str subs)^" not applicable")
1.543 + else Appl (Substitute' (subst, ft, f')) end
1.544 + handle _ => Notappl ("syntax error in "^(subs2str subs)) end
1.545 +
1.546 + | applicable_in p pt (Apply_Assumption cts') =
1.547 + (raise error ("applicable_in: not impl. for "^
1.548 + (mstep2str (Apply_Assumption cts'))))
1.549 +
1.550 + (*'logical' applicability wrt. script in locate: Inconsistent?*)
1.551 + | applicable_in (p,p_) pt (m as Take ct') =
1.552 + if p_ mem [Pbl,Met]
1.553 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.554 + else
1.555 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
1.556 + in (case parse (assoc_thy thy') ct' of
1.557 + Some ct => Appl (Take' (term_of ct))
1.558 + | None => Notappl ("syntax error in "^ct'))
1.559 + end
1.560 +
1.561 + | applicable_in p pt (Take_Inst ct') =
1.562 + raise error ("applicable_in: not impl. for "^
1.563 + (mstep2str (Take_Inst ct')))
1.564 +
1.565 + | applicable_in p pt (Group (con, ints)) =
1.566 + raise error ("applicable_in: not impl. for "^
1.567 + (mstep2str (Group (con, ints))))
1.568 +(*1.8.01---
1.569 + | applicable_in (p,p_) pt (m as Subproblem (spec, cts')) =
1.570 + if p_ mem [Pbl,Met]
1.571 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.572 + else
1.573 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
1.574 + in ((Appl (Subproblem'(spec,
1.575 + map(term_of o the o(parse (assoc_thy thy')))cts')))
1.576 + handle _ => Notappl ("syntax error in "^(strs2str cts')))
1.577 + end
1.578 +----*)
1.579 + | applicable_in (p,p_) pt (m as Subproblem (domID, pblID)) =
1.580 + if p_ mem [Pbl,Met]
1.581 + then Notappl ((mstep2str m)^" not for pos "^(pos'2str (p,p_)))
1.582 + else
1.583 + Appl (Subproblem' ((domID, pblID, e_metID), [], subpbl domID pblID))
1.584 +
1.585 + | applicable_in p pt (End_Subproblem) =
1.586 + raise error ("applicable_in: not impl. for "^
1.587 + (mstep2str (End_Subproblem)))
1.588 +
1.589 + | applicable_in p pt (CAScmd ct') =
1.590 + raise error ("applicable_in: not impl. for "^
1.591 + (mstep2str (CAScmd ct')))
1.592 +
1.593 + | applicable_in p pt (Split_And) =
1.594 + raise error ("applicable_in: not impl. for "^
1.595 + (mstep2str (Split_And)))
1.596 + | applicable_in p pt (Conclude_And) =
1.597 + raise error ("applicable_in: not impl. for "^
1.598 + (mstep2str (Conclude_And)))
1.599 + | applicable_in p pt (Split_Or) =
1.600 + raise error ("applicable_in: not impl. for "^
1.601 + (mstep2str (Split_Or)))
1.602 + | applicable_in p pt (Conclude_Or) =
1.603 + raise error ("applicable_in: not impl. for "^
1.604 + (mstep2str (Conclude_Or)))
1.605 +
1.606 + | applicable_in (p,p_) pt (Begin_Trans) =
1.607 + let
1.608 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
1.609 + (*_____ implizit Take in gen*)
1.610 + Frm => (get_obj g_form pt p, (lev_on o lev_dn) p)
1.611 + | Res => (get_obj g_result pt p, (lev_on o lev_dn o lev_on) p)
1.612 + | _ => raise error ("applicable_in: call by "^
1.613 + (pos'2str (p,p_)));
1.614 + val thy' = get_obj g_domID pt (par_pblobj pt p);
1.615 + in (Appl (Begin_Trans' ((term_of o the o (parse (assoc_thy thy'))) f)))
1.616 + handle _ => raise error ("applicable_in: Begin_Trans finds \
1.617 + \syntaxerror in '"^f^"'") end
1.618 + (*TODO: check parent branches*)
1.619 + | applicable_in (p,p_) pt (End_Trans) =
1.620 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
1.621 + in if p_ = Res
1.622 + then Appl (End_Trans' ((term_of o the o (parse (assoc_thy thy')))
1.623 + (get_obj g_result pt p)))
1.624 + else Notappl "'End_Trans' is not applicable at \
1.625 + \the beginning of a transitive sequence"
1.626 + (*TODO: check parent branches*)
1.627 + end
1.628 +
1.629 + | applicable_in p pt (Begin_Sequ) =
1.630 + raise error ("applicable_in: not impl. for "^
1.631 + (mstep2str (Begin_Sequ)))
1.632 + | applicable_in p pt (End_Sequ) =
1.633 + raise error ("applicable_in: not impl. for "^
1.634 + (mstep2str (End_Sequ)))
1.635 + | applicable_in p pt (Split_Intersect) =
1.636 + raise error ("applicable_in: not impl. for "^
1.637 + (mstep2str (Split_Intersect)))
1.638 + | applicable_in p pt (End_Intersect) =
1.639 + raise error ("applicable_in: not impl. for "^
1.640 + (mstep2str (End_Intersect)))
1.641 +(* val Check_elementwise pred = m; val (p,p_) = p;
1.642 +
1.643 + val Check_elementwise pred = m;
1.644 +
1.645 + val Appl (Check_elementwise'(t1,"Assumptions",t2)) = it;
1.646 + val (vvv,ppp) = vp;
1.647 + *)
1.648 + | applicable_in (p,p_) pt (Check_elementwise pred) =
1.649 + let
1.650 + val pp = par_pblobj pt p;
1.651 + val thy' = (get_obj g_domID pt pp):theory';
1.652 + val thy = assoc_thy thy'
1.653 + val metID = (get_obj g_metID pt pp)
1.654 + val {erls,...} = get_met metID
1.655 + (*val _=writeln("### applicable_in Check_elementwise: erls= "^erls)
1.656 + val _=writeln("### applicable_in Check_elementwise: pred= "^pred)*)
1.657 + (*val erl = the (assoc'(!ruleset',erls))*)
1.658 + val f = case p_ of
1.659 + Frm => get_obj g_form pt p
1.660 + | Res => get_obj g_result pt p;
1.661 + val ft = (term_of o the o (parse thy)) f;
1.662 + (*val _= writeln("### applicable_in Check_elementwise: f= "^f);*)
1.663 + val vp = mk_set thy pt p ft ((term_of o the o (parse thy)) pred);
1.664 + (*val (v,p)=vp;val _=writeln("### applicable_in Check_elementwise: vp= "^
1.665 + pair2str(term2str v,term2str p))*)
1.666 + in case ft of
1.667 + Const ("List.list.Cons",_) $ _ $ _ =>
1.668 + Appl (Check_elementwise'
1.669 + (ft, pred,
1.670 + ((*writeln("### applicable_in Check_elementwise: --> "^
1.671 + (term2str (check_elementwise thy erl ft vp)));*)
1.672 + check_elementwise thy erls ft vp)))
1.673 + | Const ("List.list.Nil",_) => Notappl "not applicable to empty list"
1.674 + | _ => Notappl ("not applicable: "^f^" should be constants")
1.675 + end
1.676 +
1.677 + | applicable_in (p,p_) pt Or_to_List =
1.678 + let
1.679 + val pp = par_pblobj pt p;
1.680 + val thy' = (get_obj g_domID pt pp):theory';
1.681 + val thy = assoc_thy thy';
1.682 + val f = case p_ of
1.683 + Frm => get_obj g_form pt p
1.684 + | Res => get_obj g_result pt p;
1.685 + val ft = (term_of o the o (parse thy)) f;
1.686 + in (let val ls = or2list ft
1.687 + in Appl (Or_to_List' (ft, ls)) end)
1.688 + handle _ => Notappl ("'Or_to_List' not applicable to "^f)
1.689 + end
1.690 +
1.691 + | applicable_in p pt (Collect_Trues) =
1.692 + raise error ("applicable_in: not impl. for "^
1.693 + (mstep2str (Collect_Trues)))
1.694 +
1.695 + | applicable_in p pt (Empty_Mstep) =
1.696 + Notappl "Empty_Mstep is not applicable"
1.697 +
1.698 + | applicable_in (p,p_) pt (Mstep id) =
1.699 + let
1.700 + val pp = par_pblobj pt p;
1.701 + val thy' = (get_obj g_domID pt pp):theory';
1.702 + val thy = assoc_thy thy';
1.703 + val f = case p_ of
1.704 + Frm => get_obj g_form pt p
1.705 + | Res => get_obj g_result pt p;
1.706 + in case id of
1.707 + "subproblem_equation_dummy" =>
1.708 + if is_expliceq ((term_of o the o (parse thy)) f)
1.709 + then Appl (Mstep' (thy,f,id,"subproblem_equation_dummy ("^f^")"))
1.710 + else Notappl "applicable only to equations made explicit"
1.711 + | "solve_equation_dummy" =>
1.712 + let (*val _= writeln("### applicable_in: solve_equation_dummy: f= "
1.713 + ^f);*)
1.714 + val (id',f') = split_dummy f;
1.715 + (*val _= writeln("### applicable_in: f'= "^f');*)
1.716 + (*val _= (term_of o the o (parse thy)) f';*)
1.717 + (*val _= writeln"### applicable_in: solve_equation_dummy";*)
1.718 + in if id' <> "subproblem_equation_dummy" then Notappl "no subproblem"
1.719 + else if is_expliceq ((term_of o the o (parse thy)) f')
1.720 + then Appl (Mstep' (thy,f, id, "[" ^ f' ^ "]"))
1.721 + else error ("applicable_in: f= " ^ f') end
1.722 + | _ => Appl (Mstep' (thy,f, id, f)) end
1.723 +
1.724 +
1.725 +
1.726 + | applicable_in p pt End_Proof' = Appl End_Proof''
1.727 +
1.728 + | applicable_in _ _ m =
1.729 + raise error ("applicable_in called for "^(mstep2str m));
1.730 +
1.731 +fun mstep2mstep' pt p m =
1.732 + case applicable_in p pt m of
1.733 + Appl (m') => m'
1.734 + | Notappl _ => raise error ("mstep2mstp': fails with"^
1.735 + (mstep2str m));
1.736 +
2.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2 +++ b/src/sml/ME/generate.sml Thu Apr 17 18:01:03 2003 +0200
2.3 @@ -0,0 +1,148 @@
2.4 +(* use"ME/generate.sml";
2.5 + use"generate.sml";
2.6 +*)
2.7 +
2.8 +
2.9 +
2.10 +
2.11 +
2.12 +
2.13 +(*generate 1 ppobj in ptree*)
2.14 +fun generate1 thy (Take' t) l (p,p_) pt = (* val (Take' t) = m; *)
2.15 + let
2.16 + val ct = Sign.string_of_term (sign_of thy) t;
2.17 + (*TODO: remove with rewrite term*)
2.18 + val p = let val (ps,p') = split_last p(*no connex to prev.ppobj*)
2.19 + in if p'=0 then ps@[1] else p end;
2.20 + val (pt,c) = cappend_form pt p l ct;
2.21 + in ((p,Frm):pos', c,
2.22 + Form' (FormKF (~1,EdUndef,(length p), Nundef, ct)), pt) end
2.23 +
2.24 +(* val (l, (p,p_)) = (RrlsState is, p);
2.25 + *)
2.26 + | generate1 thy (Begin_Trans' t) l (p,p_) pt =
2.27 + let val p = (lev_on o lev_dn) p;
2.28 + val ct = Sign.string_of_term (sign_of thy) t;
2.29 + (*TODO: remove with rewrite term*)
2.30 + val (pt,c) = cappend_form pt p l ct;
2.31 + in ((p,Frm), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ct)), pt) end
2.32 +
2.33 + | generate1 thy (End_Trans' t) l (p,p_) pt =
2.34 + let
2.35 + val ct = Sign.string_of_term (sign_of thy) t;
2.36 + (*TODO: remove with rewrite term*)
2.37 + val (pt,c) = append_result pt p l ct Complete;
2.38 + val p' = lev_up p;
2.39 + in ((p',Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ct)), pt) end
2.40 +
2.41 + | generate1 thy (End_Detail' t) l (p,p_) pt =
2.42 + generate1 thy (End_Trans' t) l (p,p_) pt
2.43 +
2.44 + | generate1 thy (Rewrite_Inst' (_,_,_,_,subs',thm',f,(f',asm))) l (p,p_) pt =
2.45 + let
2.46 + val t2str = Sign.string_of_term (sign_of thy);
2.47 + val ff = t2str f;
2.48 + val ff' = t2str f';
2.49 + val subs = subst2subs subs';
2.50 + (*TODO: remove with rewrite term*)
2.51 + val (pt,c) = cappend_atomic pt p l ff
2.52 + (Rewrite_Inst (subs,thm')) ff' Complete;
2.53 + val asm' = map (Sign.string_of_term (sign_of thy)) asm;
2.54 + val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');
2.55 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt) end
2.56 +
2.57 + | generate1 thy (Rewrite' (thy',ord',rls',pa,thm',f,(f',asm))) l (p,p_) pt =
2.58 + let
2.59 + val ff = Sign.string_of_term (sign_of thy) f;
2.60 + val ff' = Sign.string_of_term (sign_of thy) f';
2.61 + (*TODO: remove with rewrite on type term, not cterm'*)
2.62 + val (pt,c) = cappend_atomic pt p l ff
2.63 + (Rewrite thm') ff' Complete;
2.64 + val asm' = map (Sign.string_of_term (sign_of thy)) asm;
2.65 + val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');
2.66 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt)end
2.67 +
2.68 + | generate1 thy (Rewrite_Asm' all) l p pt = generate1 thy (Rewrite' all) l p pt
2.69 +
2.70 + | generate1 thy (Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm))) l (p,p_) pt =
2.71 + let
2.72 + val t2str = Sign.string_of_term (sign_of thy);
2.73 + val ff = t2str f;
2.74 + val ff' = t2str f';
2.75 + val subs = subst2subs subs';
2.76 + (*TODO: remove with rewrite term*)
2.77 + val (pt,c) = cappend_atomic pt p l ff
2.78 + (Rewrite_Set_Inst (subs,id_rls rls')) ff' Complete;
2.79 + val asm' = map (Sign.string_of_term (sign_of thy)) asm;
2.80 + val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');
2.81 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt) end
2.82 +
2.83 + | generate1 thy (Rewrite_Set' (_,_,rls',f,(f',asm))) l (p,p_) pt =
2.84 + let
2.85 + val t2str = Sign.string_of_term (sign_of thy);
2.86 + val ff = t2str f;
2.87 + val ff' = t2str f';
2.88 + (*TODO: remove with rewrite term*)
2.89 + val (pt,c) = cappend_atomic pt p l ff
2.90 + (Rewrite_Set (id_rls rls')) ff' Complete;
2.91 + val asm' = map (Sign.string_of_term (sign_of thy)) asm;
2.92 + val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');
2.93 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt) end
2.94 +
2.95 + | generate1 thy (Check_Postcond' (pI,scval)) l (p,p_) pt =
2.96 + let val ff' = Sign.string_of_term (sign_of thy) scval
2.97 + (*val (l',_) = get_obj g_loc pt p..don't overwrite with l from subpbl*)
2.98 + val (pt,c) = append_result pt p l ff' Complete
2.99 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')),
2.100 + pt) end
2.101 +
2.102 + | generate1 thy (Calculate' (thy',op_,f,(f',thm'))) l (p,p_) pt =
2.103 + let
2.104 + val ff = Sign.string_of_term (sign_of thy) f;
2.105 + val ff' = Sign.string_of_term (sign_of thy) f';
2.106 + (*TODO: remove with rewrite term*)
2.107 + val (pt,c) = cappend_atomic pt p l ff
2.108 + (Calculate op_) ff' Complete;
2.109 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt)end
2.110 +
2.111 + | generate1 thy (Check_elementwise' (consts,pred,f')) l (p,p_) pt =
2.112 + let
2.113 + val ff = Sign.string_of_term (sign_of thy) consts;
2.114 + val ff' = Sign.string_of_term (sign_of thy) f';
2.115 + (*TODO: remove with rewrite term*)
2.116 + val (pt,c) = cappend_atomic pt p l ff
2.117 + (Check_elementwise pred) ff' Complete;
2.118 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt)end
2.119 +
2.120 + | generate1 thy (Or_to_List' (ors,list)) l (p,p_) pt =
2.121 + let
2.122 + val ff = Sign.string_of_term (sign_of thy) ors;
2.123 + val ff' = Sign.string_of_term (sign_of thy) list;
2.124 + (*TODO: remove with rewrite term*)
2.125 + val (pt,c) = cappend_atomic pt p l ff
2.126 + Or_to_List ff' Complete;
2.127 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, ff')), pt)end
2.128 +
2.129 + | generate1 thy (Mstep' (_,f,id,f')) l (p,p_) pt =
2.130 + let val (pt,c) = cappend_atomic pt p l f (Mstep id) f' Complete;
2.131 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f')), pt)end
2.132 +
2.133 + | generate1 thy (Subproblem' ((domID, pblID, metID), oris, f)) l (p,p_) pt =
2.134 + let val (pt,c) = cappend_problem pt p l (oris, (domID, pblID, metID));
2.135 + val pbl = init_pbl ((#ppc o get_pbt) pblID);
2.136 + val pt = update_pblppc pt p pbl;
2.137 + (*val _= writeln("### generate1: is([3],Frm)= "^
2.138 + (istate2str (get_istate pt ([3],Frm))));*)
2.139 + val f = Sign.string_of_term (sign_of thy) f;
2.140 + in ((p,Pbl), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f)), pt) end
2.141 +
2.142 + | generate1 thy m' _ _ _ =
2.143 + raise error ("generate1: not impl.for "^(mstep'2str m'))
2.144 +;
2.145 +
2.146 +
2.147 +fun generate_hard thy m' (p,p_) pt =
2.148 + let
2.149 + val p = case p_ of Frm => p | Res => lev_on p
2.150 + | _ => raise error ("generate_hard: call by "^(pos'2str (p,p_)));
2.151 + in generate1 thy m' e_istate (p,p_) pt end;
3.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/src/sml/ME/modspec.sml Thu Apr 17 18:01:03 2003 +0200
3.3 @@ -0,0 +1,1357 @@
3.4 +(* W.N.22.11.99
3.5 +
3.6 + use"ME/modspec.sml";
3.7 + use"modspec.sml";
3.8 +
3.9 +(* 25.1.: alle fun auskommentiert, die auch in nnewcode.sml sind
3.10 + ... *)
3.11 +*)
3.12 +
3.13 +(*---------------------------------------------(1) nach ptyps.sml 23.3.02*)
3.14 +
3.15 +(* datatypes *)
3.16 +
3.17 +datatype pblmet = (*%^%*)
3.18 + Problem of pblID (*%^%*)
3.19 + | Method of metID; (*%^%*)
3.20 +fun pblmet2str (Problem pblID) = "Problem "^(strs2str pblID)(*%^%*)
3.21 + | pblmet2str (Method metID) = "Method "^(metID2str metID);(*%^%*)
3.22 + (*%^%*) (*26.6. moved to sequent.sml: fun ~~~~~~~~~; was here below*)
3.23 +
3.24 +
3.25 +(* copy from 03.60.usecases.sml 15.11.99 *)
3.26 +datatype user_cmd =
3.27 + Accept | NotAccept | Example
3.28 +| YourTurn | MyTurn (* internal use only 7.6.02 java-sml*)
3.29 +| Rules
3.30 +| DontKnow (*| HowComes | WhatFor 7.6.02 java-sml*)
3.31 +| Undo (*| Back | Forward 7.6.02 java-sml*)
3.32 +| EndProof | EndSession
3.33 +| ActivePlus | ActiveMinus | SpeedPlus | SpeedMinus
3.34 + (*Stepwidth...7.6.02 java-sml*)
3.35 +| Auto | NotAuto | Details;
3.36 +(* for test-print-outs *)
3.37 +fun user_cmd2str Accept ="Accept"
3.38 + | user_cmd2str NotAccept ="NotAccept"
3.39 + | user_cmd2str Example ="Example"
3.40 + | user_cmd2str MyTurn ="MyTurn"
3.41 + | user_cmd2str YourTurn ="YourTurn"
3.42 + | user_cmd2str Rules ="Rules"
3.43 +(*| user_cmd2str HowComes ="HowComes"*)
3.44 + | user_cmd2str DontKnow ="DontKnow"
3.45 +(*| user_cmd2str WhatFor ="WhatFor"
3.46 + | user_cmd2str Back ="Back"*)
3.47 + | user_cmd2str Undo ="Undo"
3.48 +(*| user_cmd2str Forward ="Forward"*)
3.49 + | user_cmd2str EndProof ="EndProof"
3.50 + | user_cmd2str EndSession ="EndSession"
3.51 + | user_cmd2str ActivePlus = "ActivePlus"
3.52 + | user_cmd2str ActiveMinus = "ActiveMinus"
3.53 + | user_cmd2str SpeedPlus = "SpeedPlus"
3.54 + | user_cmd2str SpeedMinus = "SpeedMinus"
3.55 + | user_cmd2str Auto = "Auto"
3.56 + | user_cmd2str NotAuto = "NotAuto"
3.57 + | user_cmd2str Details = "Details";
3.58 +
3.59 +
3.60 +
3.61 +(*3.5.00: TODO: foppFK eliminated in interface FE-KE !!!*)
3.62 +datatype foppFK = (* in DG cases div 2 *)
3.63 + EmptyFoppFK (*DG internal*)
3.64 +| FormFK of cterm'
3.65 +| PpcFK of cterm' ppc;
3.66 +fun foppFK2str (FormFK ct') ="FormFK "^ct'
3.67 + | foppFK2str (PpcFK ppc) ="PpcFK "^(ppc2str ppc)
3.68 + | foppFK2str EmptyFoppFK ="EmptyFoppFK";
3.69 +
3.70 +
3.71 +datatype nest = Open | Closed | Nundef;
3.72 +fun nest2str Open = "Open"
3.73 + | nest2str Closed = "Closed"
3.74 + | nest2str Nundef = "Nundef";
3.75 +
3.76 +type indent = int;
3.77 +datatype edit = EdUndef | Write | Protect;
3.78 + (* bridge --> kernel *)
3.79 + (* bridge <-> kernel *)
3.80 +(* needed in dialog.sml *) (* bridge <-- kernel *)
3.81 +fun edit2str EdUndef = "EdUndef"
3.82 + | edit2str Write = "Write"
3.83 + | edit2str Protect = "Protect";
3.84 +
3.85 +
3.86 +datatype inout =
3.87 + New_User | End_User (*<->*)
3.88 +| New_Proof | End_Proof (*<->*)
3.89 +| Command of user_cmd (*-->*)
3.90 +| Request of string | Message of string (*<--*)
3.91 +| Error_ of string | System of string (*<--*)
3.92 +| FoPpcFK of foppFK (*-->*)
3.93 +| FormKF of cellID * edit * indent * nest * cterm' (*<--*)
3.94 +| PpcKF of cellID * edit * indent * nest * (pblmet * item ppc) (*<--*)
3.95 +| RuleFK of mstep (*-->*)
3.96 +| RuleKF of edit * mstep (*<--*)
3.97 +| RefinedKF of match list (*<--*)
3.98 +| Select of mstep list (*<--*)
3.99 +| RefineKF of match list (*<--*)
3.100 +| Speed of int (*<--*)
3.101 +| Active of int (*<--*)
3.102 +| Domain of domID; (*<--*)
3.103 +
3.104 +fun inout2str End_Proof = "End_Proof"
3.105 + | inout2str (Command user_cmd) = "Command "^(user_cmd2str user_cmd)
3.106 + | inout2str (Request s) = "Request "^s
3.107 + | inout2str (Message s) = "Message "^s
3.108 + | inout2str (Error_ s) = "Error_ "^s
3.109 + | inout2str (System s) = "System "^s
3.110 + | inout2str (FoPpcFK foppFK) = "FoPpcFK "^(foppFK2str foppFK)
3.111 + | inout2str (FormKF (cellID, edit, indent, nest, ct')) =
3.112 + "FormKF ("^(string_of_int cellID)^","
3.113 + ^(edit2str edit)^","^(string_of_int indent)^","
3.114 + ^(nest2str nest)^",("
3.115 + ^ct' ^")"
3.116 + | inout2str (PpcKF (cellID, edit, indent, nest, (pm,itemppc))) =
3.117 + "PpcKF ("^(string_of_int cellID)^","
3.118 + ^(edit2str edit)^","^(string_of_int indent)^","
3.119 + ^(nest2str nest)^",("
3.120 + ^(pblmet2str pm)^","^(itemppc2str itemppc)^"))"
3.121 + | inout2str (RuleKF (edit,mstep)) = "RuleKF "^
3.122 + pair2str(edit2str edit,mstep2str mstep)
3.123 + | inout2str (RuleFK mstep) = "RuleFK "^(mstep2str mstep)
3.124 + | inout2str (Select msteps)=
3.125 + "Select "^((strs2str' o (map mstep2str)) msteps)
3.126 + | inout2str (RefineKF ms) = "RefineKF "^(matchs2str ms)
3.127 + | inout2str (Speed i) = "Speed "^(string_of_int i)
3.128 + | inout2str (Active i) = "Active "^(string_of_int i)
3.129 + | inout2str (Domain dI) = "Domain "^dI;
3.130 +fun inouts2str ios = (strs2str' o (map inout2str)) ios;
3.131 +
3.132 +datatype mout = (* DG<--ME *)
3.133 + Form' of inout (* packing cterm' | cterm' ppc *)
3.134 +| Problems of inout (* passes specify (and solve) *)
3.135 +| Error' of inout
3.136 +| EmptyMout;
3.137 +fun mout2str (Form' inout) ="Form' "^(inout2str inout)
3.138 + | mout2str (Error' inout) ="Error' "^(inout2str inout)
3.139 + | mout2str (EmptyMout ) ="EmptyMout";
3.140 +
3.141 +(*30.4.02 intermediate hack for ass_up*)
3.142 +fun f_mout thy (Form' (FormKF (_,_,_,_,f))) = (term_of o the o (parse thy)) f
3.143 + | f_mout thy _ = raise error "f_mout: not called with formula";
3.144 +
3.145 +
3.146 +
3.147 +
3.148 +
3.149 +(*---------------------------------------------(2) nach ptyps.sml 23.3.02*)
3.150 +
3.151 +
3.152 +(* make a term 'typeless' for comparing with another 'typeless' term;
3.153 + 'type-less' usually is illtyped *)
3.154 +fun typeless (Const(s,_)) = (Const(s,e_type))
3.155 + | typeless (Free(s,_)) = (Free(s,e_type))
3.156 + | typeless (Var(n,_)) = (Var(n,e_type))
3.157 + | typeless (Bound i) = (Bound i)
3.158 + | typeless (Abs(s,_,t)) = Abs(s,e_type, typeless t)
3.159 + | typeless (t1 $ t2) = (typeless t1) $ (typeless t2);
3.160 +(*
3.161 +> val (Some ct) = parse thy "max_relation (A=#2*a*b - a^^^#2)";
3.162 +> val (_,t1) = split_dsc_t hs (term_of ct);
3.163 +> val (Some ct) = parse thy "A=#2*a*b - a^^^#2";
3.164 +> val (_,t2) = split_dsc_t hs (term_of ct);
3.165 +> typeless t1 = typeless t2;
3.166 +val it = true : bool
3.167 +*)
3.168 +
3.169 +
3.170 +
3.171 +(* to an input (d,ts) find the according ori
3.172 + and insert the ts *)
3.173 +fun seek_oridts thy sel (d,ts) [] pval =
3.174 + ("'"^(string_of_cterm (compos thy (d,ts)))^
3.175 + "' not found (typed)", e_ori_:ori, [], pval)
3.176 + | seek_oridts thy sel (d,ts) ((id,vat,sel',d',ts')::(oris:ori list)) pval =
3.177 + if sel = sel' andalso d=d' andalso (ts inter ts') <> []
3.178 + then if sel = sel'
3.179 + then ("",(id,vat,sel,d, ts inter(*!overlap!*) ts'):ori, pval,
3.180 + ts')
3.181 + else ((string_of_cterm (compos thy(d,ts)))^
3.182 + " not for "^sel, e_ori_, [], [])
3.183 + else seek_oridts thy sel (d,ts) oris pval;
3.184 +
3.185 +fun seek_orits thy sel ts [] pval =
3.186 + ("'"^
3.187 + (strs2str (map (Sign.string_of_term (sign_of thy)) ts))^
3.188 + "' not found (typed)", e_ori_, pval, [])
3.189 + | seek_orits thy sel ts ((id,vat,sel',d,ts')::(oris:ori list)) pval =
3.190 + if sel = sel' andalso (ts inter ts') <> []
3.191 + then if sel = sel'
3.192 + then ("",(id,vat,sel,d,ts inter(*!overlap!*) ts'):ori, pval,
3.193 + ts')
3.194 + else (((strs2str' o map
3.195 + (Sign.string_of_term (sign_of thy))) ts)^
3.196 + " not for "^sel, e_ori_, [], [])
3.197 + else seek_orits thy sel ts oris pval;
3.198 +(* false
3.199 +> val ((id,vat,sel',d,ts')::(ori':ori)) = ori;
3.200 +> seek_orits thy sel ts [(id,vat,sel',d,ts')];
3.201 +uncaught exception TYPE
3.202 +> seek_orits thy sel ts [];
3.203 +uncaught exception TYPE
3.204 +*)
3.205 +
3.206 +fun seek_ppc id [] = None
3.207 + | seek_ppc id (p::(ppc:itm list)) =
3.208 + if id = #1 p then Some p else seek_ppc id ppc;
3.209 +
3.210 +
3.211 +
3.212 +(*---------------------------------------------(3) nach ptyps.sml 23.3.02*)
3.213 +
3.214 +
3.215 +datatype appl = Appl of mstep' | Notappl of string;
3.216 +
3.217 +fun ppc2list ({Given=gis,Where=whs,Find=fis,
3.218 + With=wis,Relate=res}: 'a ppc) =
3.219 + gis @ whs @ fis @ wis @ res;
3.220 +fun ppc135list ({Given=gis,Find=fis,Relate=res,...}: 'a ppc) =
3.221 + gis @ fis @ res;
3.222 +
3.223 +
3.224 +
3.225 +
3.226 +(* get the number of variants in a problem in 'original',
3.227 + assumes equal descriptions in immediate sequence *)
3.228 +fun variants_in ts =
3.229 + let fun eq(x,y) = head_of x = head_of y;
3.230 + fun cnt eq [] y n = ([n],[])
3.231 + | cnt eq (x::xs) y n = if eq(x,y) then cnt eq xs y (n+1)
3.232 + else ([n], x::xs);
3.233 + fun coll eq xs [] = xs
3.234 + | coll eq xs (y::ys) =
3.235 + let val (n,ys') = cnt eq (y::ys) y 0;
3.236 + in if ys' = [] then xs @ n else coll eq (xs @ n) ys' end;
3.237 + val vts = (distinct (coll eq [] ts))\\[1];
3.238 + in case vts of [] => 1 | [n] => n
3.239 + | _ => error "different variants in formalization" end;
3.240 +(*
3.241 +> cnt (op=) [2,2,2,4,5,5,5,5,5] 2 0;
3.242 +val it = ([3],[4,5,5,5,5,5]) : int list * int list
3.243 +> coll (op=) [] [1,2,2,2,4,5,5,5,5,5];
3.244 +val it = [1,3,1,5] : int list
3.245 +*)
3.246 +
3.247 +fun is_list_type (Type("List.list",_)) = true
3.248 + | is_list_type _ = false;
3.249 +(* fun destr (Type(str,sort)) = (str,sort);
3.250 +> val (Some ct) = parse thy "lll::real list";
3.251 +> val ty = (#T o rep_cterm) ct;
3.252 +> is_list_type ty;
3.253 +val it = true : bool
3.254 +> destr ty;
3.255 +val it = ("List.list",["RealDef.real"]) : string * typ list
3.256 +> atomty thy ((#t o rep_cterm) ct);
3.257 +*** -------------
3.258 +*** Free ( lll, real list)
3.259 +val it = () : unit
3.260 +
3.261 +> val (Some ct) = parse thy "[lll::real]";
3.262 +> val ty = (#T o rep_cterm) ct;
3.263 +> is_list_type ty;
3.264 +val it = true : bool
3.265 +> destr ty;
3.266 +val it = ("List.list",["'a"]) : string * typ list
3.267 +> atomty thy ((#t o rep_cterm) ct);
3.268 +*** -------------
3.269 +*** Const ( List.list.Cons, [real, real list] => real list)
3.270 +*** Free ( lll, real)
3.271 +*** Const ( List.list.Nil, real list)
3.272 +
3.273 +> val (Some ct) = parse thy "lll";
3.274 +> val ty = (#T o rep_cterm) ct;
3.275 +> is_list_type ty;
3.276 +val it = false : bool *)
3.277 +
3.278 +
3.279 +fun has_list_type (Free(_,T)) = is_list_type T
3.280 + | has_list_type _ = false;
3.281 +(*
3.282 +> val (Some ct) = parse thy "lll::real list";
3.283 +> has_list_type (term_of ct);
3.284 +val it = true : bool
3.285 +> val (Some ct) = parse thy "[lll::real]";
3.286 +> has_list_type (term_of ct);
3.287 +val it = false : bool *)
3.288 +
3.289 +
3.290 +
3.291 +
3.292 +(*fdcrs = descriptions in formalization
3.293 + unused 22.11.00
3.294 +fun is_already_input thy fdcrs ts t =
3.295 + let
3.296 + val tss = flat (map isalist2list ts);
3.297 +(*28.1. val (dcr,t') = split_dsc_t fdcrs t; *)
3.298 + val (dcr,[t']) = split_dts t;
3.299 + in if (typeless t') mem (map typeless tss)
3.300 + then ("term '"^(Sign.string_of_term (sign_of thy) t')^
3.301 + "' already input")
3.302 + else "" end;
3.303 +
3.304 +> val pts = appc (map (term_of o the o (parse thy))) pbl;
3.305 +> val ts = #Relate pts;
3.306 +> val t = (term_of o the o (parse thy))"(A=#2*a*b - a^^^#2)";
3.307 +> is_already_input thy ts t;
3.308 +val it = "term 'A = #2 * a * b - a ^^^ #2' already input" : string
3.309 +> val t = (term_of o the o (parse thy))"a=#2*R*sin alpha";
3.310 +> is_already_input thy ts t;
3.311 +val it = "term 'a = #2 * R * sin alpha' already input" : string
3.312 +> val t = (term_of o the o (parse thy))"a=R*sin alpha";
3.313 +> is_already_input thy ts t;
3.314 +val it = "" : string
3.315 +*)
3.316 +
3.317 +
3.318 +fun is_parsed (Syn _) = false
3.319 + | is_parsed _ = true;
3.320 +fun parse_ok its = foldl and_ (true, map is_parsed its);
3.321 +
3.322 +fun all_dsc_in itm_s =
3.323 + let
3.324 + fun d_in (Cor ((d,_),_)) = [d]
3.325 + | d_in (Syn c) = []
3.326 + | d_in (Typ c) = []
3.327 + | d_in (Inc ((d,_),_)) = [d]
3.328 + | d_in (Sup (d,_)) = [d]
3.329 + | d_in (Mis (d,_)) = [d];
3.330 + in (flat o (map d_in)) itm_s end;
3.331 +
3.332 +(* 30.1.00 ---
3.333 +fun is_Syn (Syn _) = true
3.334 + | is_Syn (Typ _) = true
3.335 + | is_Syn _ = false;
3.336 + --- *)
3.337 +fun is_error (Cor (_,ts)) = false
3.338 + | is_error (Sup (_,ts)) = false
3.339 + | is_error (Inc (_,ts)) = false
3.340 + | is_error (Mis (_,ts)) = false
3.341 + | is_error _ = true;
3.342 +
3.343 +(* 30.1.00 ---
3.344 +fun ct_in (Syn (c)) = c
3.345 + | ct_in (Typ (c)) = c
3.346 + | ct_in _ = raise error "ct_in called for Cor .. Sup";
3.347 + --- *)
3.348 +
3.349 +(*#############################################################*)
3.350 +(*#############################################################*)
3.351 +(* vvv--- aus nnewcode.sml am 30.1.00 ---vvv *)
3.352 +
3.353 +
3.354 +(* testdaten besorgen:
3.355 + use"test-coil-kernel.sml";
3.356 + val (PblObj{origin=(oris,_),meth={ppc=itms,...},...}) =
3.357 + get_obj I pt p;
3.358 + *)
3.359 +
3.360 +(* given oris, ppc,
3.361 + variant V: oris union ppc => int, id ID: oris union ppc => int
3.362 +
3.363 + ppc is_complete ==
3.364 + EX vt:V. ALL r:oris --> EX i:ppc. ID r = ID i & complete i
3.365 +
3.366 + and
3.367 + @vt = max sum(i : ppc) V i
3.368 +*)
3.369 +
3.370 +
3.371 +
3.372 +(*
3.373 +> ((vts_cnt (vts_in itms))) itms;
3.374 +
3.375 +
3.376 +
3.377 +---^^--test 10.3.
3.378 +> val vts = vts_in itms;
3.379 +val vts = [1,2,3] : int list
3.380 +> val nvts = vts_cnt vts itms;
3.381 +val nvts = [(1,6),(2,5),(3,7)] : (int * int) list
3.382 +> val mx = max2 nvts;
3.383 +val mx = (3,7) : int * int
3.384 +> val v = max_vt itms;
3.385 +val v = 3 : int
3.386 +--------------------------
3.387 +>
3.388 +*)
3.389 +
3.390 +(* get the first term in ts *)
3.391 +fun getr_ct thy ((_,_,fd,d,ts):ori) =
3.392 + (fd, (string_of_cterm o (compos thy)) (d,[hd ts]):cterm');
3.393 +
3.394 +(* get a term from ori, notyet input in itm *)
3.395 +fun geti_ct thy ((_,_,_,d,ts):ori) ((_,_,_,fd,itm_):itm) =
3.396 + (fd, (string_of_cterm o (compos thy)) (d,ts \\ (ts_in itm_)):cterm');
3.397 +(* test-maximum.sml fmy <> [], Init_Proof ...
3.398 + val (_,_,_,d,ts) = ori; val (_,_,_,fd,itm_) = hd icl;
3.399 + val d' $ ts' = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
3.400 + atomty thy d;
3.401 + atomty thy d';
3.402 + atomty thy (hd ts);
3.403 + atomty thy ts';
3.404 + cterm_of (sign_of thy) (d $ (hd ts));
3.405 + cterm_of (sign_of thy) (d' $ ts');
3.406 +
3.407 + compos thy (d,ts);
3.408 + *)
3.409 +
3.410 +
3.411 +(* in FE dsc, not dat: this is in itms ...*)
3.412 +fun is_untouched ((_,_,false,_,Inc((_,[]),_)):itm) = true
3.413 + | is_untouched _ = false;
3.414 +
3.415 +
3.416 +(* select an item in oris, notyet input in itms
3.417 + (precondition: in itms are only Cor, Sup, Inc) *)
3.418 +(*
3.419 +> val thy = assoc_thy dI;val itms = pbl;
3.420 + nxt_add thy oris pbt itms;
3.421 + *)
3.422 +fun nxt_add thy ([]:ori list) pbt itms = (*root (only) ori...fmz=[]*)
3.423 + let
3.424 + fun test_d d ((i,_,_,_,itm_):itm) = (d = (d_in itm_)) andalso i<>0;
3.425 + fun is_elem itms (f,(d,t)) =
3.426 + case find_first (test_d d) itms of
3.427 + Some _ => true | None => false;
3.428 + in case filter_out (is_elem itms) pbt of
3.429 +(* val ((f,(d,_))::itms) = filter_out (is_elem itms) pbt;
3.430 + *)
3.431 + (f,(d,_))::itms =>
3.432 + Some (f:string, (string_of_cterm o compos thy) (d,[]):cterm')
3.433 + | _ => None end
3.434 +
3.435 +(* val thy = assoc_thy dI; val pbt = mpc; val itms = met;
3.436 +
3.437 + val (thy,itms)=(assoc_thy (if dI=e_domID then dI' else dI), pbl);
3.438 + *)
3.439 + | nxt_add thy oris pbt itms =
3.440 + let
3.441 + fun testr_vt v ori = (curry (op mem) v) (#2 (ori:ori))
3.442 + andalso (#3 ori) <>"#undef";
3.443 + fun testi_vt v itm = (curry (op mem) v) (#2 (itm:itm));
3.444 + fun test_id ids r = curry (op mem) (#1 (r:ori)) ids;
3.445 +(* val itm = hd icl; val (_,_,_,d,ts) = v6;
3.446 + *)
3.447 + fun test_subset (itm:itm) ((_,_,_,d,ts):ori) =
3.448 + (d_in (#5 itm)) = d andalso (ts_in (#5 itm)) subset ts;
3.449 + fun false_and_not_Sup((i,v,false,f,Sup _):itm) = false
3.450 + | false_and_not_Sup (i,v,false,f, _) = true
3.451 + | false_and_not_Sup _ = false;
3.452 +
3.453 + val v = if itms = [] then 1 else max_vt itms;
3.454 + val vors = if v = 0 then oris else filter (testr_vt v) oris;(*oris..vat*)
3.455 + val vits = if v = 0 then itms (*because of dsc without dat*)
3.456 + else filter (testi_vt v) itms; (*itms..vat*)
3.457 + val icl = filter false_and_not_Sup vits; (* incomplete *)
3.458 + in if icl = []
3.459 + then case filter_out (test_id (map #1 vits)) vors of
3.460 + [] => None
3.461 + | miss => Some (getr_ct thy (hd miss))
3.462 + else
3.463 + case find_first (test_subset (hd icl)) vors of
3.464 +(* val Some ori = find_first (test_subset (hd icl)) vors;
3.465 + *)
3.466 + None => raise error "nxt_add: EX itm. not(dat(itm)<=dat(ori))"
3.467 + | Some ori => Some (geti_ct thy ori (hd icl))
3.468 + end;
3.469 +
3.470 +
3.471 +
3.472 +fun mk_delete thy "#Given" itm_ = Del_Given (itm_out thy itm_)
3.473 + | mk_delete thy "#Find" itm_ = Del_Find (itm_out thy itm_)
3.474 + | mk_delete thy "#Relate" itm_ = Del_Relation(itm_out thy itm_)
3.475 + | mk_delete thy str _ =
3.476 + raise error ("mk_delete: called with field '"^str^"'");
3.477 +fun mk_additem "#Given" ct = Add_Given ct
3.478 + | mk_additem "#Find" ct = Add_Find ct
3.479 + | mk_additem "#Relate"ct = Add_Relation ct
3.480 + | mk_additem str _ =
3.481 + raise error ("mk_additem: called with field '"^str^"'");
3.482 +
3.483 +
3.484 +(* called only once, if a Subproblem has been located in the script*)
3.485 +fun nxt_model_pbl (Subproblem'((_,pblID,metID),_,_)) =
3.486 + (case metID of
3.487 + (_,"no_met") => Refine_Tacitly pblID
3.488 + | _ => Model_Problem pblID)
3.489 + | nxt_model_pbl e = raise error ("nxt_model_pbl: called by last ets = ");
3.490 +(* run subp_rooteq.sml ''
3.491 + until nxt=("Subproblem",Subproblem ("SqRoot.thy",["univariate","equation"]))
3.492 +> val (_, (Subproblem'((_,pblID,metID),_,_),_,_,_,_,_)) =
3.493 + (last_elem o drop_last) ets'';
3.494 +> val mst = (last_elem o drop_last) ets'';
3.495 +> nxt_model_pbl mst;
3.496 +val it = Refine_Tacitly ["univariate","equation"] : mstep
3.497 +*)
3.498 +
3.499 +
3.500 +
3.501 +
3.502 +(* find the next mstep in specify (except nxt_model_pbl)
3.503 + 4.00.: TODO: do not return a pos !!!
3.504 + (sind from DG comes the _OLD_ writepos)*)
3.505 +(*
3.506 +> val (pbl,pbt,mpc) =(pbl',get_pbt cpI,(#ppc o get_met) cmI);
3.507 +> val (dI,pI,mI) = empty_spec;
3.508 +> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*))
3.509 + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec);
3.510 +
3.511 +at Init_Proof:
3.512 +> val met = [];val (pbt,mpc) = (get_pbt pI',(#ppc o get_met) mI');
3.513 +> val (dI,pI,mI) = empty_spec;
3.514 +> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*))
3.515 + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec);
3.516 + *)
3.517 +
3.518 +(*. determine the next step of specification;
3.519 + not done here: Refine_Tacitly (otherwise *** unknown method: (..., no_met))
3.520 +eg. in rootpbl 'no_met':
3.521 +args:
3.522 + preok predicates are _all_ ok, or problem matches completely
3.523 + oris immediately from formalization
3.524 + (dI',pI',mI') specification coming from author/parent-problem
3.525 + (pbl, item lists specified by user
3.526 + met) -"-, tacitly completed by copy_probl
3.527 + (dI,pI,mI) specification explicitly done by the user
3.528 + (pbt, mpc) problem type, guard of method
3.529 +.*)
3.530 +fun nxt_spec Pbl preok (oris:ori list) ((dI',pI',mI'):spec)
3.531 + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec) =
3.532 +(* val preok=ok; val (pbl,met)=(itms,met);
3.533 + val (pbt,mpc)=((#ppc o get_pbt) pI'', (#ppc o get_met) mID);
3.534 + val (dI,pI,mI) = (dI'',pI'',mID);
3.535 +
3.536 + val preok = ok; val pbl = itms;
3.537 + val (pbt,mpc) = ((#ppc o get_pbt) pI,(#ppc o get_met) mI'');
3.538 +
3.539 + val (preok,pbl,pbt,mpc)=(pb,pbl',(#ppc o get_pbt) cpI,(#ppc o get_met) cmI);
3.540 + *)
3.541 + ((*writeln"### nxt_spec Pbl";*)
3.542 + if dI'=e_domID andalso dI=e_domID then (Pbl, Specify_Domain dI')
3.543 + else if pI'=e_pblID andalso pI=e_pblID
3.544 + then (Pbl, Specify_Problem pI')
3.545 + else case find_first (is_error o #5) (pbl:itm list) of
3.546 + Some (_,_,_,fd,itm_) =>
3.547 + (Pbl, mk_delete
3.548 + (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_)
3.549 + | None =>
3.550 + ((*writeln"### nxt_spec is_error None";*)
3.551 + case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))
3.552 + oris pbt pbl of
3.553 +(* val Some (fd,ct') = nxt_add (assoc_thy (if dI=e_domID then dI' else dI))
3.554 + oris pbt pbl;
3.555 + *)
3.556 + Some (fd,ct') => ((*writeln"### nxt_spec nxt_add Some";*)
3.557 + (Pbl, mk_additem fd ct'))
3.558 + | None => (*pbl-items complete*)
3.559 + if not preok then (Pbl, Refine_Problem pI')
3.560 + else
3.561 + if dI = e_domID then (Pbl, Specify_Domain dI')
3.562 + else if pI = e_pblID then (Pbl, Specify_Problem pI')
3.563 + else if mI = e_metID then (Pbl, Specify_Method mI')
3.564 + else
3.565 + case find_first (is_error o #5) met of
3.566 + Some (_,_,_,fd,itm_) =>
3.567 + (Met, mk_delete (assoc_thy dI) fd itm_)
3.568 + | None =>
3.569 + (case nxt_add (assoc_thy dI) oris mpc met of
3.570 + Some (fd,ct') => (*30.8.01: pre?!?*)
3.571 + (Met, mk_additem fd ct')
3.572 + | None =>
3.573 + ((*Solv 3.4.00*)Met, Apply_Method mI))))
3.574 +(* val preok=pb; val (pbl, met) = (pbl,met');
3.575 + val (pbt,mpc)=((#ppc o get_pbt) cpI,(#ppc o get_met) cmI);
3.576 + *)
3.577 + | nxt_spec Met preok oris (dI',pI',mI') (pbl, met) (pbt,mpc) (dI,pI,mI) =
3.578 + ((*writeln"### nxt_spec Met"; *)
3.579 + case find_first (is_error o #5) met of
3.580 + Some (_,_,_,fd,itm_) =>
3.581 + (Met, mk_delete (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_)
3.582 + | None =>
3.583 + case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))oris mpc met of
3.584 + Some (fd,ct') => (Met, mk_additem fd ct')
3.585 + | None =>
3.586 + ((*writeln"### nxt_spec Met: nxt_add None";*)
3.587 + if dI = e_domID then (Met, Specify_Domain dI')
3.588 + else if pI = e_pblID then (Met, Specify_Problem pI')
3.589 + else if not preok then (Met, Specify_Method mI)
3.590 + else (Met, Apply_Method mI)));
3.591 +
3.592 +(* di_ pI_ mI_ pos_
3.593 +val itms = [(1,[1],true,"#Find",Cor(e_term,[e_term])):itm,
3.594 + (2,[2],true,"#Find",Syn("empty"))];
3.595 +*)
3.596 +
3.597 +
3.598 +(* ^^^--- aus nnewcode.sml am 30.1.00 ---^^^ *)
3.599 +(*#############################################################*)
3.600 +(*#############################################################*)
3.601 +(* vvv--- aus nnewcode.sml vor 29.1.00 ---vvv *)
3.602 +
3.603 +(*3.3.--
3.604 +fun update_itm (cl,d,ts) ((id,vt,_,sl,Cor (_,_)):itm) =
3.605 + (id,vt,cl,sl,Cor (d,ts)):itm
3.606 + | update_itm (cl,d,ts) (id,vt,_,sl,Syn (_)) =
3.607 + raise error ("update_itm "^(string_of_cterm (compos thy (d,ts)))^
3.608 + " not not for Syn (s:cterm')")
3.609 + | update_itm (cl,d,ts) (id,vt,_,sl,Typ (_)) =
3.610 + raise error ("update_itm "^(string_of_cterm (compos thy (d,ts)))^
3.611 + " not not for Typ (s:cterm')")
3.612 + | update_itm (cl,d,ts) (id,vt,_,sl,Fal (_,_)) =
3.613 + (id,vt,cl,sl,Fal (d,ts))
3.614 + | update_itm (cl,d,ts) (id,vt,_,sl,Inc (_,_)) =
3.615 + (id,vt,cl,sl,Inc (d,ts))
3.616 + | update_itm (cl,d,ts) (id,vt,_,sl,Sup (_,_)) =
3.617 + (id,vt,cl,sl,Sup (d,ts));
3.618 +*)
3.619 +
3.620 +
3.621 +
3.622 +
3.623 +fun is_field_correct sel d dscpbt =
3.624 + case assoc (dscpbt, sel) of
3.625 + None => false
3.626 + | Some ds => d mem ds;
3.627 +
3.628 +(*. update the itm_ already input, all..from ori .*)
3.629 +(* make penv w.r.t. intersections ... 22.3.02 TODO *)
3.630 +(* val (id,vt,fd,d,ts) = (i,v,f,d,ts\\ts');
3.631 + *)
3.632 +fun ori_2itm itm_ (pid, pval) all ((id,vt,fd,d,ts):ori) =
3.633 + let
3.634 + val ts' = (ts_in itm_) union ts;
3.635 + val complete = if eq_set (ts', all) then true else false;
3.636 + in case itm_ of
3.637 + (Cor _) =>
3.638 + (if fd = "#undef" then (id,vt,complete,fd,Sup(d,ts'))
3.639 + else (id,vt,complete,fd,Cor((d,ts'),(pid, pval)))):itm
3.640 + | (Syn c) => raise error ("ori_2itm wants to overwrite "^c)
3.641 + | (Typ c) => raise error ("ori_2itm wants to overwrite "^c)
3.642 + | (Inc _) => if complete
3.643 + then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval)))
3.644 + else (id,vt,false,fd, Inc ((d,ts'),(pid, pval)))
3.645 + | (Sup ((*_,_*)d,ts')) => (*4.9.01 lost env*)
3.646 + (*if fd = "#undef" then*) (id,vt,complete,fd,Sup(d,ts'))
3.647 + (*else (id,vt,complete,fd,Cor((d,ts'),e))*)
3.648 +(* 28.1.00: not completely clear ---^^^ etc.*)
3.649 +(* 4.9.01: Mis just copied---vvv *)
3.650 + | (Mis _) => if complete
3.651 + then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval)))
3.652 + else (id,vt,false,fd, Inc ((d,ts'),(pid, pval)))
3.653 + end;
3.654 +
3.655 +
3.656 +fun eq1 d (_,(d',_)) = (d = d');
3.657 +fun eq3 f d (_,_,_,f',itm_) = f = f' andalso d = (d_in itm_);
3.658 +
3.659 +
3.660 +(* 'all' ts from ori; ts is the input; (ori carries rest of info)
3.661 + 9.01: this + ori_2itm is _VERY UNCLEAR_ ? overhead ?
3.662 + pval: value for problem-environment _NOT_ checked for 'inter'*)
3.663 +(*. is_input ori itms <=>
3.664 + EX itm. (1) ori(field,dsc) = itm(field,dsc) & (2..4)
3.665 + (2) ori(ts) subset itm(ts) --- Err "already input"
3.666 + (3) ori(ts) inter itm(ts) = empty --- new: ori(ts)
3.667 + (4) -"- <> empty --- new: ori(ts) \\ inter .*)
3.668 +(* val(itms,(i,v,f,d,ts)) = (ppc,ori');
3.669 + *)
3.670 +fun is_notyet_input thy (itms:itm list) pval all ((i,v,f,d,ts):ori) pbt =
3.671 + case find_first (eq1 d) pbt of
3.672 + Some (_,(_,pid)) =>(* val Some (_,(_,pid)) = find_first (eq1 d) pbt;
3.673 + val Some (_,_,_,_,itm_)=find_first (eq3 f d) itms;
3.674 + *)
3.675 + (case find_first (eq3 f d) itms of
3.676 + Some (_,_,_,_,itm_) =>
3.677 + let
3.678 + val ts' = (ts_in itm_) inter ts;
3.679 + in if ts subset ts'
3.680 + then (((strs2str' o
3.681 + map (Sign.string_of_term (sign_of thy))) ts')^
3.682 + " already input", e_itm) (*2*)
3.683 + else ("", ori_2itm itm_ (pid, pval) all
3.684 + (i,v,f,d,ts\\ts')) (*3,4*)
3.685 + end
3.686 + | None => ("", ori_2itm (Inc ((e_term,[]),(pid,[])))
3.687 + (pid, pval) all (i,v,f,d,ts)) (*1*)
3.688 + )
3.689 + | None => ("", ori_2itm (Sup (d,ts))
3.690 + (e_term, []) all (i,v,f,d,ts));
3.691 +(*------------------------------------------------
3.692 +fun eq3 f d (_,_,_,f',itm_) = f = f' andalso d = (d_in itm_);
3.693 +fun is_notyet_input thy itms pval all ((id,vt,fd,d,ts):ori) pbt =
3.694 + case find_first (eq1 d) pbt of
3.695 + Some (_,(_,pid)) => (* val Some (_,(_,pid)) = find_first (eq1 d) pbt;
3.696 + *)
3.697 + (case seek_ppc id itms of
3.698 + Some (id',_,_,_,itm_) =>
3.699 + let
3.700 + val ts' = (ts_in itm_) inter ts;
3.701 + in if ts'= [] then ("", ori_2itm itm_ (pid, pval) all
3.702 + (id,vt,fd,d,(ts_in itm_)@ts))
3.703 + else (((strs2str' o
3.704 + map (Sign.string_of_term (sign_of thy))) ts')^
3.705 + " already input", e_itm) end
3.706 + | None =>
3.707 + if all = ts
3.708 + then ("", ori_2itm (Cor ((e_term,[]),(pid,[])))
3.709 + (pid, pval) all (id,vt,fd,d,ts))
3.710 + else ("", ori_2itm (Inc ((e_term,[]),(e_term,[])))
3.711 + (pid, pval) all (id,vt,fd,d,ts))
3.712 + )
3.713 + | None => ("", ori_2itm (Sup (e_term,[]))
3.714 + (e_term, []) all (id,vt,fd,d,ts));----*)
3.715 +
3.716 +fun test_types thy (d,ts) =
3.717 + let
3.718 + val s = !show_types; val _ = show_types:= true;
3.719 + val opt = (try (compos thy)) (d,ts);
3.720 + val msg = case opt of
3.721 + Some _ => ""
3.722 + | None => ((Sign.string_of_term (sign_of thy) d)^" "^
3.723 + ((strs2str' o map (Sign.string_of_term(sign_of thy)))ts)
3.724 + ^" is illtyped");
3.725 + val _ = show_types:= s
3.726 + in msg end;
3.727 +
3.728 +
3.729 +
3.730 +fun maxl [] = raise error "maxl of []"
3.731 + | maxl (y::ys) =
3.732 + let fun mx x [] = x
3.733 + | mx x (y::ys) = if x < (y:int) then mx y ys else mx x ys
3.734 + in mx y ys end;
3.735 +
3.736 +
3.737 +(*. is the input term t known in oris ?
3.738 + give feedback on all(?) strange input;
3.739 + return _all_ terms already input to this item (e.g. valuesFor a,b) .*)
3.740 +fun is_known thy sel ori t =
3.741 +(* val (ori,t)=(oris,term_of ct);
3.742 + *)
3.743 + let
3.744 + val ots = (distinct o flat o (map #5)) (ori:ori list);
3.745 + val oids = ((map (fst o dest_Free)) o distinct o
3.746 + flat o (map vars)) ots;
3.747 + val (d,ts,pval) = split_dts thy t;
3.748 + val ids = map (fst o dest_Free)
3.749 + ((distinct o (flat o (map vars))) ts);
3.750 + in if (ids \\ oids) <> []
3.751 + then (("identifiers "^(strs2str' (ids \\ oids))^
3.752 + " not in example"), e_ori_, [], [])
3.753 + else
3.754 + if d = e_term
3.755 + then
3.756 + if not ((map typeless ts) subset (map typeless ots))
3.757 + then (("terms '"^
3.758 + ((strs2str' o (map (Sign.string_of_term
3.759 + (sign_of thy)))) ts)^
3.760 + "' not in example (typeless)"), e_ori_, [], [])
3.761 + else (case seek_orits thy sel ts ori pval of
3.762 + ("", ori_ as (_,_,_,d,ts), all, pval) =>
3.763 + (case test_types thy (d,ts) of
3.764 + "" => ("", ori_, pval, all)
3.765 + | msg => (msg, e_ori_, [], []))
3.766 + | (msg,_,_,_) => (msg, e_ori_, [], []))
3.767 + else
3.768 + if d mem (map #4 ori)
3.769 + then seek_oridts thy sel (d,ts) ori pval
3.770 + else ((Sign.string_of_term (sign_of thy) d)^
3.771 + " not in example", e_ori_, [], [])
3.772 + end;
3.773 +
3.774 +
3.775 +(*. for return-value of appl_add .*)
3.776 +datatype additm =
3.777 + Add of itm
3.778 + | Err of string; (*error-message*)
3.779 +
3.780 +
3.781 +(*. add an item; check wrt. oris and pbt .*)
3.782 +
3.783 +(* in contrary to oris<>[] below, this part handles user-input
3.784 + extremely acceptive, i.e. accept input instead error-msg *)
3.785 +fun appl_add thy sel ([]:ori list) ppc pbt ct' =
3.786 +(* val (ppc,pbt,ct',env) = (pbl, (#ppc o get_pbt) cpI, ct, []:envv);
3.787 + !!!! 28.8.01: env tested _minimally_ !!!
3.788 + *)
3.789 + let
3.790 + val i = 1 + (if ppc=[] then 0 else maxl (map #1 ppc));
3.791 + in case parse thy ct' of (*should be done in applicable_in 4.00.TODO*)
3.792 + None => Add (i,[],false,sel,Syn ct')
3.793 +(* val (Some ct) = parse thy ct';
3.794 + *)
3.795 + | Some ct =>
3.796 + let
3.797 + val (d,ts,pval) = split_dts thy (term_of ct);
3.798 + in if d = e_term
3.799 + then Add (i,[],false,sel,Mis (dsc_unknown,hd ts(*24.3.02*)))
3.800 +
3.801 + else
3.802 + (case find_first (eq1 d) pbt of
3.803 + None => Add (i,[],true,sel,Sup ((d,ts)))
3.804 + | Some (f,(_,id)) =>
3.805 +(* val Some (f,(_,id)) = find_first (eq1 d) pbt;
3.806 + *)
3.807 + let
3.808 + fun eq2 d ((i,_,_,_,itm_):itm) =
3.809 + (d = (d_in itm_)) andalso i<>0;
3.810 + in case find_first (eq2 d) ppc of
3.811 + None => Add (i,[],true,f, Cor ((d,ts), (id, pval)))
3.812 + | Some (i',_,_,_,itm_) =>
3.813 +(* val Some (i',_,_,_,itm_) = find_first (eq2 d) ppc;
3.814 + val None = find_first (eq2 d) ppc;
3.815 + *)
3.816 + if is_list_dsc d
3.817 + then let val ts = ts union (ts_in itm_)
3.818 + in Add (if ts_in itm_ = [] then i else i',
3.819 + [],true,f,Cor ((d, ts), (id, pval)))
3.820 + end
3.821 + else Add (i',[],true,f,Cor ((d,ts),(id, pval)))
3.822 + end
3.823 + )
3.824 + end
3.825 + end
3.826 +(*. add ct to ppc .*)
3.827 +(*FIXXME: accept items as Sup, Syn here, too (like appl_add..oris=[] above)*)
3.828 +(* val (ppc,pbt) = (pbl, (#ppc o get_pbt) cpI);
3.829 +
3.830 + val (ppc,pbt) = (met, (#ppc o get_met) cmI);
3.831 +
3.832 + val (ppc,pbt) = (pbl, (#ppc o get_pbt) cpI);
3.833 + *)
3.834 + | appl_add thy sel oris ppc pbt(*only for upd_envv*) ct =
3.835 + let
3.836 + val ctopt = parse thy ct;
3.837 + in case ctopt of
3.838 + None => Err ("syntax error in "^ct)
3.839 + | Some ct =>(* val Some ct = ctopt;
3.840 + val (msg,ori',pval,all) = is_known thy sel oris (term_of ct);
3.841 + val (msg,itm) = is_notyet_input thy ppc pval all ori' pbt;
3.842 + *)
3.843 + (case is_known thy sel oris (term_of ct) of
3.844 + ("",ori'(*ts='ct'*), pval, all) =>
3.845 + (case is_notyet_input thy ppc pval all ori' pbt of
3.846 + ("",itm) => Add itm
3.847 + | (msg,_) => Err msg)
3.848 + | (msg,_,_,_) => Err msg)
3.849 + end;
3.850 +(*
3.851 +> val (msg,itm) = is_notyet_input thy ppc all ori';
3.852 +val itm = (12,[3],false,"#Relate",Cor (Const #,[#,#])) : itm
3.853 +> val itm_ = #5 itm;
3.854 +> val ts = ts_in itm_;
3.855 +> map (atomty thy) ts;
3.856 +*)
3.857 +
3.858 +(*---------------------------------------------(4) nach ptyps.sml 23.3.02*)
3.859 +
3.860 +
3.861 +(* make oris from args of SubProblem and pbt *)
3.862 +
3.863 +fun is_cpy str =
3.864 + case (rev o explode) str of
3.865 + "_"::_::"_"::_ => true
3.866 + | _ => false;
3.867 +(*> is_cpy "v_i_";
3.868 +val it = true : bool
3.869 + > is_cpy "e_";
3.870 +val it = false : bool *)
3.871 +fun is_cp (_,(_,t)) = (is_cpy o free2str) t;
3.872 +
3.873 +fun mtc thy (str, (dsc, _)) (ty $ va) =
3.874 + (cterm_of (sign_of thy) (dsc $ va);
3.875 + Some (([1], str, dsc, [va])(*:ori without leading #*)))
3.876 + handle _ => None;
3.877 +(*> val pbt = (#ppc o get_pbt) ["univariate","equation"];
3.878 +> val Const ("Script.SubProblem",_) $
3.879 + (Const ("Pair",_) $ Free (thy',_) $
3.880 + (Const ("Pair",_) $ pblID' $
3.881 + (Const ("Pair",_) $ Free (mI1',_) $ Free (mI2',_)))) $
3.882 + ags = (term_of o the o (parse thy))
3.883 + "(SubProblem (SqRoot_,[univariate,equation],\
3.884 + \ (SqRoot_,solve_linear)) [bool_ (x+#1-#2=#0), real_ x])::bool list";
3.885 +> val ags = isalist2list ags;
3.886 +> mtc thy (hd pbt) (hd ags);
3.887 +val it = Some ([1],"#Given",Const (#,#),[# $ #]) *)
3.888 +
3.889 +(*copy-named vars must be filtered out*)
3.890 +fun matc thy [] _ oris = oris (*type oris, but without leading # *)
3.891 + | matc thy ((p as (s,(d,t)))::pbt) (a::ags) oris =
3.892 + if (is_cpy o free2str) t then oris
3.893 + else let val opt = mtc thy p a;
3.894 + in case opt of
3.895 + Some ori => matc thy pbt ags (oris @ [ori])
3.896 + | None => raise error ("match "^
3.897 + (Sign.string_of_term (sign_of thy) (d$t))^
3.898 + " doesn't match "^
3.899 + (Sign.string_of_term (sign_of thy) a))
3.900 + end;
3.901 +fun matc thy [] _ oris = oris (*type oris, but without leading #1 *)
3.902 + | matc thy ((p as (s,(d,t)))::pbt) (a::ags) oris =
3.903 + if (is_cpy o free2str) t then oris
3.904 + else let val opt = mtc thy p a;
3.905 + in case opt of
3.906 + Some ori => ((*writeln("### matc: ori0= "^(ori02str ori));*)
3.907 + matc thy pbt ags (oris @ [ori]))
3.908 + | None => raise error ("match: "^
3.909 + (Sign.string_of_term (sign_of thy) (d$t))^
3.910 + " doesn't match "^
3.911 + (Sign.string_of_term (sign_of thy) a))
3.912 + end;
3.913 +(* run subp-rooteq.sml until Init_Proof before ...
3.914 +> val Nd (PblObj {origin=(oris,_),...},_) = pt;(*from test/subp-rooteq.sml*)
3.915 +> fun xxxfortest (_,a,b,c,d) = (a,b,c,d);val oris = map xxxfortest oris;
3.916 +
3.917 + other vars as in mtc ..
3.918 +> matc thy (drop_last pbt) ags [];
3.919 +val it = ([[1],"#Given",Const #,[#]),(0,[#],"#Given",Const #,[#])],2)*)
3.920 +
3.921 +
3.922 +(*copy name from an appropriate in problem-type,
3.923 + pbt and oris are 1:1 until cpy-nam at the end*)
3.924 +fun cpy_nam pbt oris (gfr,(dsc,t)) =
3.925 + let fun sel (_,_,_,[vl]) = vl;
3.926 + val cy = (implode o drop_last o drop_last o explode o free2str) t;
3.927 + val ext = (last_elem o drop_last o explode o free2str) t;
3.928 + val vars' = map (free2str o snd o snd) pbt;(*cpy-nam filtered_out*)
3.929 + val vals = map sel oris;
3.930 + val cy_ext = (free2str o the) (assoc (vars'~~vals, cy))^"_"^ext;
3.931 + in ([1], gfr, dsc, [mk_free (type_of t) cy_ext]) end;
3.932 +(*> val (gfr,(dsc,t)) = last_elem pbt;
3.933 +> cpy_nam pbt (drop_last oris) (gfr,(dsc,t));
3.934 +val it = ([1],"#Find",
3.935 + Const ("Descript.solutions","bool List.list => Tools.toreall"),
3.936 + [Free ("x_i","bool List.list")]) *)
3.937 +
3.938 +(*expects beginning of pbt:ags = 1:1, until cpy-nam in pbt*)
3.939 +fun match_ags thy pbt ags =
3.940 + let fun flattup (i,(var,bool,str,itm_)) = (i,var,bool,str,itm_);
3.941 + val pbt' = filter_out is_cp pbt;(*cpy-nam are never args of script*)
3.942 + val cy = filter is_cp pbt;
3.943 + val oris' = matc thy pbt' ags [];
3.944 + val cy' = map (cpy_nam pbt' oris') cy;
3.945 + val ors = add_id (oris' @ cy');
3.946 + in (map flattup ors):ori list end;
3.947 +(*vars as above ..
3.948 +> match_ags thy pbt ags;
3.949 +val it =
3.950 + [(1,[1],"#Given",Const ("Descript.equality","bool => Tools.una"),
3.951 + [Const # $ (# $ #) $ Free (#,#)]),
3.952 + (2,[1],"#Given",Const ("Descript.solveFor","RealDef.real => Tools.una"),
3.953 + [Free ("x","RealDef.real")]),
3.954 + (3,[1],"#Find",
3.955 + Const ("Descript.solutions","bool List.list => Tools.toreall"),
3.956 + [Free ("x_i","bool List.list")])] : ori list*)
3.957 +
3.958 +(*@@@
3.959 +> val Nd (PblObj {origin=(oris,_),...},_) = pt;(*from test/subp-rooteq.sml*)
3.960 +
3.961 +*)
3.962 +
3.963 +
3.964 +
3.965 +
3.966 +
3.967 +(* init pbl with ...,dsc,empty | [] *)
3.968 +fun init_pbl pbt =
3.969 + let
3.970 + fun pbt2itm (f,(d,t)) =
3.971 + ((0,[],false,f,Inc((d,[]),(e_term,[]))):itm);
3.972 + in map pbt2itm pbt end;
3.973 +
3.974 +fun overwrite_ppc thy itm ppc =
3.975 + let
3.976 + fun repl ppc' (_,_,_,_,itm_) [] =
3.977 + raise error ("overwrite_ppc: "^(itm_2str thy itm_)^" not found")
3.978 + | repl ppc' itm (p::ppc) =
3.979 + if (#1 itm) = (#1 (p:itm)) then ppc' @ [itm] @ ppc
3.980 + else repl (ppc' @ [p]) itm ppc
3.981 + in repl [] itm ppc end;
3.982 +
3.983 +(*10.3.00: insert the already compiled itm into ppc;
3.984 + filter_out ev. related untouched (in FE) item *)
3.985 +(* val ppc=pbl;
3.986 + *)
3.987 +fun insert_ppc thy itm ppc =
3.988 + let
3.989 + fun eq_untouched d ((0,_,_,_,itm_):itm) = (d = d_in itm_)
3.990 + | eq_untouched _ _ = false;
3.991 + val ppc' =
3.992 + (
3.993 +(*writeln("### insert_ppc: itm= "^(itm2str itm));*)
3.994 + case seek_ppc (#1 itm) ppc of
3.995 + Some _ => (*itm updated in is_notyet_input*)
3.996 + overwrite_ppc thy itm ppc
3.997 + | None => (ppc @ [itm]));
3.998 + in filter_out (eq_untouched ((d_in o #5) itm)) ppc' end;
3.999 +
3.1000 +
3.1001 +
3.1002 +(*. output the headline to a ppc .*)
3.1003 +fun header p_ pI mI =
3.1004 + case p_ of Pbl => Problem (if pI = e_pblID then [] else pI)
3.1005 + | Met => Method mI
3.1006 + | pos => raise error ("header called with "^ pos_2str pos);
3.1007 +
3.1008 +
3.1009 +
3.1010 +(* test-printouts ---
3.1011 +val _=writeln("### insert_ppc: (d,ts)= "^(string_of_cterm(compos thy(d,ts))));
3.1012 + val _=writeln("### insert_ppc: pts= "^
3.1013 +(strs2str' o map (Sign.string_of_term (sign_of thy))) pts);
3.1014 +
3.1015 +
3.1016 + val sel = "#Given"; val Add_Given' ct = m;
3.1017 + val sel = "#Find"; val Add_Find' ct = m;
3.1018 + val (_,_,f,nxt',_,pt')= specify_additem sel ct (p,Pbl(*!!!!!!!*)) c pt;
3.1019 + *)
3.1020 +fun specify_additem sel ct (p,Pbl) c pt =
3.1021 + let
3.1022 + val (PblObj{meth=met,origin=(oris,(dI',pI',mI')),
3.1023 + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
3.1024 + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
3.1025 + (*val ppt = if pI = e_pblID then get_pbt pI' else get_pbt pI;*)
3.1026 + val cpI = if pI = e_pblID then pI' else pI;
3.1027 + val cmI = if mI = e_metID then mI' else mI
3.1028 + val {ppc,where_,prls,...} = get_pbt cpI
3.1029 +(* val Add itm = appl_add thy sel oris pbl ((#ppc o get_pbt) cpI) ct;
3.1030 + *)
3.1031 + in case appl_add thy sel oris pbl ppc ct of
3.1032 + Add itm (*..union old input *) =>
3.1033 + let
3.1034 +(*val _= writeln("###specify_additem: itm= "^(itm2str itm));*)
3.1035 + val pbl' = insert_ppc thy itm pbl;
3.1036 + val pt' = update_pbl pt p pbl'
3.1037 + val (pre, pb) = check_preconds thy prls where_ pbl';
3.1038 + val (p_,nxt) =
3.1039 + nxt_spec Pbl pb oris (dI',pI',mI') (pbl',met)
3.1040 + (ppc,(#ppc o get_met) cmI) (dI,pI,mI);
3.1041 + val ppc = if p_= Pbl then pbl' else met;
3.1042 + in ((p,p_), []:cid,
3.1043 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
3.1044 + (header p_ pI cmI,
3.1045 + itms2itemppc thy ppc pre))), nxt,Safe,pt') end
3.1046 + | Err msg =>
3.1047 + let val (_, pb) = check_preconds thy prls where_ pbl
3.1048 + val (p_,nxt) =
3.1049 + nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met)
3.1050 + (ppc,(#ppc o get_met) cmI) (dI,pI,mI);
3.1051 + in ((p,p_), []:cid, Error' (Error_ msg), nxt, Safe,pt) end
3.1052 + end
3.1053 +(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt;
3.1054 + val (_,_,f,nxt',_,pt')= specify_additem sel ct (p,Met) c pt;
3.1055 + *)
3.1056 + | specify_additem sel ct (p,Met) c pt =
3.1057 + let
3.1058 + val (PblObj{meth=met,origin=(oris,(dI',pI',mI')),
3.1059 + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
3.1060 + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
3.1061 + (*val ppt = if pI = e_pblID then get_pbt pI' else get_pbt pI;*)
3.1062 + val cpI = if pI = e_pblID then pI' else pI;
3.1063 + val cmI = if mI = e_metID then mI' else mI;
3.1064 + val {ppc,pre,prls,...} = get_met cmI
3.1065 + in case appl_add thy sel oris met ppc ct of
3.1066 + Add itm (*..union old input *) =>
3.1067 + let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct;
3.1068 + *)
3.1069 + val met' = insert_ppc thy itm met;
3.1070 + val pt' = update_met pt p met';
3.1071 + (*val pt' = update_pbl pt p (env, pbl); 3.9.01*)
3.1072 + val (pre', pb) = check_preconds thy prls pre met';
3.1073 + val (p_,nxt) =
3.1074 + nxt_spec Met pb oris (dI',pI',mI') (pbl,met')
3.1075 + ((#ppc o get_pbt) cpI,ppc) (dI,pI,mI);
3.1076 + in ((p,p_), []:cid,
3.1077 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
3.1078 + (Method cmI, itms2itemppc thy met' pre'))),
3.1079 + nxt,Safe,pt') end
3.1080 + | Err msg =>
3.1081 + let val (_, pb) = check_preconds thy prls pre met;
3.1082 + val (p_,nxt) =
3.1083 + nxt_spec Met pb oris (dI',pI',mI') (pbl,met)
3.1084 + ((#ppc o get_pbt) cpI,(#ppc o get_met) cmI) (dI,pI,mI);
3.1085 + in ((p,p_), []:cid, Error' (Error_ msg), nxt, Safe,pt) end
3.1086 + end;
3.1087 +(* ori
3.1088 +val (msg,itm) = appl_add thy sel oris ppc ct;
3.1089 +val (Cor(d,ts)) = #5 itm;
3.1090 +map (atomty thy) ts;
3.1091 +
3.1092 +pre
3.1093 +*)
3.1094 +
3.1095 +(* specify (Init_Proof' (fmz,(dI',pI',mI'))) e_pos' [] EmptyPtree;
3.1096 + *)
3.1097 +fun specify (Init_Proof' (fmz,(dI',pI',mI')))(_:pos')(_:cid)(_:ptree)=
3.1098 + let (* either """"""""""""""" all empty or complete *)
3.1099 + val thy = assoc_thy dI'
3.1100 + val oris = if dI' = e_domID orelse pI' = e_pblID then ([]:ori list)
3.1101 + else prep_ori fmz thy ((#ppc o get_pbt) pI');
3.1102 + val (pt,c) = cappend_problem e_ptree [] e_istate (oris,(dI',pI',mI'));
3.1103 + val {ppc,prls,where_,...} = get_pbt pI'
3.1104 + val pbl = init_pbl ppc;
3.1105 + val pt = update_pbl pt [] pbl;
3.1106 + val (pre, pb) = check_preconds thy prls where_ pbl;
3.1107 + in case mI' of
3.1108 + (_,"no_met") =>
3.1109 + (([],Pbl), c,
3.1110 + Form' (PpcKF (0,EdUndef,(length []),Nundef,
3.1111 + (Problem [], itms2itemppc (assoc_thy dI') pbl pre))),
3.1112 + Refine_Tacitly pI', Safe,pt)
3.1113 + | _ =>
3.1114 + (([],Pbl), c,
3.1115 + Form' (PpcKF (0,EdUndef,(length []),Nundef,
3.1116 + (Problem [], itms2itemppc (assoc_thy dI') pbl pre))),
3.1117 + snd(nxt_spec Pbl pb oris (dI',pI',mI')
3.1118 + (pbl,[]) ((#ppc o get_pbt) pI',(#ppc o get_met) mI')empty_spec),
3.1119 + Safe,pt)
3.1120 + end
3.1121 +
3.1122 + | specify (Model_Problem' _) (p,_) c pt = (*called only by Subproblem*)
3.1123 + let
3.1124 + val (PblObj{origin=(oris,(dI',pI',mI')), meth=met,
3.1125 + probl=pbl,spec=(dI,_,_),...}) = get_obj I pt p
3.1126 + val thy' = if dI = e_domID then dI' else dI
3.1127 + val thy = assoc_thy thy'
3.1128 + val {ppc,prls,where_,...} = get_pbt pI'
3.1129 + val (pre, pb) = check_preconds thy prls where_ pbl;
3.1130 + val (_,nxt) = nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met)
3.1131 + (ppc,(#ppc o get_met) mI') (dI',pI',mI');
3.1132 + in ((p,Pbl), c,
3.1133 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
3.1134 + (Problem pI', itms2itemppc (assoc_thy dI') pbl pre))),
3.1135 + nxt, Safe, pt) end
3.1136 +
3.1137 +(*. called only if no_met is specified .*)
3.1138 + | specify (Refine_Tacitly' (pI,pIre)) (p,_) c pt =
3.1139 + let (* val Refine_Tacitly' (pI,pIre) = m;
3.1140 + *)
3.1141 + val (PblObj{origin=(oris,(dI',pI',mI')), meth=met, ...}) =
3.1142 + get_obj I pt p;
3.1143 + val {prls,met,ppc,thy,where_,...} = get_pbt pIre;
3.1144 + val pbl = init_pbl ppc;
3.1145 + val pt = update_pbl pt p pbl;
3.1146 + val pt = update_orispec pt p
3.1147 + (string_of_thy thy, pIre,
3.1148 + if length met = 0 then e_metID else hd met);
3.1149 + val (pre, pb) = check_preconds thy prls where_ pbl;
3.1150 + in ((p,Pbl), c,
3.1151 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
3.1152 + (Problem pIre, itms2itemppc (assoc_thy dI') pbl pre))),
3.1153 + Model_Problem pIre, Safe, pt) end
3.1154 +
3.1155 + | specify (Refine_Problem' ms) (p,_) c pt =
3.1156 + ((p,Pbl), c, Problems (RefinedKF ms), Model_Problem (refined ms), Safe, pt)
3.1157 +(* val (Specify_Problem' (pI, (ok, (itms, pre)))) = nxt; val (p,_) = p;
3.1158 + *)
3.1159 + | specify (Specify_Problem' (pI, (ok, (itms, pre)))) (p,_) c pt =
3.1160 + let val (PblObj {origin=(oris,(dI',pI',mI')), spec=(dI,_,mI),
3.1161 + meth=met, ...}) = get_obj I pt p;
3.1162 + val pt = update_pbl pt p itms;
3.1163 + val pt = update_pblID pt p pI;
3.1164 + val dI'' = assoc_thy (if dI=e_domID then dI' else dI);
3.1165 + val mI'' = if mI=e_metID then mI' else mI;
3.1166 + val (_,nxt) = nxt_spec Pbl ok oris (dI',pI',mI') (itms, met)
3.1167 + ((#ppc o get_pbt) pI,(#ppc o get_met) mI'') (dI,pI,mI);
3.1168 + in ((p,Pbl), c,
3.1169 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
3.1170 + (Problem pI, itms2itemppc dI'' itms pre))),
3.1171 + nxt, Safe, pt) end
3.1172 +(* val Specify_Method' mID = nxt; val (p,_) = p;
3.1173 + val Specify_Method' mID = m;
3.1174 + specify (Specify_Method' mID) (p,p_) c pt;
3.1175 + *)
3.1176 + | specify (Specify_Method' mID) (p,_) c pt =
3.1177 + let val (PblObj {origin=(oris,(dI',pI',mI')), probl=pbl, spec=(dI,pI,mI),
3.1178 + meth=met, ...}) = get_obj I pt p;
3.1179 + val {ppc,pre,prls,...} = get_met mID
3.1180 + val thy = assoc_thy dI
3.1181 + val oris = add_field' thy ppc oris;
3.1182 + val pt = update_oris pt p oris; (*20.3.02: repl. "#undef"*)
3.1183 + val dI'' = if dI=e_domID then dI' else dI;
3.1184 + val pI'' = if pI = e_pblID then pI' else pI;
3.1185 + val met = if met=[] then pbl else met;
3.1186 + val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris;
3.1187 + val pt = update_met pt p itms;
3.1188 + val pt = update_metID pt p mID;
3.1189 + val (_,nxt) = nxt_spec Met (*ok*)true oris (dI',pI',mI') (pbl, itms)
3.1190 + ((#ppc o get_pbt) pI'',ppc) (dI'',pI'',mID);
3.1191 + in ((p,Met), c,
3.1192 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
3.1193 + (Method mID, itms2itemppc (assoc_thy dI'') itms pre'))),
3.1194 + nxt, Safe, pt) end
3.1195 +(* val Add_Find' ct = nxt; val sel = "#Find"; val (p,p_) = p;
3.1196 + *)
3.1197 + | specify (Add_Given' ct) p c pt = specify_additem "#Given" ct p c pt
3.1198 + | specify (Add_Find' ct) p c pt = specify_additem "#Find" ct p c pt
3.1199 + | specify (Add_Relation' ct) p c pt=specify_additem"#Relate"ct p c pt
3.1200 +(* val Specify_Domain' domID = m;
3.1201 + *)
3.1202 + | specify (Specify_Domain' domID) (p,p_) c pt =
3.1203 + let
3.1204 + val thy = assoc_thy domID;
3.1205 + val (PblObj{origin=(oris,(dI',pI',mI')), meth=met,
3.1206 + probl=pbl, spec=(dI,pI,mI),...}) = get_obj I pt p;
3.1207 + val mppc = case p_ of Pbl => pbl | Met => met;
3.1208 + val cpI = if pI = e_pblID then pI' else pI;
3.1209 + val {prls=per,ppc,where_=pwh,...} = get_pbt cpI
3.1210 + val cmI = if mI = e_metID then mI' else mI;
3.1211 + val {prls=mer,ppc=mpc,pre=mwh,...} = get_met cmI
3.1212 + val (pre, pb) =
3.1213 + case p_ of
3.1214 + Pbl => (check_preconds thy per pwh pbl)
3.1215 + | Met => (check_preconds thy mer mwh met)
3.1216 + in if domID = dI
3.1217 + then let
3.1218 + val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI')
3.1219 + (pbl,met) (ppc,mpc) (dI,pI,mI);
3.1220 + in ((p,p_), c,
3.1221 + Form'(PpcKF (0,EdUndef,(length p), Nundef,
3.1222 + (header p_ pI cmI, itms2itemppc thy mppc pre))),
3.1223 + nxt,Safe,pt) end
3.1224 + else (*FIXME: check ppc wrt. (new!) domID .. 30.8.01 still !!!*)
3.1225 + let
3.1226 + val pt = update_domID pt p domID;
3.1227 + val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') (pbl,met)
3.1228 + (ppc,mpc) (domID,pI,mI);
3.1229 + in ((p,p_), c,
3.1230 + Form' (PpcKF (0, EdUndef, (length p),Nundef,
3.1231 + (header p_ pI cmI, itms2itemppc thy mppc pre))),
3.1232 + nxt, Safe,pt) end
3.1233 + end
3.1234 +(* itms2itemppc thy [](*mpc*) pre
3.1235 + *)
3.1236 + | specify m' _ _ _ =
3.1237 + raise error ("specify: not impl. for (no: mstep'2str m'");
3.1238 +
3.1239 +
3.1240 +
3.1241 +
3.1242 +(*18.12.99*)
3.1243 +fun get_spec_form (m:mstep') ((p,p_):pos') (pt:ptree) =
3.1244 +(* case appl_spec p pt m of /// 19.1.00
3.1245 + Notappl e => Error' (Error_ e)
3.1246 + | Appl =>
3.1247 +*) let val (_,_,f,_,_,_) = specify m (p,p_) [] pt
3.1248 + in f end;
3.1249 +
3.1250 +
3.1251 +
3.1252 +
3.1253 +
3.1254 +
3.1255 +(* --------------------- ME --------------------- *)
3.1256 +fun tag_form thy (formal, given) = cterm_of (sign_of thy)
3.1257 + (((head_of o term_of) given) $ (term_of formal));
3.1258 +(* val formal = (the o (parse thy)) "[R::real]";
3.1259 +> val given = (the o (parse thy)) "fixed_values (cs::real list)";
3.1260 +> tag_form thy (formal, given);
3.1261 +val it = "fixed_values [R]" : cterm
3.1262 +*)
3.1263 +fun chktyp thy (n, fs, gs) =
3.1264 + ((writeln o string_of_cterm o (nth n)) fs;
3.1265 + (writeln o string_of_cterm o (nth n)) gs;
3.1266 + tag_form thy (nth n fs, nth n gs));
3.1267 +
3.1268 +fun chktyps thy (fs, gs) = map (tag_form thy) (fs ~~ gs);
3.1269 +
3.1270 +(* #####################################################
3.1271 + find the failing item:
3.1272 +> val n = 2;
3.1273 +> val tag__form = chktyp (n,formals,givens);
3.1274 +> (type_of o term_of o (nth n)) formals;
3.1275 +> (type_of o term_of o (nth n)) givens;
3.1276 +> atomty thy ((term_of o (nth n)) formals);
3.1277 +> atomty thy ((term_of o (nth n)) givens);
3.1278 +> atomty thy (term_of tag__form);
3.1279 +> use_thy"isa-98-1-HOL-plus/knowl-base/DiffAppl";
3.1280 + ##################################################### *)
3.1281 +
3.1282 +(* #####################################################
3.1283 + testdata setup
3.1284 +val origin = ["sqrt(9+4*x)=sqrt x + sqrt(5+x)","x::rat","(+0)"];
3.1285 +val formals = map (the o (parse thy)) origin;
3.1286 +
3.1287 +val given = ["equation (lhs=rhs)",
3.1288 + "bound_variable bdv", (* TODO type *)
3.1289 + "error_bound apx"];
3.1290 +val where_ = ["e is_root_equation_in bdv",
3.1291 + "bdv is_var",
3.1292 + "apx is_const_expr"];
3.1293 +val find = ["L::rat set"];
3.1294 +val with_ = ["L = {bdv. || ((%x. lhs) bdv) - ((%x. rhs) bdv) || < apx}"];
3.1295 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
3.1296 +val givens = map (the o (parse thy)) given;
3.1297 +
3.1298 +val tag__forms = chktyps (formals, givens);
3.1299 +map ((atomty thy) o term_of) tag__forms;
3.1300 + ##################################################### *)
3.1301 +
3.1302 +
3.1303 +(* check pbltypes, announces one failure a time *)
3.1304 +fun chk_vars ctppc =
3.1305 + let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} =
3.1306 + appc flat (mappc (vars o term_of) ctppc)
3.1307 + in if (wh\\gi) <> [] then ("wh\\gi",wh\\gi)
3.1308 + else if (re\\(gi union fi)) <> []
3.1309 + then ("re\\(gi union fi)",re\\(gi union fi))
3.1310 + else ("ok",[]) end;
3.1311 +
3.1312 +(* check a new pbltype: variables (Free) unbound by given, find*)
3.1313 +fun unbound_ppc ctppc =
3.1314 + let val {Given=gi,Find=fi,Relate=re,...} =
3.1315 + appc flat (mappc (vars o term_of) ctppc)
3.1316 + in distinct (re\\(gi union fi)) end;
3.1317 +(*
3.1318 +> val org = {Given=["[R=(R::real)]"],Where=[],
3.1319 + Find=["[A::real]"],With=[],
3.1320 + Relate=["[A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"]
3.1321 + }:string ppc;
3.1322 +> val ctppc = mappc (the o (parse thy)) org;
3.1323 +> unbound_ppc ctppc;
3.1324 +val it = [("a","RealDef.real"),("b","RealDef.real")] : (string * typ) list
3.1325 +*)
3.1326 +
3.1327 +
3.1328 +(* f, a binary operator, is nested rightassociative *)
3.1329 +fun foldr1 f xs =
3.1330 + let
3.1331 + fun fld f (x::[]) = x
3.1332 + | fld f (x::x'::[]) = f (x',x)
3.1333 + | fld f (x::x'::xs) = f (fld f (x'::xs),x);
3.1334 + in ((fld f) o rev) xs end;
3.1335 +(*
3.1336 +> val (Some ct) = parse thy "[a=b,c=d,e=f]";
3.1337 +> val ces = map (cterm_of (sign_of thy)) (isalist2list (term_of ct));
3.1338 +> val conj = foldr1 HOLogic.mk_conj (isalist2list (term_of ct));
3.1339 +> cterm_of (sign_of thy) conj;
3.1340 +val it = "(a = b & c = d) & e = f" : cterm
3.1341 +*)
3.1342 +
3.1343 +(* f, a binary operator, is nested leftassociative *)
3.1344 +fun foldl1 f (x::[]) = x
3.1345 + | foldl1 f (x::x'::[]) = f (x,x')
3.1346 + | foldl1 f (x::x'::xs) = f (x,foldl1 f (x'::xs));
3.1347 +(*
3.1348 +> val (Some ct) = parse thy "[a=b,c=d,e=f,g=h]";
3.1349 +> val ces = map (cterm_of (sign_of thy)) (isalist2list (term_of ct));
3.1350 +> val conj = foldl1 HOLogic.mk_conj (isalist2list (term_of ct));
3.1351 +> cterm_of (sign_of thy) conj;
3.1352 +val it = "a = b & c = d & e = f & g = h" : cterm
3.1353 +*)
3.1354 +
3.1355 +
3.1356 +
3.1357 +(*
3.1358 + use"ME/modspec.sml";
3.1359 + use"modspec.sml";
3.1360 + *)
3.1361 \ No newline at end of file
4.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2 +++ b/src/sml/ME/mstools.sml Thu Apr 17 18:01:03 2003 +0200
4.3 @@ -0,0 +1,637 @@
4.4 +(* tools for model-specify and ptyps
4.5 + use"ME/mstools.sml";
4.6 + use"mstools.sml";
4.7 + *)
4.8 +
4.9 +
4.10 +
4.11 +(*27.8.01: problem-environment*)
4.12 +type penv = (term (*err_*)
4.13 + * (term list) (*[#0, epsilon]*)
4.14 + ) list;
4.15 +fun pen2str thy (t, ts) =
4.16 + pair2str(Sign.string_of_term (sign_of thy) t,
4.17 + (strs2str' o map (Sign.string_of_term (sign_of thy))) ts);
4.18 +fun penv2str thy (penv:penv) = (strs2str' o (map (pen2str thy))) penv;
4.19 +
4.20 +type envv = (int * penv) list;
4.21 +
4.22 +(*. 14.9.01: not used after putting penv-values into itm_
4.23 + make the result of split_* a value of problem-environment .*)
4.24 +fun mkval dsc [] = raise error "mkval called with []"
4.25 + | mkval dsc [t] = t
4.26 + | mkval dsc ts = list2isalist ((type_of o hd) ts) ts;
4.27 +
4.28 +
4.29 +
4.30 +
4.31 +(*. get the constant value from a penv .*)
4.32 +fun getval (id, values) =
4.33 + case values of
4.34 + [] => raise error ("penv_value: no values in '"^
4.35 + (Sign.string_of_term (sign_of Tools.thy) id))
4.36 + | [v] => (id, v)
4.37 + | (v1::v2::_) => (case v1 of
4.38 + Const ("Script.Arbfix",_) => (id, v2)
4.39 + | _ => (id, v1));
4.40 +(*
4.41 + val e_ = (term_of o the o (parse thy)) "e_::bool";
4.42 + val ev = (term_of o the o (parse thy)) "#4 + #3 * x^^^#2 = #0";
4.43 + val v_ = (term_of o the o (parse thy)) "v_";
4.44 + val vv = (term_of o the o (parse thy)) "x";
4.45 + val r_ = (term_of o the o (parse thy)) "err_::bool";
4.46 + val rv1 = (term_of o the o (parse thy)) "eps";
4.47 + val rv2 = (term_of o the o (parse thy)) "#0";
4.48 +
4.49 + val penv = [(e_,[ev]),(v_,[vv]),(r_,[rv2,rv1])]:penv;
4.50 + map getval penv;
4.51 +[(Free ("e_","bool"),
4.52 + Const (#,#) $ (# $ # $ (# $ #)) $ Free ("#0","RealDef.real")),
4.53 + (Free ("v_","RealDef.real"),Free ("x","RealDef.real")),
4.54 + (Free ("err_","bool"),Free ("#0","RealDef.real"))] : (term * term) list
4.55 +*)
4.56 +
4.57 +
4.58 +(*23.3.02 TODO: ideas on redesign of type itm_,type item,type ori,type item ppc
4.59 +(1) kinds of itms:
4.60 + (1.1) untouched: for modeling only dsc displayed(impossible after match_itms)
4.61 + =(presently) Mis (? should be Inc initially, and Mis after match_itms?)
4.62 + (1.2) Syn,Typ,Sup: not related to oris
4.63 + Syn, Typ (presently) should be accepted in appl_add (instead Error')
4.64 + Sup (presently) should be accepted in appl_add (instead Error')
4.65 + _could_ be w.r.t current vat (and then _is_ related to vat
4.66 + Mis should _not_ be made Inc ((presently, by appl_add & match_itms)
4.67 +- dsc in itm_ is timeconsuming -- keep id for respective queries ?
4.68 +- order of items in ppc should be stable w.r.t order of itms
4.69 +
4.70 +- stepwise input of itms --- match_itms (in one go) ..not koordinated
4.71 + - unify code
4.72 + - match_itms / match_itms_oris ..2 versions ?!
4.73 + (fast, for refine / slow, for modeling)
4.74 +
4.75 +- clarify: efficiency <--> simplicity !!!
4.76 + ?: shift dsc itm_ -> itm | discard int in ori,itm | take int instead dsc
4.77 + | take int for perserving order of item ppc in itms
4.78 + | make all(!?) handling of itms stable against reordering(?)
4.79 + | field in ori ?? (not from fmz!) -- meant for efficiency (not doc!???)
4.80 + -"- "#undef" ?= not touched ?= (id,..)
4.81 +-----------------------------------------------------------------
4.82 +27.3.02:
4.83 +def: type pbt = (field, (dsc, pid))
4.84 +
4.85 +(1) fmz + pbt -> oris
4.86 +(2) input + oris -> itm
4.87 +(3) match_itms : schnell(?) f"ur refine
4.88 + match_itms_oris : r"uckmeldung f"ur item ppc
4.89 +
4.90 +(1.1) in oris fehlt daher pid: (i,v,f,d,ts,pid)
4.91 +---------- ^^^^^ --- dh. pbt meist als argument zu viel !!!
4.92 +
4.93 +(3.1) abwarten, wie das matchen mehr unterschiedlicher pbt's sich macht;
4.94 + wenn Problem pbt v"ollig neue, dann w"are eigentlich n"otig ????:
4.95 + (a) (_,_,d1,ts,_):ori + pbt -> (i,vt,d2,ts,pid) dh.vt neu ????
4.96 + (b)
4.97 +*)
4.98 +
4.99 +
4.100 +
4.101 +
4.102 +(*4.9.01: not consistent:
4.103 + after Init_Proof 'Inc', but after copy_probl 'Mis' - for same situation
4.104 + (involves 'is_error');
4.105 + bool in itm really necessary ???*)
4.106 +datatype itm_ =
4.107 + Cor of (term * (* description *)
4.108 + (term list)) * (* for list: elem-wise input *)
4.109 + (term * (term list)) (* elem of penv *)
4.110 + | Syn of cterm'
4.111 + | Typ of cterm'
4.112 + | Inc of (term * (term list)) * (term * (term list)) (*lists only !*)
4.113 + | Sup of (term * (term list)) (* user-input not found in pbt *)
4.114 + | Mis of (term * term) (* pbt-item not found in pbl: only dsc, pid_ *)
4.115 +(*| Inc of bool --- instead of istate in itm ?26.1.00?*);
4.116 +
4.117 +type vats = int list; (*variants in formalizations*)
4.118 +
4.119 +(*.data-type for working on pbl/met-ppc:
4.120 + in pbl initially holds descriptions (only) for user guidance.*)
4.121 +type itm =
4.122 + int * (* id =0 .. untouched - descript (only) from init
4.123 + 23.3.02: seems to correspond to ori (fun insert_ppc)
4.124 + with the purpose to maintain order in item ppc?*)
4.125 + vats * (* variants - copy from ori *)
4.126 + bool * (* input on this item is not/complete *)
4.127 + string * (* #Given | #Find | #Relate *)
4.128 + itm_; (* *)
4.129 +(* use"ME/sequent.sml";
4.130 + *)
4.131 +val e_itm = (0,[],false,"e_itm",Syn"e_itm"):itm;
4.132 +
4.133 +(* find most frequent variant v in itms *)
4.134 +
4.135 +fun vts_in itms = (distinct o flat o (map #2)) (itms:itm list);
4.136 +
4.137 +fun cnt itms v = (v,(length o (filter (curry op= v)) o
4.138 + flat o (map #2)) (itms:itm list));
4.139 +fun vts_cnt vts itms = map (cnt itms) vts;
4.140 +fun max2 [] = raise error "max2 of []"
4.141 + | max2 (y::ys) =
4.142 + let fun mx (a,x) [] = (a,x)
4.143 + | mx (a,x) ((b,y)::ys) =
4.144 + if x < y then mx (b,y) ys else mx (a,x) ys;
4.145 +in mx y ys end;
4.146 +
4.147 +(*. find the variant with most items already input .*)
4.148 +fun max_vt itms =
4.149 + let val vts = (vts_cnt (vts_in itms)) itms;
4.150 + in if vts = [] then 0 else (fst o max2) vts end;
4.151 +
4.152 +
4.153 +(* TODO ev. make more efficient by avoiding flat *)
4.154 +fun mk_e (Cor (_, iv)) = [getval iv]
4.155 + | mk_e (Syn _) = []
4.156 + | mk_e (Typ _) = []
4.157 + | mk_e (Inc (_, iv)) = [getval iv]
4.158 + | mk_e (Sup _) = []
4.159 + | mk_e (Mis _) = [];
4.160 +fun mk_en vt ((i,vts,b,f,itm_):itm) =
4.161 + if vt mem vts then mk_e itm_ else [];
4.162 +(*. extract the environment from an item list;
4.163 + takes the variant with most items .*)
4.164 +fun mk_env itms =
4.165 + let val vt = max_vt itms
4.166 + in (flat o (map (mk_en vt))) itms end;
4.167 +
4.168 +
4.169 +
4.170 +(*. example as provided by an author, complete w.r.t. pbt specified
4.171 + not touched by any user action .*)
4.172 +type ori = (int * (* id: 10.3.00ff impl. only <>0 .. touched
4.173 + 21.3.02: insert_ppc needs it ! ?:purpose maintain
4.174 + order in item ppc ???*)
4.175 + vats * (* variants 21.3.02: related to pbt..discard ?*)
4.176 + string * (* #Given | #Find | #Relate 21.3.02: discard ?*)
4.177 + term * (* description *)
4.178 + term list (* isalist2list t | [t] *)
4.179 + );
4.180 +val e_ori_ = (0,[],"",e_term,[e_term]):ori;
4.181 +val e_ori = (0,[],"",e_term,[e_term]):ori;
4.182 +(* [e_ori_]:ori;
4.183 +val it = [(0,[],"",Const (#,#),[Const #])] : ori
4.184 +*)
4.185 +fun ori2str ((i,vs,fi,t,ts):ori) =
4.186 + "("^(string_of_int i)^", "^((strs2str o (map string_of_int)) vs)^", "^fi^","^
4.187 + (term2str t)^", "^((strs2str o (map term2str)) ts)^")";
4.188 +fun ori02str (vs,fi,t,ts) =
4.189 + "("^((strs2str o (map string_of_int)) vs)^", "^fi^", "^
4.190 + (term2str t)^", "^((strs2str o (map term2str)) ts)^")";
4.191 +
4.192 +
4.193 +
4.194 +
4.195 +(*. given the input value (from split_dts)
4.196 + make the value in a problem-env according to description-type .*)
4.197 +(*28.8.01: .nam and .una impl. properly, others copied .. TODO*)
4.198 +fun pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) v =
4.199 + if is_list v
4.200 + then [v] (*eg. [r=Arbfix]*)
4.201 + else (case v of (*eg. eps=#0*)
4.202 + (Const ("op =",_) $ l $ r) => [r,l]
4.203 + | _ => raise error ("pbl_ids Tools.nam: no equality "
4.204 + ^(Sign.string_of_term (sign_of thy) v)))
4.205 + | pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.una",_)]))) v = [v]
4.206 + | pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) v = [v]
4.207 + | pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.str",_)]))) v = [v]
4.208 + | pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) v = [v]
4.209 + | pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))v = [v]
4.210 + | pbl_ids thy (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))v = [v]
4.211 + | pbl_ids thy _ v = raise error ("pbl_ids: not implemented for "
4.212 + ^(Sign.string_of_term (sign_of thy) v));
4.213 +(*
4.214 + val t = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
4.215 + val (d,argl) = strip_comb t;
4.216 + is_dsc d; (*see split_dts*)
4.217 + dest_list (d,argl);
4.218 + val (_ $ v) = t;
4.219 + is_list v;
4.220 + pbl_ids thy d v;
4.221 +[Const ("List.list.Cons","[bool, bool List.list] => bool List.list") $
4.222 + (Const # $ Free # $ Const (#,#)) $ Const ("List.list.Nil","bool List..
4.223 +
4.224 + val (dsc,vl,_) = (split_dts o term_of o the o (parse thy)) "solveFor x";
4.225 +val dsc = Const ("Descript.solveFor","RealDef.real => Tools.una") : term
4.226 +val vl = Free ("x","RealDef.real") : term
4.227 +
4.228 + val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_";
4.229 + pbl_ids thy dsc vl;
4.230 +val it = [Free ("x","RealDef.real")] : term list
4.231 +
4.232 + val (dsc,vl,_) = (split_dts o term_of o the o(parse thy))
4.233 + "errorBound (eps=#0)";
4.234 + val (dsc,id) = (split_did o term_of o the o(parse thy)) "errorBound err_";
4.235 + pbl_ids thy dsc vl;
4.236 +val it = [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")] : term list *)
4.237 +
4.238 +(*. given an already input itm, ((14.9.01: no difference to pbl_ids jet!!))
4.239 + make the value in a problem-env according to description-type .*)
4.240 +(*28.8.01: .nam and .una impl. properly, others copied .. TODO*)
4.241 +fun pbl_ids' (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) vs =
4.242 + (case vs of
4.243 + [] => raise error ("pbl_ids' Tools.nam called with []")
4.244 + | [t] => (case t of (*eg. eps=#0*)
4.245 + (Const ("op =",_) $ l $ r) => [r,l]
4.246 + | _ => raise error ("pbl_ids' Tools.nam: no equality "
4.247 + ^(Sign.string_of_term (sign_of thy) t)))
4.248 + | vs' => vs (*14.9.01: ???TODO *))
4.249 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.una",_)]))) vs = vs
4.250 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) vs = vs
4.251 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.str",_)]))) vs = vs
4.252 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) vs = vs
4.253 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))vs = vs
4.254 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))vs = vs
4.255 + | pbl_ids' _ vs =
4.256 + raise error ("pbl_ids': not implemented for "
4.257 + ^(terms2str vs));
4.258 +
4.259 +(*
4.260 +@@@@@ v
4.261 +*)
4.262 +
4.263 +
4.264 +
4.265 +
4.266 +
4.267 +
4.268 +(*14.9.01: not used after putting values for penv into itm_*)
4.269 +fun upd_penv thy penv dsc (id, vl) =
4.270 + overwrite (penv, (id, pbl_ids thy dsc vl));
4.271 +(*
4.272 + val penv = [];
4.273 + val (dsc,vl) = (split_did o term_of o the o (parse thy)) "solveFor x";
4.274 + val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_";
4.275 + val penv = upd_penv thy penv dsc (id, vl);
4.276 +[(Free ("v_","RealDef.real"),
4.277 + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")])]
4.278 +: (term * term list) list
4.279 +
4.280 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"errorBound (eps=#0)";
4.281 + val (dsc,id) = (split_did o term_of o the o(parse thy))"errorBound err_";
4.282 + upd_penv thy penv dsc (id, vl);
4.283 +[(Free ("v_","RealDef.real"),
4.284 + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")]),
4.285 + (Free ("err_","bool"),
4.286 + [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")])]
4.287 +: (term * term list) list ^.........!!!!
4.288 +*)
4.289 +
4.290 +
4.291 +fun upd thy envv dsc (id, vl) i =
4.292 + let val penv = case assoc (envv, i) of
4.293 + Some e => e
4.294 + | None => [];
4.295 + val penv' = upd_penv thy penv dsc (id, vl);
4.296 + in (i, penv') end;
4.297 +(*
4.298 + val i = 2;
4.299 + val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv;
4.300 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b";
4.301 + val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_";
4.302 + upd thy envv dsc (id, vl) i;
4.303 +val it = (2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])
4.304 + : int * (term * term list) list*)
4.305 +
4.306 +
4.307 +(*14.9.01: not used after putting pre-penv into itm_*)
4.308 +fun upd_envv thy (envv:envv) (vats:vats) dsc id vl =
4.309 + let val vats = if length vats = 0
4.310 + then (*unknown id to _all_ variants*)
4.311 + if length envv = 0 then [1]
4.312 + else (intsto o length) envv
4.313 + else vats
4.314 + fun isin vats (i,_) = i mem vats;
4.315 + val envs_notin_vat = filter_out (isin vats) envv;
4.316 + in ((map (upd thy envv dsc (id, vl)) vats) @ envs_notin_vat):envv end;
4.317 +(*
4.318 + val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv;
4.319 +
4.320 + val vats = [2]
4.321 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b";
4.322 + val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_";
4.323 + val envv = upd_envv thy envv vats dsc id vl;
4.324 +val envv = [(2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])]
4.325 + : (int * (term * term list) list) list
4.326 +
4.327 + val vats = [1,2,3];
4.328 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"maximum A";
4.329 + val (dsc,id) = (split_did o term_of o the o(parse thy))"maximum m_";
4.330 + upd_envv thy envv vats dsc id vl;
4.331 +[(1,[(Free ("m_","bool"),[Free ("A","bool")])]),
4.332 + (2,
4.333 + [(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")]),
4.334 + (Free ("m_","bool"),[Free ("A","bool")])]),
4.335 + (3,[(Free ("m_","bool"),[Free ("A","bool")])])]
4.336 +: (int * (term * term list) list) list
4.337 +
4.338 +
4.339 + val env = []:envv;
4.340 + val (d,ts) = (split_dts o term_of o the o (parse thy))
4.341 + "fixedValues [r=Arbfix]";
4.342 + val (_,id) = (split_did o term_of o the o (parse thy))"fixedValues fix_";
4.343 + val vats = [1,2,3];
4.344 + val env = upd_envv thy env vats d id (mkval ts);
4.345 +*)
4.346 +
4.347 +(*. update envv by folding from a list of arguments .*)
4.348 +fun upds_envv thy envv [] = envv
4.349 + | upds_envv thy envv ((vs, dsc, id, vl)::ps) =
4.350 + upds_envv thy (upd_envv thy envv vs dsc id vl) ps;
4.351 +(* eval test-maximum.sml until Specify_Method ...
4.352 + val PblObj{probl=(_,pbl),origin=(_,(_,_,mI)),...} = get_obj I pt [];
4.353 + val met = (#ppc o get_met) mI;
4.354 +
4.355 + val envv = [];
4.356 + val eargs = flat eargs;
4.357 + val (vs, dsc, id, vl) = hd eargs;
4.358 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
4.359 +
4.360 + val (vs, dsc, id, vl) = hd (tl eargs);
4.361 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
4.362 +
4.363 + val (vs, dsc, id, vl) = hd (tl (tl eargs));
4.364 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
4.365 +
4.366 + val (vs, dsc, id, vl) = hd (tl (tl (tl eargs)));
4.367 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
4.368 +[(1,
4.369 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
4.370 + (Free ("m_","bool"),[Free (#,#)]),
4.371 + (Free ("vs_","bool List.list"),[# $ # $ Const #]),
4.372 + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
4.373 + (2,
4.374 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
4.375 + (Free ("m_","bool"),[Free (#,#)]),
4.376 + (Free ("vs_","bool List.list"),[# $ # $ Const #]),
4.377 + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
4.378 + (3,
4.379 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
4.380 + (Free ("m_","bool"),[Free (#,#)]),
4.381 + (Free ("vs_","bool List.list"),[# $ # $ Const #])])] : envv *)
4.382 +
4.383 +
4.384 +datatype item =
4.385 + Correct of cterm'
4.386 + | SyntaxE of string
4.387 + | TypeE of string
4.388 + | False of cterm'
4.389 + | Incompl of cterm'
4.390 + | Superfl of string
4.391 + | Missing of cterm';
4.392 +fun item2str (Correct s) ="Correct "^s
4.393 + | item2str (SyntaxE s) ="SyntaxE "^s
4.394 + | item2str (TypeE s) ="TypeE "^s
4.395 + | item2str (False s) ="False "^s
4.396 + | item2str (Incompl s) ="Incompl "^s
4.397 + | item2str (Superfl s) ="Superfl "^s
4.398 + | item2str (Missing s) ="Missing "^s;
4.399 +fun init_item str = SyntaxE str;
4.400 +
4.401 +
4.402 +
4.403 +
4.404 +type 'a ppc =
4.405 + {Given : 'a list,
4.406 + Where: 'a list,
4.407 + Find : 'a list,
4.408 + With : 'a list,
4.409 + Relate: 'a list};
4.410 +fun ppc2str {Given=Given,Where=Where,Find=Find,With=With,Relate=Relate}=
4.411 + ("{Given =" ^ (strs2str Given ) ^
4.412 + ",Where=" ^ (strs2str Where) ^
4.413 + ",Find =" ^ (strs2str Find ) ^
4.414 + ",With =" ^ (strs2str With ) ^
4.415 + ",Relate=" ^ (strs2str Relate) ^ "}");
4.416 +
4.417 +
4.418 +
4.419 +
4.420 +fun item_ppc ({Given = gi,Where= wh,
4.421 + Find = fi,With = wi,Relate= re}: string ppc) =
4.422 + {Given = map init_item gi,Where= map init_item wh,
4.423 + Find = map init_item fi,With = map init_item wi,
4.424 + Relate= map init_item re}:item ppc;
4.425 +fun itemppc2str ({Given=Given,Where=Where,
4.426 + Find=Find,With=With,Relate=Relate}:item ppc)=
4.427 + ("{Given =" ^ ((strs2str' o (map item2str)) Given ) ^
4.428 + ",Where=" ^ ((strs2str' o (map item2str)) Where) ^
4.429 + ",Find =" ^ ((strs2str' o (map item2str)) Find ) ^
4.430 + ",With =" ^ ((strs2str' o (map item2str)) With ) ^
4.431 + ",Relate=" ^ ((strs2str' o (map item2str)) Relate) ^ "}");
4.432 +
4.433 +fun de_item (Correct x) = x
4.434 + | de_item (SyntaxE x) = x
4.435 + | de_item (TypeE x) = x
4.436 + | de_item (False x) = x
4.437 + | de_item (Incompl x) = x
4.438 + | de_item (Superfl x) = x
4.439 + | de_item (Missing x) = x;
4.440 +val empty_ppc ={Given = [],
4.441 + Where= [],
4.442 + Find = [],
4.443 + With = [],
4.444 + Relate= []}:item ppc;
4.445 +val empty_ppc_ct' ={Given = [],
4.446 + Where = [],
4.447 + Find = [],
4.448 + With = [],
4.449 + Relate= []}:cterm' ppc;
4.450 +
4.451 +
4.452 +datatype match =
4.453 + Matches of pblID * item ppc
4.454 +| NoMatch of pblID * item ppc;
4.455 +fun match2str (Matches (pI, ppc)) =
4.456 + "Matches ("^(strs2str pI)^", "^(itemppc2str ppc)^")"
4.457 + | match2str(NoMatch (pI, ppc)) =
4.458 + "NoMatch ("^(strs2str pI)^", "^(itemppc2str ppc)^")";
4.459 +fun matchs2str ms = (strs2str o (map match2str)) ms;
4.460 +fun pblID_of_match (Matches (pI,_)) = pI
4.461 + | pblID_of_match (NoMatch (pI,_)) = pI;
4.462 +
4.463 +
4.464 +(*. the refined pbt is the last_element Matches in the list .*)
4.465 +fun is_matches (Matches _) = true
4.466 + | is_matches _ = false;
4.467 +fun matches_pblID (Matches (pI,_)) = pI;
4.468 +fun refined ms = ((matches_pblID o the o (find_first is_matches) o rev) ms)
4.469 + handle _ => []:pblID;
4.470 +
4.471 +fun ts_in (Cor ((_,ts),_)) = ts
4.472 + | ts_in (Syn (c)) = []
4.473 + | ts_in (Typ (c)) = []
4.474 + | ts_in (Inc ((_,ts),_)) = ts
4.475 + | ts_in (Sup (_,ts)) = ts
4.476 + | ts_in (Mis _) = [];
4.477 +fun all_ts_in itm_s = (flat o (map ts_in)) itm_s;
4.478 +val unique = (term_of o the o (parse Real.thy)) "UnIqE_tErM";
4.479 +fun d_in (Cor ((d,_),_)) = d
4.480 + | d_in (Syn (c)) = (writeln("*** d_in: Syn ("^c^")"); unique)
4.481 + | d_in (Typ (c)) = (writeln("*** d_in: Syn ("^c^")"); unique)
4.482 + | d_in (Inc ((d,_),_)) = d
4.483 + | d_in (Sup (d,_)) = d
4.484 + | d_in (Mis (d,_)) = d;
4.485 +
4.486 +
4.487 +
4.488 +(* val pre = t;
4.489 + (eval_true' "Isac.thy" "eval_rls" pre) handle e => print_exn e;
4.490 + *)
4.491 +
4.492 +(*. check a predicate and make it an item .*)
4.493 +(* val pre::_ = pres';
4.494 + *)
4.495 +fun chkpre2item prls pre =
4.496 + if eval_true (assoc_thy "Isac.thy") (*for Pattern.match *)
4.497 + [pre] prls (*pre parsed, prls.thy*)
4.498 + then (true , Correct (term2str pre))
4.499 + else (false , False (term2str pre));
4.500 +
4.501 +(*. check preconditions, make them items, return true for all true .*)
4.502 +fun check_preconds' _ [] _ _ = ([], true)
4.503 +(* val pres = (#where_ o get_pbt) pI'; val mvat = max_vt pbl;
4.504 +
4.505 + val (pres,pbl)=(pre,itms);
4.506 + *)
4.507 + | check_preconds' prls pres pbl mvat =
4.508 + let val env = mk_env pbl;
4.509 + val pres' = map (subst_atomic env) pres;
4.510 + val pres'' = map (chkpre2item prls) pres';
4.511 + in (map snd pres'', foldl and_ (true, map fst pres'')) end;
4.512 +(*
4.513 + val [t] = pres';
4.514 + term2str t;
4.515 + chkpre2item t;
4.516 + *)
4.517 +
4.518 +
4.519 +fun check_preconds thy prls pres pbl =
4.520 + check_preconds' prls pres pbl (max_vt pbl);
4.521 +(* run test-root-equ-sml until nxt=Add_Find "solutions L")...
4.522 +
4.523 + val ppp = hd pres';
4.524 + val ppp = (term_of o the o (parse thy)) "matches (a=b) (x=#0)";
4.525 +
4.526 + eval_matches "" "" ppp thy;
4.527 + eval_true' "Isac.thy" "eval_rls" ppp;
4.528 +
4.529 +*)
4.530 +
4.531 +(*----------------------------24.3.02: done too much-----
4.532 +(**. copy the already input items from probl to meth (in PblObj):
4.533 + for each item in met search the related one in pbl,
4.534 + items not found in probl are (1) inserted as 'untouched' (0,...),
4.535 + and (2) completed from oris (via max_vt)
4.536 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ "uberkomplett 21.2.02 ------------ .**)
4.537 +(* val (pbl, met) = (itms, ppc);
4.538 + *)
4.539 +fun copy_pbl thy oris pbl met =
4.540 + let val vt = max_vt pbl;
4.541 + fun vt_and_dsc d' ((i,v,f,d,ts):ori) =
4.542 + vt mem v andalso d'= d
4.543 + fun cpy its [] (f, (d, id)) =
4.544 + if length its = 0 (*no dsc found in pbl*)
4.545 + then case find_first (vt_and_dsc d) oris
4.546 + of Some (i,v,_,_,ts) =>
4.547 + [(i,v,true,f, Cor ((d,ts), (id,pbl_ids' thy d ts)))]
4.548 + | None => [(0,[],false,f,Mis (d, id))]
4.549 + else its
4.550 + | cpy its ((it as (i, vs, b, f, itm_))::itms) (pb as (x, (d, id))) =
4.551 + if d = d_in itm_ andalso i<>0 (*already touched by user*)
4.552 + then cpy (its @ [it]) itms pb else cpy its itms pb;
4.553 + in ((flat o (map (cpy [] pbl))) met):itm list end;
4.554 +
4.555 +
4.556 +(**. copy the already input items from probl to meth (in PblObj):
4.557 + for each item in met search the related one in pbl,
4.558 + items not found in probl are inserted as 'untouched' (0,...)
4.559 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ "uberkomplett 21.2.02 ------------ .**)
4.560 +(* val (pbl, met) = (itms, ppc);
4.561 + *)
4.562 +fun copy_pbl (pbl:itm list) met =
4.563 + let fun cpy its [] (f, (d, id)) =
4.564 + if length its = 0 (*no dsc found in pbl*)
4.565 + then [(0,[],false,f,Mis (d, id))]
4.566 + else its
4.567 + | cpy its ((it as (i, vs, b, f, itm_))::itms) (pb as (x, (d, id))) =
4.568 + if d = d_in itm_ andalso i<>0 (*already touched by user*)
4.569 + then cpy (its @ [it]) itms pb else cpy its itms pb;
4.570 + in ((flat o (map (cpy [] pbl))) met):itm list end;
4.571 +
4.572 +
4.573 +(**. copy the already input items from probl to meth (in PblObj):
4.574 + for each item in met search the related one in pbl
4.575 + (missing items are requested by nxt_spec) .**)
4.576 +(* val (pbl, met) = (itms, ppc);
4.577 + *)
4.578 +fun copy_pbl (pbl:itm list) met =
4.579 + let fun cpy its [] (f, (d, id)) = its
4.580 + | cpy its ((it as (i, vs, b, f, itm_))::itms) (pb as (x, (d, id))) =
4.581 + if d = d_in itm_ andalso i<>0 (*already touched by user*)
4.582 + then cpy (its @ [it]) itms pb
4.583 + else cpy its itms pb;
4.584 + in ((flat o (map (cpy [] pbl))) met):itm list end;
4.585 +
4.586 +(*. copy pbt to met (in Specify_Method)
4.587 + ALL pbt. (1) dsc(pbt) notmem dsc(pbls) =>
4.588 + (2) filter (dsc(pbt) = dsc(oris)) oris; -> newitms;
4.589 + (3) pbt @ newitms .*)
4.590 +(* val (pbl, met) = (itms, pbt);
4.591 + *)
4.592 +fun copy_pbl (pbl:itm list) met oris =
4.593 + let fun eqdsc_pbt_itm ((_,(d,_))) ((_,_,_,_,itm_):itm) = d = d_in itm_;
4.594 + fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of
4.595 + Some _ => false | None => true;
4.596 + (*1*)val mis = ((map (cons2 (fst, fst o snd))) o (filter (notmem pbl))) met;
4.597 +
4.598 + fun eqdsc_ori d ((_,_,_,d',_):ori) = d = d';
4.599 + fun ori2itmMis f ((i,v,_,d,ts):ori) = (i,v,false,f,Mis (d,ts)):itm;
4.600 + fun oris2itms oris mis1 = ((map (ori2itmMis (fst mis1)))
4.601 + o (filter ((eqdsc_ori o snd) mis1))) oris;
4.602 + val news = (flat o (map (oris2itms oris))) mis;
4.603 + in pbl @ news end;
4.604 + ----------------------------24.3.02: done too much-----*)
4.605 +
4.606 +
4.607 +
4.608 +
4.609 +
4.610 +
4.611 +(* ---------------------------------------------NOT UPTODATE !!! 4.9.01
4.612 + eval test-maximum.sml until Specify_Method ...
4.613 + val PblObj{probl=(_,pbl),origin=(_,(_,_,mI)),...} = get_obj I pt [];
4.614 + val met = (#ppc o get_met) mI;
4.615 + val (m::_) = met;
4.616 + cpy [] pbl m;
4.617 +[((1,[1,2,3],true,"#Given",Cor ((Const #,[#]),[])),
4.618 + [([1,2,3],Const ("Descript.fixedValues","bool List.list => Tools.nam"),
4.619 + Free ("fix_","bool List.list"),Const # $ Free # $ Const (#,#))])]
4.620 +: (itm * (vats * term * term * term) list) list
4.621 +
4.622 + upds_envv thy [] (flat eargs);
4.623 +[(1,
4.624 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
4.625 + (Free ("m_","bool"),[Free (#,#)]),
4.626 + (Free ("vs_","bool List.list"),[# $ # $ (# $ #)]),
4.627 + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
4.628 + (2,
4.629 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
4.630 + (Free ("m_","bool"),[Free (#,#)]),
4.631 + (Free ("vs_","bool List.list"),[# $ # $ (# $ #)]),
4.632 + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
4.633 + (3,
4.634 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
4.635 + (Free ("m_","bool"),[Free (#,#)]),
4.636 + (Free ("vs_","bool List.list"),[# $ # $ (# $ #)])])] : envv
4.637 + *)
4.638 +
4.639 +
4.640 +
5.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2 +++ b/src/sml/ME/ptyps.sml Thu Apr 17 18:01:03 2003 +0200
5.3 @@ -0,0 +1,1108 @@
5.4 +(* tree of problem-types
5.5 + W.N.98
5.6 + use"../ME/ptyps.sml";
5.7 + use"ME/ptyps.sml";
5.8 + use"ptyps.sml";
5.9 + *)
5.10 +
5.11 +(*-----------------------------------------vvv-(1) aus modspec.sml 23.3.02*)
5.12 +val dsc_unknown = (term_of o the o (parseold Script.thy))
5.13 + "unknown::'a => unknow";
5.14 +(*-----------------------------------------^^^-(1) aus modspec.sml 23.3.02*)
5.15 +
5.16 +(*-----------------------------------------vvv-(2) aus modspec.sml 23.3.02*)
5.17 +
5.18 +
5.19 +fun is_var (Free _) = true
5.20 + | is_var _ = false;
5.21 +
5.22 +
5.23 +
5.24 +val e_listReal = (term_of o the o (parse Script.thy)) "[]::(real list)";
5.25 +val e_listBool = (term_of o the o (parse Script.thy)) "[]::(bool list)";
5.26 +
5.27 +
5.28 +(* revert split_ *)
5.29 +fun compos thy (d,[]) =
5.30 + cterm_of (sign_of thy)
5.31 + (if is_reall_dsc d then (d $ e_listReal)
5.32 + else if is_booll_dsc d then (d $ e_listBool)
5.33 + else d)
5.34 + | compos thy (d,ts) =
5.35 + cterm_of (sign_of thy)
5.36 + (d $ (if is_list_dsc d andalso not (is_dscforlist d)
5.37 + andalso not (is_var (hd ts)) (*..for pbt*)
5.38 + then (list2isalist (type_of (hd ts)) ts)
5.39 + else hd ts));
5.40 +(*
5.41 +> val t = (term_of o the o (parse thy)) "maximum A";
5.42 +> val (d,ts) = split_dts t;
5.43 +> compos thy (d,ts);
5.44 +val it = "maximum A" : cterm
5.45 +> val t = (term_of o the o (parse thy)) "fixed_values [R=(R::real)]";
5.46 +> val (d,ts) = split_dts t;
5.47 +> compos thy (d,ts);
5.48 +val it = "fixed_values [R = R]" : cterm
5.49 +> val t = (term_of o the o (parse thy)) "testdscforlist [#1]";
5.50 +> val (d,ts) = split_dts t;
5.51 +> compos thy (d,ts);
5.52 +val it = "testdscforlist [#1]" : cterm
5.53 +
5.54 +> val t = (term_of o the o (parse thy)) "(A::real)";
5.55 +> val (d,ts) = split_dts t;
5.56 +val d = Const ("empty","empty") : term
5.57 +val ts = [Free ("A","RealDef.real")] : term list
5.58 +> val t = (term_of o the o (parse thy)) "[R=(R::real)]";
5.59 +> val (d,ts) = split_dts t;
5.60 +val d = Const ("empty","empty") : term
5.61 +val ts = [Const # $ Free # $ Free (#,#)] : term list
5.62 +> val t = (term_of o the o (parse thy)) "[#1,#2]";
5.63 +> val (d,ts) = split_dts t;
5.64 +val ts = [Free ("#1","'a"),Free ("#2","'a")] : NOT WANTED
5.65 +*)
5.66 +
5.67 +fun itm_2item thy (Cor ((d,ts),_))= Correct(string_of_cterm (compos thy(d,ts)))
5.68 + | itm_2item thy (Syn c) = SyntaxE c
5.69 + | itm_2item thy (Typ c) = TypeE c
5.70 + | itm_2item thy (Inc ((d,ts),_))=Incompl(string_of_cterm (compos thy(d,ts)))
5.71 + | itm_2item thy (Sup (d,ts)) =Superfl(string_of_cterm (compos thy(d,ts)))
5.72 + | itm_2item thy (Mis (d,pid)) =
5.73 + Missing (Sign.string_of_term (sign_of thy) d ^" "^
5.74 + Sign.string_of_term (sign_of thy) pid);
5.75 +
5.76 +
5.77 +
5.78 +
5.79 +
5.80 +(* --- 8.3.00
5.81 +fun get_dsc_in dscppc sel = ((the (assoc (dscppc, sel))):term list)
5.82 + handle _ => error ("get_dsc_in not for "^sel);
5.83 +
5.84 +fun dscs_in dscppc =
5.85 + ((get_dsc_in dscppc "#Given") @
5.86 + (get_dsc_in dscppc "#Find") @
5.87 + (get_dsc_in dscppc "#Relate")):term list;
5.88 +
5.89 + --- 26.1.88
5.90 +fun get_dsc_of pblID sel = (the (assoc((snd o get_pbt) pblID, sel)));
5.91 +fun get_dsc pblID =
5.92 + (get_dsc_of pblID "#Given") @
5.93 + (get_dsc_of pblID "#Find") @
5.94 + (get_dsc_of pblID "#Relate");
5.95 + --- *)
5.96 +
5.97 +fun mappc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) =
5.98 + {Given=map f gi, Where=map f wh,
5.99 + Find=map f fi, With=map f wi, Relate=map f re}:'b ppc;
5.100 +fun appc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) =
5.101 + {Given=f gi, Where=f wh,
5.102 + Find=f fi, With=f wi, Relate=f re}:'b ppc;
5.103 +
5.104 +(*for ppc of changing type*)
5.105 +fun sel_ppc sel ppc =
5.106 + case sel of
5.107 + "#Given" => #Given (ppc:'a ppc)
5.108 + | "#Where" => #Where (ppc:'a ppc)
5.109 + | "#Find" => #Find (ppc:'a ppc)
5.110 + | "#With" => #With (ppc:'a ppc)
5.111 + | "#Relate" => #Relate (ppc:'a ppc)
5.112 + | _ => raise error ("sel_ppc tried to select by '"^sel^"'");
5.113 +
5.114 +fun repl_sel_ppc sel
5.115 + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x =
5.116 + case sel of
5.117 + "#Given" => ({Given= x,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc)
5.118 + | "#Where" => {Given=gi,Where= x,Find=fi,With=wi,Relate=re}
5.119 + | "#Find" => {Given=gi,Where=wh,Find= x,With=wi,Relate=re}
5.120 + | "#With" => {Given=gi,Where=wh,Find=fi,With= x,Relate=re}
5.121 + | "#Relate" => {Given=gi,Where=wh,Find=fi,With=wi,Relate= x}
5.122 + | _ => raise error ("repl_sel_ppc tried to select by '"^sel^"'");
5.123 +
5.124 +fun add_sel_ppc thy sel
5.125 + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x =
5.126 + case sel of
5.127 + "#Given" => ({Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}:'a ppc)
5.128 + | "#Where" => {Given=gi,Where=wh@[x],Find=fi,With=wi,Relate=re}
5.129 + | "#Find" => {Given=gi,Where=wh,Find=fi@[x],With=wi,Relate=re}
5.130 + | "#Relate"=> {Given=gi,Where=wh,Find=fi,With=wi,Relate=re@[x]}
5.131 + | "#undef" => {Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}(*ori2itmSup*)
5.132 + | _ => raise error ("add_sel_ppc tried to select by '"^sel^"'");
5.133 +fun add_where ({Given=gi,Find=fi,With=wi,Relate=re,...}:'a ppc) wh =
5.134 + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc);
5.135 +
5.136 +
5.137 +(*---------------------------------------------------------------
5.138 +fun meth'2meth ({ppc=ppc,pre=_,rew_ord'=rew_ord',rls'=rls',asm_thm=asm_thm,
5.139 + asm_rls=asm_rls,scr=scr}:meth') =
5.140 + ({ppc=[],rew_ord'=rew_ord',rls'=rls',asm_thm=asm_thm,
5.141 + asm_rls=asm_rls}:meth);--------------cleaned 27.8.02*)
5.142 +
5.143 +
5.144 +(*-----------------------------------------^^^-(2) aus modspec.sml 23.3.02*)
5.145 +
5.146 +(*-----------------------------------------vvv-(3) aus modspec.sml 23.3.02*)
5.147 +
5.148 +(* this may decompose an object-language isa-list;
5.149 + use only, if description is not available, eg. not input *)
5.150 +fun dest_list' t = if is_list t then isalist2list t else [t];
5.151 +
5.152 +fun dest_list (d,ts) =
5.153 + let fun dest t =
5.154 + if is_list_dsc d andalso not (is_dscforlist d)
5.155 + andalso not (is_var t) (*..for pbt*)
5.156 + then isalist2list t else [t]
5.157 + in (flat o (map dest)) ts end;
5.158 +
5.159 +(*decompose a problem-type into description and identifier
5.160 + TODO: no term list !!! (just for quick redoing prep_ori) *)
5.161 +fun split_dsc thy t =
5.162 + (let val (hd,args) = strip_comb t
5.163 + in if is_dsc hd
5.164 + then (hd, args)
5.165 + else (e_term, [t]) (*??? 9.01 just copied*)
5.166 + end)
5.167 + handle _ => raise error ("split_dsc: called with "^
5.168 + (Sign.string_of_term (sign_of thy) t));
5.169 +(*
5.170 +> val t1 = (term_of o the o (parse thy)) "errorBound err_";
5.171 +> split_dsc t1;
5.172 +(Const ("Descript.errorBound","bool => Tools.nam"),Free ("err_","bool"))
5.173 + : term * term
5.174 +> val t3 = (term_of o the o (parse thy)) "valuesFor vs_";
5.175 +> split_dsc t3;
5.176 +(Const ("Descript.valuesFor","bool List.list => Tools.toreall"),
5.177 + Free ("vs_","bool List.list")) : term * term*)
5.178 +
5.179 +
5.180 +(*
5.181 + val t = (term_of o the o (parse thy)) "x::real";
5.182 + val (hd,argl) = strip_comb t;
5.183 +
5.184 + ((split_dts' thy) o term_of o the o (parse thy)) (hd (tl fmz));
5.185 + split_dts' thy t;
5.186 + *)
5.187 +
5.188 +
5.189 +
5.190 +(*. decompose an input into description, terms (ev. elems of lists),
5.191 + and the value for the problem-environment .*)
5.192 +fun split_dts thy (t as (_ $ args)) =
5.193 + let val (hd,argl) = strip_comb t
5.194 + in if (not o is_dsc) hd then (e_term, dest_list' t, [t(*9.01 ???*)])
5.195 + else (hd, dest_list (hd,argl), pbl_ids thy hd args)
5.196 + end
5.197 + | split_dts thy t = (*either dsc or term*)
5.198 + let val (hd,argl) = strip_comb t
5.199 + in if (not o is_dsc) hd then (e_term, dest_list' t, [t(*9.01 ???*)])
5.200 + else (hd, dest_list (hd,argl), [t(*9.01 ???*)])
5.201 + end;
5.202 +(*
5.203 +> val t2 = (term_of o the o (parse thy)) "errorBound (eps = #0)";
5.204 +> split_dts thy t2;
5.205 +(Const ("Descript.errorBound","bool => Tools.nam"),
5.206 + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")],
5.207 + [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")])
5.208 +: term * term list * term list
5.209 +
5.210 +> val t4 = (term_of o the o (parse thy)) "valuesFor [a,b]";
5.211 +> split_dts thy t4;
5.212 +(Const ("Descript.valuesFor","bool List.list => Tools.toreall"),
5.213 + [Free ("a","bool"),Free ("b","bool")],
5.214 + [Const (#,#) $ Free (#,#) $ (Const # $ Free # $ Const (#,#))])
5.215 + : term * term list * term list
5.216 +
5.217 +> val t = (term_of o the o (parse thy)) "x::real";
5.218 +> val (hd,argl) = strip_comb t;
5.219 +val hd = Free ("x","RealDef.real") : term
5.220 +val argl = [] : term list
5.221 +> split_dts thy t;
5.222 +(Const ("empty","empty"),[Free ("x","RealDef.real")],
5.223 + [Free ("x","RealDef.real")]) : term * term list * term list
5.224 +
5.225 +
5.226 +BEFORE 9.01:
5.227 +> val t = (term_of o the o (parse thy)) "solutions x_i_";
5.228 +> split_dts t;
5.229 + (Const ("Descript.solutions","bool List.list => Tools.toreall"),
5.230 + [Free ("x_i_","bool List.list")]) : term * term list
5.231 +
5.232 +> val t = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
5.233 +> split_dts t;
5.234 + (Const ("Descript.fixedValues","bool List.list => Tools.nam"),
5.235 + [Const ("op =","[RealDef.real, RealDef.real] => bool") $
5.236 + Free ("r","RealDef.real") $ Const ("Script.Arbfix","RealDef.real")])
5.237 + : term * term list
5.238 +
5.239 +> val t = (term_of o the o (parse thy)) "valuesFor [a=Undef,b=Undef]";
5.240 +> split_dts t;
5.241 + (Const ("Descript.valuesFor","bool List.list => Tools.toreall"),
5.242 + [Const ("op =","[RealDef.real, RealDef.real] => bool") $
5.243 + Free ("a","RealDef.real") $ Const ("Script.Undef","RealDef.real"),
5.244 + Const ("op =","[RealDef.real, RealDef.real] => bool") $
5.245 + Free ("b","RealDef.real") $ Const ("Script.Undef","RealDef.real")])
5.246 + : term * term list
5.247 +*)
5.248 +
5.249 +(*. take the first two return-values; for prep_ori .*)
5.250 +fun split_dts' thy t =
5.251 + let val (d, ts, _) = split_dts thy t
5.252 + in (d, ts) end;
5.253 +
5.254 +(*9.3.00*)
5.255 +(* split a term into description and (id | structured variable)
5.256 + for pbt, met.ppc *)
5.257 +fun split_did t =
5.258 + (let val (hd,[arg]) = strip_comb t
5.259 + in (hd,arg) end)
5.260 + handle _ => raise error ("split_did: doesn't match (hd,[arg]) for t = "
5.261 + ^(Sign.string_of_term (sign_of Script.thy) t));
5.262 +
5.263 +
5.264 +
5.265 +(*create output-string for itm_*)
5.266 +fun itm_out thy (Cor ((d,ts),_)) = (string_of_cterm (compos thy(d,ts)))
5.267 + | itm_out thy (Syn c) = c
5.268 + | itm_out thy (Typ c) = c
5.269 + | itm_out thy (Inc ((d,ts),_)) = (string_of_cterm (compos thy(d,ts)))
5.270 + | itm_out thy (Sup (d,ts)) = (string_of_cterm (compos thy(d,ts)))
5.271 + | itm_out thy (Mis (d,pid)) =
5.272 + Sign.string_of_term (sign_of thy) d ^" "^
5.273 + Sign.string_of_term (sign_of thy) pid;
5.274 +(*make string for error-msgs*)
5.275 +fun itm_2str thy (Cor ((d,ts), penv)) =
5.276 + "Cor " ^ string_of_cterm (compos thy(d,ts)) ^" ,"^ pen2str thy penv
5.277 + | itm_2str thy (Syn c) = "Syn "^c
5.278 + | itm_2str thy (Typ c) = "Typ "^c
5.279 + | itm_2str thy (Inc ((d,ts), penv)) =
5.280 + "Inc " ^ string_of_cterm (compos thy(d,ts)) ^" ,"^ pen2str thy penv
5.281 + | itm_2str thy (Sup (d,ts)) = "Sup "^(string_of_cterm (compos thy(d,ts)))
5.282 + | itm_2str thy (Mis (d,pid))=
5.283 + "Mis "^ Sign.string_of_term (sign_of thy) d ^
5.284 + " "^ Sign.string_of_term (sign_of thy) pid;
5.285 +fun itm2str thy ((i,is,b,s,itm_):itm) =
5.286 + "("^(string_of_int i)^" ,"^(ints2str' is)^" ,"^(bool2str b)^" ,"^
5.287 + s^" ,"^(itm_2str thy itm_)^")";
5.288 +val linefeed = (curry op^) "\n";
5.289 +fun itms2str thy itms = strs2str' (map (linefeed o (itm2str thy)) itms);
5.290 +fun w_itms2str thy itms = writeln (itms2str thy itms);
5.291 +
5.292 +(*22.11.00 unused
5.293 +fun itm_ppc2str thy ipc = (ppc2str o (mappc (itm_2str thy))) ipc;*)
5.294 +
5.295 +
5.296 +(*--3.3.
5.297 +fun itms2dts itms =
5.298 + let
5.299 + fun coll itms' [] = itms'
5.300 + | coll itms' (i::itms) =
5.301 + case i of
5.302 + (Cor (d,ts)) => coll (itms' @ [(d,ts)]) itms
5.303 + | (Syn c) => coll (itms' ) itms
5.304 + | (Typ c) => coll (itms' ) itms
5.305 + | (Fal (d,ts)) => coll (itms' @ [(d,ts)]) itms
5.306 + | (Inc (d,ts)) => coll (itms' @ [(d,ts)]) itms
5.307 + | (Sup (d,ts)) => coll (itms' @ [(d,ts)]) itms
5.308 + in coll [] itms end;
5.309 +*)
5.310 +(*--3.3.00
5.311 +fun itm2item ((_,_,_,_,Cor (d,ts)):itm) =
5.312 + Correct (string_of_cterm (compos thy(d,ts)))
5.313 + | itm2item (_,_,_,_,Syn (c)) = SyntaxE c
5.314 + | itm2item (_,_,_,_,Typ (c)) = TypeE c
5.315 + | itm2item (_,_,_,_,Fal (d,ts)) =
5.316 + False (string_of_cterm (compos thy(d,ts)))
5.317 + | itm2item (_,_,_,_,Inc (d,ts)) =
5.318 + Incompl (string_of_cterm (compos thy(d,ts)))
5.319 + | itm2item (_,_,_,_,Sup (d,ts)) =
5.320 + Superfl (string_of_cterm (compos thy(d,ts)));
5.321 +*)
5.322 +
5.323 +(* use"ME/modspec.sml";
5.324 + *)
5.325 +fun itms2itemppc thy (itms:itm list) (pre:item list) =
5.326 + let
5.327 + fun coll ppc [] = ppc
5.328 + | coll ppc ((_,_,_,field,itm_)::itms) =
5.329 + coll (add_sel_ppc thy field ppc (itm_2item thy itm_)) itms;
5.330 + val gfr = coll empty_ppc itms;
5.331 + in add_where gfr pre end;
5.332 +(*-----------------------------------------^^^-(3) aus modspec.sml 23.3.02*)
5.333 +
5.334 +(*-----------------------------------------vvv-(4) aus modspec.sml 23.3.02*)
5.335 +
5.336 +(* --- 9.3.fun add_field dscs (d,ts) =
5.337 + if d mem (get_dsc_in dscs "#Given")
5.338 + then ("#Given",d,ts:term list)
5.339 + else if d mem (get_dsc_in dscs "#Find")
5.340 + then ("#Find",d,ts)
5.341 + else if d mem (get_dsc_in dscs "#Relate")
5.342 + then ("#Relate",d,ts)
5.343 + else ("#undef",d,ts);
5.344 +(* 28.1.00 raise error ("add_field: '"^
5.345 + (Sign.string_of_term (sign_of thy) d)^
5.346 + "' not in ppc-description "); *)
5.347 + ------9.3. *)
5.348 +
5.349 +(* 9.3.00
5.350 + compare d and dsc in pbt and transfer field to pre-ori *)
5.351 +fun add_field thy pbt (d,ts) =
5.352 + let fun eq d pt = (d = (fst o snd) pt);
5.353 + in case filter (eq d) pbt of
5.354 + [(fi,(dsc,_))] => (fi,d,ts)
5.355 + | [] => ("#undef",d,ts) (*may come with met.ppc*)
5.356 + | _ => raise error ("add_field: "^
5.357 + (Sign.string_of_term (sign_of thy) d)^
5.358 + " more than once in pbt")
5.359 + end;
5.360 +
5.361 +(*. take over field from met.ppc at 'Specify_Method' into ori,
5.362 + i.e. also removes "#undef" fields .*)
5.363 +(* val (mpc, ori) = ((#ppc o get_met) mID, oris);
5.364 + *)
5.365 +fun add_field' thy mpc (ori:ori list) =
5.366 + let fun eq d pt = (d = (fst o snd) pt);
5.367 + fun repl mpc (i,v,_,d,ts) =
5.368 + case filter (eq d) mpc of
5.369 + [(fi,(dsc,_))] => [(i,v,fi,d,ts)]
5.370 + | [] => [] (*25.2.02: dsc in ori, but not in met -> superfluous*)
5.371 + (*raise error ("add_field': "^
5.372 + (Sign.string_of_term (sign_of thy) d)^
5.373 + " not in met"*)
5.374 + | _ => raise error ("add_field': "^
5.375 + (Sign.string_of_term (sign_of thy) d)^
5.376 + " more than once in met");
5.377 + in (flat ((map (repl mpc)) ori)):ori list end;
5.378 +
5.379 +
5.380 +(*.mark an element with the position within a plateau;
5.381 + a plateau with length 1 is marked with 0 .*)
5.382 +fun mark eq [] = raise error "mark []"
5.383 + | mark eq xs =
5.384 + let
5.385 + fun mar xx eq [x] n = xx @ [(if n=1 then 0 else n,x)]
5.386 + | mar xx eq (x::x'::xs) n =
5.387 + if eq(x,x') then mar (xx @ [(n,x)]) eq (x'::xs) (n+1)
5.388 + else mar (xx @ [(if n=1 then 0 else n,x)]) eq (x'::xs) 1;
5.389 + in mar [] eq xs 1 end;
5.390 +(*
5.391 +> val xs = [1,1,1,2,4,4,5];
5.392 +> mark (op=) xs;
5.393 +val it = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)]
5.394 +*)
5.395 +
5.396 +(*.assumes equal descriptions to be in adjacent 'plateaus',
5.397 + items at a certain position within the plateaus form a variant;
5.398 + length = 1 ... marked with 0: covers all variants .*)
5.399 +fun add_variants fdts =
5.400 + let
5.401 + fun eq (a,b) = curry op= (snd3 a) (snd3 b);
5.402 + in mark eq fdts end;
5.403 +
5.404 +(* collect equal elements: the model for coll_variants *)
5.405 +fun coll eq xs =
5.406 + let
5.407 + fun col xs eq x [] = xs @ [x]
5.408 + | col xs eq x (y::ys) =
5.409 + if eq(x,y) then col xs eq x ys
5.410 + else col (xs @ [x]) eq y ys;
5.411 + in col [] eq (hd xs) xs end;
5.412 +(*
5.413 +> val xs = [1,1,1,2,4,4,4];
5.414 +> coll (op=) xs;
5.415 +val it = [1,2,4] : int list
5.416 +*)
5.417 +
5.418 +fun max [] = raise error "max of []"
5.419 + | max (y::ys) =
5.420 + let fun mx x [] = x
5.421 + | mx x (y::ys) = if x < y then mx y ys else mx x ys;
5.422 +in mx y ys end;
5.423 +
5.424 +(* assumes *)
5.425 +fun coll_variants (((v,x)::vxs)) =
5.426 + let
5.427 + fun col xs (vs,x) [] = xs @ [(vs,x)]
5.428 + | col xs (vs,x) ((v',x')::vxs') =
5.429 + if x=x' then col xs (vs @ [v'], x') vxs'
5.430 + else col (xs @ [(vs,x)]) ([v'], x') vxs';
5.431 + in col [] ([v],x) vxs end;
5.432 +(* val xs = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)];
5.433 +> col [] ([(fst o hd) xs],(snd o hd) xs) (tl xs);
5.434 +val it = [([1,2,3],1),([0],2),([1,2],4),([0],5)] *)
5.435 +
5.436 +
5.437 +fun replace_0 vm [0] = intsto vm
5.438 + | replace_0 vm vs = vs;
5.439 +
5.440 +fun add_id [] = raise error "add_id []"
5.441 + | add_id xs =
5.442 + let fun add n [] = []
5.443 + | add n (x::xs) = (n,x) :: add (n+1) xs;
5.444 +in add 1 xs end;
5.445 +(*
5.446 +> val xs = [([1,2,3],1),([0],2),([1,2],4),([0],5)];
5.447 +> add_id xs;
5.448 +val it = [(1,([#,#,#],1)),(2,([#],2)),(3,([#,#],4)),(4,([#],5))]
5.449 + *)
5.450 +
5.451 +fun flattup (a,(b,(c,d,e))) = (a,b,c,d,e);
5.452 +fun flattup' (a,(b,((c,d),e))) = (a,b,c,d,e);
5.453 +fun flat3 (a,(b,c)) = (a,b,c);
5.454 +(*
5.455 + val pI = pI';
5.456 + !pbts;
5.457 +*)
5.458 +(* in root (only!) fmz may be empty: fill with ..,dsc,[]
5.459 +fun init_ori fmz thy pI =
5.460 + if fmz <> [] then prep_ori fmz thy pI (*fmz assumed complete*)
5.461 + else
5.462 + let
5.463 + val fds = map (cons2 (fst, fst o snd)) (get_pbt pI);
5.464 + val vfds = map ((pair [1]) o (rpair [])) fds;
5.465 + val ivfds = add_id vfds
5.466 + in (map flattup' ivfds):ori list end; 10.3.00---*)
5.467 +(* val fmz = ctl; val pI=["sqroot-test","univariate","equation"];
5.468 + val (thy,pbt) = (assoc_thy dI',(#ppc o get_pbt) pI');
5.469 + *)
5.470 +fun prep_ori [] _ _ = []
5.471 + | prep_ori fmz thy pbt =
5.472 + let
5.473 + val dts = map ((split_dts' thy) o term_of o the o (parse thy)) fmz;
5.474 + val ori = map (add_field thy pbt) dts;
5.475 +(* val ori = map (flat3 o (pair "#undef")) dts; *)
5.476 + val ori' = add_variants ori;
5.477 + val maxv = max (map fst ori');
5.478 + val maxv = if maxv = 0 then 1(*only 1 variant*) else maxv;
5.479 + val ori'' = coll_variants ori';
5.480 + val ori''' = map (apfst (replace_0 maxv)) ori'';
5.481 + val ori'''' = add_id ori'''
5.482 + in (map flattup ori''''):ori list end;
5.483 +
5.484 +(*-----------------------------------------^^^-(4) aus modspec.sml 23.3.02*)
5.485 +
5.486 +fun del_eq k ptyps =
5.487 +let fun del k ptyps [] = ptyps
5.488 + | del k ptyps ((Ptyp (k', [p], ps))::pys) =
5.489 + if k=k' then del k ptyps pys
5.490 + else del k (ptyps @ [Ptyp (k', [p], ps)]) pys;
5.491 +in del k [] ptyps end;
5.492 +
5.493 +fun insrt d pbt [k] [] = [Ptyp (k, [pbt],[])]
5.494 +
5.495 + | insrt d pbt [k] ((Ptyp (k', [p], ps))::pys) =
5.496 +((*writeln("### insert 1: ks = "^(strs2str [k])^" k'= "^k');*)
5.497 + if k=k'
5.498 + then ((Ptyp (k', [pbt], ps))::pys)
5.499 + else (*ev.newly added pbt is free _only_ with 'last_elem pblID'*)
5.500 + ((Ptyp (k', [p], ps))::(insrt d pbt [k] pys))
5.501 +)
5.502 + | insrt d pbt (k::ks) ((Ptyp (k', [p], ps))::pys) =
5.503 +((*writeln("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*)
5.504 + if k=k'
5.505 + then ((Ptyp (k', [p], insrt d pbt ks ps))::pys)
5.506 + else
5.507 + if length pys = 0
5.508 + then raise error ("insert_pbt: not found "^(strs2str (d:pblID)))
5.509 + else ((Ptyp (k', [p], ps))::(insrt d pbt (k::ks) pys))
5.510 +);
5.511 +
5.512 +fun store_pbt (pbt, pblID) = ptyps:= insrt pblID pbt (rev pblID) (!ptyps);
5.513 +
5.514 +
5.515 +
5.516 +
5.517 +(* prepare problem-types before storing in pbltypes *)
5.518 +
5.519 +
5.520 +(*
5.521 + val thy = SqRoot.thy;
5.522 + val pblID = ["detail","test"];
5.523 + val dsc_dats = [("#Given" ,["realTestGiven t_"]),
5.524 + ("#Find" ,["realTestFind s_"])
5.525 + ];
5.526 + val metIDs = [("SqRoot.thy","test_detail")];
5.527 + *)
5.528 +fun prep_pbt thy (pblID, dsc_dats: (string * (string list)) list,
5.529 + ev:rls, ca: term option, metIDs:metID list) =
5.530 + let fun eq f (f', _) = f = f';
5.531 + val gi = filter (eq "#Given") dsc_dats;
5.532 +(*val gi = [("#Given",["equality e_","solveFor v_"])]
5.533 + : (string * string list) list*)
5.534 + val gi = (case gi of
5.535 + [] => []
5.536 + | ((_,gi')::[]) =>
5.537 + ((map (split_did o term_of o the o (parse thy)) gi')
5.538 + handle _ => raise error
5.539 + ("prep_pbt: syntax error in '#Given' of "^
5.540 + (strs2str pblID)))
5.541 + | _ =>
5.542 + (raise error ("prep_pbt: more than one '#Given' in "^
5.543 + (strs2str pblID))));
5.544 +(*val gi =
5.545 + [(Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool")),
5.546 + (Const ("Descript.solveFor","RealDef.real => Tools.una"),
5.547 + Free ("v_","RealDef.real"))] : (term * term) list *)
5.548 + val gi = map (pair "#Given") gi;
5.549 +(*val gi =
5.550 + [("#Given",
5.551 + (Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool"))),
5.552 + ("#Given",
5.553 + (Const ("Descript.solveFor","RealDef.real => Tools.una"),
5.554 + Free ("v_","RealDef.real")))] : (string * (term * term)) list*)
5.555 +
5.556 + val fi = filter (eq "#Find") dsc_dats;
5.557 + val fi = (case fi of
5.558 + [] => [](*28.8.01: ["tool"] ...// raise error
5.559 + ("prep_pbt: no '#Find' in "^(strs2str pblID))*)
5.560 +(* val ((_,fi')::[]) = fi;
5.561 + *)
5.562 + | ((_,fi')::[]) =>
5.563 + ((map (split_did o term_of o the o (parse thy)) fi')
5.564 + handle _ => raise error
5.565 + ("prep_pbt: syntax error in '#Find' of "^
5.566 + (strs2str pblID)))
5.567 + | _ =>
5.568 + (raise error ("prep_pbt: more than one '#Find' in "^
5.569 + (strs2str pblID))));
5.570 + val fi = map (pair "#Find") fi;
5.571 +
5.572 + val re = filter (eq "#Relate") dsc_dats;
5.573 + val re = (case re of
5.574 + [] => []
5.575 + | ((_,re')::[]) =>
5.576 + ((map (split_did o term_of o the o (parse thy)) re')
5.577 + handle _ => raise error
5.578 + ("prep_pbt: syntax error in '#Relate' of "^
5.579 + (strs2str pblID)))
5.580 + | _ =>
5.581 + (raise error ("prep_pbt: more than one '#Relate' in "^
5.582 + (strs2str pblID))));
5.583 + val re = map (pair "#Relate") re;
5.584 +
5.585 + val wh = filter (eq "#Where") dsc_dats;
5.586 + val wh = (case wh of
5.587 + [] => []
5.588 + | ((_,wh')::[]) =>
5.589 + ((map (term_of o the o (parse thy)) wh')
5.590 + handle _ => raise error
5.591 + ("prep_pbt: syntax error in '#Where' of "^
5.592 + (strs2str pblID)))
5.593 + | _ =>
5.594 + (raise error ("prep_pbt: more than one '#Where' in "^
5.595 + (strs2str pblID))));
5.596 + in ({thy=thy,cas=ca,prls=ev,where_=wh,ppc= gi @ fi @ re,
5.597 + met=metIDs}, pblID):pbt * pblID end;
5.598 +(* prep_pbt thy (pblID, dsc_dats, metIDs);
5.599 + val it =
5.600 + ({met=[],
5.601 + ppc=[("#Given",(Const (#,#),Free (#,#))),
5.602 + ("#Given",(Const (#,#),Free (#,#))),
5.603 + ("#Find",(Const (#,#),Free (#,#)))],
5.604 + thy={ProtoPure, ..., Atools, RatArith},
5.605 + where_=[Const ("Descript.solutions","bool List.list => Tools.toreall") $
5.606 + Free ("v_i_","bool List.list")]},["equation"]) : pbt * pblID *)
5.607 +
5.608 +
5.609 +
5.610 +
5.611 +(*. prepare meth' for storage analogous to pbt .*)
5.612 +fun prep_met (metID, ppc: (string * string list) list (*'#Where' -> #pre*),
5.613 + {rew_ord'=ro, rls'=rls, srls=srls, prls=prls, calc = scr_isa_fns,
5.614 + asm_rls=ar, asm_thm=at}, scr) =
5.615 + let fun eq f (f', _) = f = f';
5.616 + val thy = (assoc_thy o fst) metID
5.617 + val gi = filter (eq "#Given") ppc;
5.618 + val gi = (case gi of
5.619 + [] => []
5.620 + | ((_,gi')::[]) =>
5.621 + ((map (split_did o term_of o the o (parse thy)) gi')
5.622 + handle _ => raise error
5.623 + ("prep_pbt: syntax error in '#Given' of "^
5.624 + (pair2str metID)))
5.625 + | _ =>
5.626 + (raise error ("prep_pbt: more than one '#Given' in "^
5.627 + (pair2str metID))));
5.628 + val gi = map (pair "#Given") gi;
5.629 +
5.630 + val fi = filter (eq "#Find") ppc;
5.631 + val fi = (case fi of
5.632 + [] => [](*28.8.01: ["tool"] ...// raise error
5.633 + ("prep_pbt: no '#Find' in "^(pair2str metID))*)
5.634 + | ((_,fi')::[]) =>
5.635 + ((map (split_did o term_of o the o (parse thy)) fi')
5.636 + handle _ => raise error
5.637 + ("prep_pbt: syntax error in '#Find' of "^
5.638 + (pair2str metID)))
5.639 + | _ =>
5.640 + (raise error ("prep_pbt: more than one '#Find' in "^
5.641 + (pair2str metID))));
5.642 + val fi = map (pair "#Find") fi;
5.643 +
5.644 + val re = filter (eq "#Relate") ppc;
5.645 + val re = (case re of
5.646 + [] => []
5.647 + | ((_,re')::[]) =>
5.648 + ((map (split_did o term_of o the o (parse thy)) re')
5.649 + handle _ => raise error
5.650 + ("prep_pbt: syntax error in '#Relate' of "^
5.651 + (pair2str metID)))
5.652 + | _ =>
5.653 + (raise error ("prep_pbt: more than one '#Relate' in "^
5.654 + (pair2str metID))));
5.655 + val re = map (pair "#Relate") re;
5.656 +
5.657 + val wh = filter (eq "#Where") ppc;
5.658 + val wh = (case wh of
5.659 + [] => []
5.660 + | ((_,wh')::[]) =>
5.661 + ((map (term_of o the o (parse thy)) wh')
5.662 + handle _ => raise error
5.663 + ("prep_pbt: syntax error in '#Where' of "^
5.664 + (pair2str metID)))
5.665 + | _ =>
5.666 + (raise error ("prep_pbt: more than one '#Where' in "^
5.667 + (pair2str metID))));
5.668 + val scr = Script (((inst_abs thy) o term_of o the o (parse thy)) scr)
5.669 + in (metID:metID,
5.670 + {ppc=gi@fi@re, pre=wh, rew_ord'=ro, erls=rls, srls=srls, prls=prls,
5.671 + calc = scr_isa_fns, asm_rls=ar, asm_thm=at, scr=scr}:meth')
5.672 + end;
5.673 +
5.674 +
5.675 +
5.676 +
5.677 +
5.678 +(**. get pblIDs of all entries in mat3D .**)
5.679 +
5.680 +
5.681 +fun format_pblID strl = enclose " [" "]" (commas_quote strl);
5.682 +fun format_pblIDl strll = enclose "[\n" "\n]\n"
5.683 + (space_implode ",\n" (map format_pblID strll));
5.684 +
5.685 +fun scan _ [] = [] (* no base case, for empty doms only *)
5.686 + | scan id ((Ptyp ((i,_,[])))::[]) = [id@[i]]
5.687 + | scan id ((Ptyp ((i,_,pl)))::[]) = scan (id@[i]) pl
5.688 + | scan id ((Ptyp ((i,_,[])))::ps) = [id@[i]] @(scan id ps)
5.689 + | scan id ((Ptyp ((i,_,pl)))::ps) =(scan (id@[i]) pl)@(scan id ps);
5.690 +
5.691 +fun show_ptyps () = (writeln o format_pblIDl o (scan [])) (!ptyps);
5.692 +(* ptyps:=[];
5.693 + show_ptyps();
5.694 + *)
5.695 +
5.696 +
5.697 +
5.698 +(*vvvvv---------- preparational work 8.01. UNUSED *)
5.699 +(**+ instantiate a problem-type +**)
5.700 +
5.701 +(*+ transform oris +*)
5.702 +
5.703 +fun coll_vats (vats, ((_,vs,_,_,_):ori)) = vats union vs;
5.704 +(*> coll_vats [11,22] (hd oris);
5.705 +val it = [22,11,1,2,3] : int list
5.706 +
5.707 +> foldl coll_vats ([],oris);
5.708 +val it = [1,2,3] : int list
5.709 +
5.710 +> val i=1;
5.711 +> filter ((curry (op mem) i) o #2) oris;
5.712 +val it =
5.713 + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
5.714 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
5.715 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
5.716 + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
5.717 + (6,[1],"#undef",Const (#,#),[Free #]),
5.718 + (9,[1,2],"#undef",Const (#,#),[# $ #]),
5.719 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])] : ori list *)
5.720 +
5.721 +fun filter_vat oris i = filter ((curry (op mem) i)o(#2:ori -> int list))oris;
5.722 +(*> map (filter_vat oris) [1,2,3];
5.723 +val it =
5.724 + [[(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
5.725 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
5.726 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
5.727 + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
5.728 + (6,[1],"#undef",Const (#,#),[Free #]),
5.729 + (9,[1,2],"#undef",Const (#,#),[# $ #]),
5.730 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])],
5.731 + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
5.732 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
5.733 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
5.734 + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
5.735 + (7,[2],"#undef",Const (#,#),[Free #]),
5.736 + (9,[1,2],"#undef",Const (#,#),[# $ #]),
5.737 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])],
5.738 + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
5.739 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
5.740 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
5.741 + (5,[3],"#Relate",Const (#,#),[# $ #,# $ #,# $ #]),
5.742 + (8,[3],"#undef",Const (#,#),[Free #]),
5.743 + (10,[3],"#undef",Const (#,#),[# $ #]),
5.744 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])]] : ori list list*)
5.745 +
5.746 +
5.747 +fun separate_vats oris =
5.748 + let val vats = foldl coll_vats ([],oris);
5.749 + in map (filter_vat oris) vats end;
5.750 +(*^^^ end preparational work 8.01.*)
5.751 +
5.752 +
5.753 +
5.754 +(**. check a problem (ie. itm list) for matching a problemtype .**)
5.755 +
5.756 +fun eq1 d (_,(d',_)) = (d = d');
5.757 +fun itm_id ((i,_,_,_,_):itm) = i;
5.758 +fun ori_id ((i,_,_,_,_):ori) = i;
5.759 +fun ori2itmSup ((i,v,_,d,ts):ori) = ((i,v,true,"#Given",Sup(d,ts)):itm);
5.760 +(*see + add_sel_ppc ~~~~~~~*)
5.761 +fun field_eq f ((_,_,f',_,_):ori) = f = f';
5.762 +
5.763 +(*. check an item (with arbitrary itm_ from previous matchings)
5.764 + for matching a problemtype; returns true only for itms found in pbt .*)
5.765 +fun chk_ thy pbt ((i,vats,b,f,Cor ((d,vs),_)):itm) =
5.766 + (case find_first (eq1 d) pbt of
5.767 + Some (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
5.768 + (id, pbl_ids' d vs))):itm)
5.769 + | None => (i,vats,false,f,Sup (d,vs)))
5.770 + | chk_ thy pbt ((i,vats,b,f,Inc ((d,vs),_)):itm) =
5.771 + (case find_first (eq1 d) pbt of
5.772 + Some (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
5.773 + (id, pbl_ids' d vs))):itm)
5.774 + | None => (i,vats,false,f,Sup (d,vs)))
5.775 +
5.776 + | chk_ thy pbt (itm as (i,vats,b,f,Syn ct):itm) = itm
5.777 + | chk_ thy pbt (itm as (i,vats,b,f,Typ ct):itm) = itm
5.778 +
5.779 + | chk_ thy pbt ((i,vats,b,f,Sup (d,vs)):itm) =
5.780 + (case find_first (eq1 d) pbt of
5.781 + Some (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
5.782 + (id, pbl_ids' d vs))):itm)
5.783 + | None => (i,vats,false,f,Sup (d,vs)))
5.784 +(* val (i,vats,b,f,Mis (d,vs)) = i4;
5.785 + *)
5.786 + | chk_ thy pbt ((i,vats,b,f,Mis (d,vs)):itm) =
5.787 + (case find_first (eq1 d) pbt of
5.788 +(* val Some (_,(_,id)) = find_first (eq1 d) pbt;
5.789 + *)
5.790 + Some (_,(_,id)) => raise error "chk_: ((i,vats,b,f,Cor ((d,vs),\
5.791 + \(id, pbl_ids' d vs))):itm)"
5.792 + | None => (i,vats,false,f,Sup (d,[vs])));
5.793 +
5.794 +(* chk_ thy pbt i
5.795 + *)
5.796 +
5.797 +(*. for the user .*)
5.798 +datatype match' =
5.799 + Matches' of item ppc
5.800 +| NoMatch' of item ppc;
5.801 +
5.802 +fun eq2 (_,(d,_)) ((_,_,_,_,itm_):itm) = d = d_in itm_;
5.803 +fun eq2' (_,(d,_)) ((_,_,_,d',_):ori) = d = d';
5.804 +fun eq0 ((0,_,_,_,_):itm) = true
5.805 + | eq0 _ = false;
5.806 +fun max_i i [] = i
5.807 + | max_i i ((id,_,_,_,_)::is) =
5.808 + if i > id then max_i i is else max_i id is;
5.809 +fun max_id [] = 0
5.810 + | max_id ((id,_,_,_,_)::is) = max_i id is;
5.811 +fun add_idvat itms _ _ [] = itms
5.812 + | add_idvat itms i mvat (((_,_,b,f,itm_):itm)::its) =
5.813 + add_idvat (itms @ [(i,[(*mvat ...meaningless with pbl-identifier *)
5.814 + ],b,f,itm_):itm]) (i+1) mvat its;
5.815 +
5.816 +
5.817 +(*. find elements of pbt not contained in itms;
5.818 + if such one is untouched, return this one, otherwise create new itm .*)
5.819 +fun chk_m (itms:itm list) untouched (p as (f,(d,id))) =
5.820 + case find_first (eq2 p) itms of
5.821 + Some _ => []
5.822 + | None => (case find_first (eq2 p) untouched of
5.823 + Some itm => [itm]
5.824 + | None => [(0,[],false,f,Mis (d,id)):itm]);
5.825 +(* val itms = itms'';
5.826 + *)
5.827 +fun chk_mis mvat itms untouched pbt =
5.828 + let val mis = (flat o (map (chk_m itms untouched))) pbt;
5.829 + val mid = max_id itms;
5.830 + in add_idvat [] (mid + 1) mvat mis end;
5.831 +
5.832 +(*. check a problem (ie. itm list) for matching a problemtype,
5.833 + takes the max_vt for concluding completeness (could be another!) .*)
5.834 +(* val itms = itms'; val (pbt,pre) = (ppc, pre);
5.835 + val itms = itms; val (pbt,pre) = (ppc, pre);
5.836 + *)
5.837 +fun match_itms thy itms (pbt,pre,prls) =
5.838 + (let fun okv mvat (_,vats,b,_,_) = mvat mem vats andalso b;
5.839 + val itms' = map (chk_ thy pbt) itms; (*all found are #3 true*)
5.840 + val mvat = max_vt itms';
5.841 + val itms'' = filter (okv mvat) itms';
5.842 + val untouched = filter eq0 itms;(*i.e. dsc only (from init)*)
5.843 + val mis = chk_mis mvat itms'' untouched pbt;
5.844 + val (pre', pb) = check_preconds' prls pre itms'' mvat;
5.845 + in (length mis = 0 andalso pb, (itms'@ mis, pre')) end)
5.846 +
5.847 +(*. check a problem pbl (ie. itm list) for matching a problemtype pbt,
5.848 + for missing items get data from formalization (ie. ori list);
5.849 + takes the max_vt for concluding completeness (could be another!) .*)
5.850 +(* (0) determine the most frequent variant mv in pbl
5.851 + ALL pbt. (1) dsc(pbt) notmem dsc(pbls) =>
5.852 + (2) filter (dsc(pbt) = dsc(oris)) oris; -> news;
5.853 + (3) newitms = filter (mv mem vat(news)) news
5.854 + (4) pbt @ newitms *)
5.855 +(* val (pbl, pbt, pre) = (met, mtt, pre);
5.856 + val (pbl, pbt, pre) = (itms, #ppc pbt, #where_ pbt);
5.857 + *)
5.858 +fun match_itms_oris thy (pbl:itm list) (pbt, pre, prls) oris =
5.859 + let
5.860 + (*0*)val mv = max_vt pbl;
5.861 +
5.862 + fun eqdsc_pbt_itm ((_,(d,_))) ((_,_,_,_,itm_):itm) = d = d_in itm_;
5.863 + fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of
5.864 + Some _ => false | None => true;
5.865 + (*1*)val mis = (*(map (cons2 (fst, fst o snd)))o*) (filter (notmem pbl)) pbt;
5.866 +
5.867 + fun eqdsc_ori (_,(d,_)) ((_,_,_,d',_):ori) = d = d';
5.868 + fun ori2itmMis (f,(d,pid)) ((i,v,_,_,ts):ori) =
5.869 + (i,v,false,f,Mis (d,pid)):itm;
5.870 + (*2*)fun oris2itms oris mis1 =
5.871 + ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris;
5.872 + val news = (flat o (map (oris2itms oris))) mis;
5.873 + (*3*)fun mem_vat (_,vats,b,_,_) = mv mem vats;
5.874 + val newitms = filter mem_vat news;
5.875 + (*4*)val itms' = pbl @ newitms;
5.876 + val (pre', pb) = check_preconds' prls pre itms' mv;
5.877 + in (length mis = 0 andalso pb, (itms', pre')) end;
5.878 + (*handle _ => (false,([],[]))*);
5.879 +
5.880 +
5.881 +(*vvv--- doubled 20.9.01: ... 7.3.02 itms --> oris, because oris
5.882 + allow for faster access to descriptions and terms *)
5.883 +(**. check a problem (ie. itm list) for matching a problemtype .**)
5.884 +
5.885 +(*. check an ori for matching a problemtype by description;
5.886 + returns true only for itms found in pbt .*)
5.887 +fun chk1_ pbt ((i,vats,f,d,vs):ori) =
5.888 + case find_first (eq1 d) pbt of
5.889 + Some (_,(_,id)) => [(i,vats,true,f,
5.890 + Cor ((d,vs), (id, pbl_ids' d vs))):itm]
5.891 + | None => [];
5.892 +
5.893 +(* elem 'p' of pbt contained in itms ? *)
5.894 +fun chk1_m (itms:itm list) p =
5.895 + case find_first (eq2 p) itms of
5.896 + Some _ => true | None => false;
5.897 +fun chk1_m' (oris: ori list) (p as (f,(d,t))) =
5.898 + case find_first (eq2' p) oris of
5.899 + Some _ => []
5.900 + | None => [(f, Mis (d, t))];
5.901 +fun pair0vatsfalse (f,itm_) = (0,[],false,f,itm_):itm;
5.902 +
5.903 +fun chk1_mis mvat itms ppc = foldl and_ (true, map (chk1_m itms) ppc);
5.904 +fun chk1_mis' oris ppc =
5.905 + map pair0vatsfalse ((flat o (map (chk1_m' oris))) ppc);
5.906 +
5.907 +
5.908 +(*. check a problem (ie. ori list) for matching a problemtype,
5.909 + takes the max_vt for concluding completeness (FIXME could be another!) .*)
5.910 +(* val (prls,oris,pbt,pre)=(#prls py, ori, #ppc py, #where_ py);
5.911 + *)
5.912 +fun match_oris prls oris (pbt,pre) =
5.913 + let val itms = (flat o (map (chk1_ pbt))) oris;
5.914 + val mvat = max_vt itms;
5.915 + val complete = chk1_mis mvat itms pbt;
5.916 + val (pre', pb) = check_preconds' prls pre itms mvat;
5.917 + in if complete andalso pb then true else false end;
5.918 +(*run subp-rooteq.sml 'root-eq + subpbl: solve_linear'
5.919 + until 'val nxt = ("Model_Problem",Model_Problem ["linear","univariate"...
5.920 +> val Nd(PblObj _,[_,_,_,_,_,_,_,_,_,_,_,
5.921 + Nd(PblObj{origin=(oris,_),...},[])]) = pt;
5.922 +> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"],
5.923 + (#where_ o get_pbt) ["linear","univariate","equation"]);
5.924 +> match_oris oris (pbt,pre);
5.925 +val it = true : bool
5.926 +
5.927 +
5.928 +> val (pbt,pre) =((#ppc o get_pbt) ["plain_square","univariate","equation"],
5.929 + (#where_ o get_pbt)["plain_square","univariate","equation"]);
5.930 +> match_oris oris (pbt,pre);
5.931 +val it = false : bool
5.932 +
5.933 +
5.934 + ---------------------------------------------------
5.935 + run subp-rooteq.sml 'root-eq + subpbl: solve_plain_square'
5.936 + until 'val nxt = ("Model_Problem",Model_Problem ["plain_square","univ...
5.937 +> val Nd (PblObj _, [_,_,_,_,_,_,_,Nd (PrfObj _,[]),
5.938 + Nd (PblObj {origin=(oris,_),...},[])]) = pt;
5.939 +> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"],
5.940 + (#where_ o get_pbt) ["linear","univariate","equation"]);
5.941 +> match_oris oris (pbt,pre);
5.942 +val it = false : bool
5.943 +
5.944 +
5.945 +> val (pbt,pre)=((#ppc o get_pbt) ["plain_square","univariate","equation"],
5.946 + (#where_ o get_pbt) ["plain_square","univariate","equation"]);
5.947 +> match_oris oris (pbt,pre);
5.948 +val it = true : bool
5.949 +*)
5.950 +(*^^^--- doubled 20.9.01 *)
5.951 +
5.952 +
5.953 +(*. check a problem (ie. ori list) for matching a problemtype,
5.954 + returns items for output to math-experts .*)
5.955 +(* val (ppc,pre) = (#ppc py, #where_ py);
5.956 + *)
5.957 +fun match_oris' thy oris (ppc,pre,prls) =
5.958 + let val itms = (flat o (map (chk1_ ppc))) oris;
5.959 + val sups = ((map ori2itmSup) o (filter(field_eq "#undef")))oris;
5.960 + val mvat = max_vt itms;
5.961 + val miss = chk1_mis' oris ppc;
5.962 + val (pre', pb) = check_preconds' prls pre itms mvat;
5.963 + in (miss = [] andalso pb, (itms @ miss @ sups, pre')) end;
5.964 +
5.965 +type fmz = string list;
5.966 +
5.967 +(*. match a formalization with a problem type .*)
5.968 +fun match_pbl (fmz:fmz) ({thy=thy,where_=pre,ppc,prls=er,...}:pbt) =
5.969 + let val oris = prep_ori fmz thy ppc;
5.970 + val (bool, (itms, pre')) = match_oris' thy oris (ppc,pre,er);
5.971 + in if bool then Matches' (itms2itemppc thy itms pre')
5.972 + else NoMatch' (itms2itemppc thy itms pre') end;
5.973 +(*
5.974 +val fmz = ["equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))",
5.975 + "solveFor x","errorBound (eps=0)","solutions L"];
5.976 +val pbt as {thy = thy, where_ = pre, ppc = ppc,...} =
5.977 + get_pbt ["univariate","equation"];
5.978 +match_pbl fmz pbt;
5.979 +*)
5.980 +
5.981 +
5.982 +(*. refine a problem; construct pblRD while scanning .*)
5.983 +(* val (pblRD,ori)=("xxx",oris);
5.984 + val py = get_pbt ["equation"];
5.985 + val py = get_pbt ["univariate","equation"];
5.986 + val py = get_pbt ["linear","univariate","equation"];
5.987 + val py = get_pbt ["root","univariate","equation"];
5.988 + match_oris (#prls py) ori (#ppc py, #where_ py);
5.989 +
5.990 + *)
5.991 +fun refin (pblRD:pblRD) ori
5.992 +((Ptyp (pI,[py],[])):ptyp) =
5.993 + if match_oris (#prls py) ori (#ppc py, #where_ py)
5.994 + then Some ((pblRD @ [pI]):pblRD)
5.995 + else None
5.996 + | refin pblRD ori (Ptyp (pI,[py],pys)) =
5.997 + if match_oris (#prls py) ori (#ppc py, #where_ py)
5.998 + then (case refins (pblRD @ [pI]) ori pys of
5.999 + Some pblRD' => Some pblRD'
5.1000 + | None => Some (pblRD @ [pI]))
5.1001 + else None
5.1002 +and refins pblRD ori [] = None
5.1003 + | refins pblRD ori ((p as Ptyp (pI,_,_))::pts) =
5.1004 + (case refin pblRD ori p of
5.1005 + Some pblRD' => Some pblRD'
5.1006 + | None => refins pblRD ori pts);
5.1007 +
5.1008 +(*. refine a problem; version providing output for math-experts .*)
5.1009 +fun refin' (pblRD:pblRD) fmz pbls ((Ptyp (pI,[py],[])):ptyp) =
5.1010 + let val _ = (writeln o ((curry op^)"*** pass ") o strs2str)(pblRD @ [pI])
5.1011 + val {thy,ppc,where_,prls,...} = py
5.1012 + val oris = prep_ori fmz thy ppc
5.1013 + (*8.3.02: itms!: oris ev. are _not_ complete here*)
5.1014 + val (b, (itms, pre')) = match_oris' thy oris (ppc, where_, prls)
5.1015 + in if b then pbls @ [Matches (rev (pblRD @ [pI]),
5.1016 + itms2itemppc thy itms pre')]
5.1017 + else pbls @ [NoMatch (rev (pblRD @ [pI]),
5.1018 + itms2itemppc thy itms pre')]
5.1019 + end
5.1020 +(* val pblRD = ["pbla"]; val fmz = fmz1; val pbls = [];
5.1021 + val Ptyp (pI,[py],pys) = hd (!ptyps);
5.1022 + refin' pblRD fmz pbls (Ptyp (pI,[py],pys));
5.1023 +*)
5.1024 + | refin' pblRD fmz pbls (Ptyp (pI,[py],pys)) =
5.1025 + let val _ = (writeln o ((curry op^)"*** pass ") o strs2str) (pblRD @ [pI])
5.1026 + val {thy,ppc,where_,prls,...} = py
5.1027 + val oris = prep_ori fmz thy ppc;
5.1028 + (*8.3.02: itms!: oris ev. are _not_ complete here*)
5.1029 + val(b, (itms, pre')) = match_oris' thy oris (ppc,where_,prls);
5.1030 + in if b
5.1031 + then let val pbl = Matches (rev (pblRD @ [pI]),
5.1032 + itms2itemppc thy itms pre')
5.1033 + in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end
5.1034 + else (pbls @ [NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')])
5.1035 + end
5.1036 +and refins' pblRD fmz pbls [] = pbls
5.1037 + | refins' pblRD fmz pbls ((p as Ptyp (pI,_,_))::pts) =
5.1038 + let val pbls' = refin' pblRD fmz pbls p
5.1039 + in case last_elem pbls' of
5.1040 + Matches _ => pbls'
5.1041 + | NoMatch _ => refins' pblRD fmz pbls' pts end;
5.1042 +
5.1043 +(*. refine a problem; version for tactic Refine_Problem .*)
5.1044 +fun refin'' thy (pblRD:pblRD) itms pbls ((Ptyp (pI,[py],[])):ptyp) =
5.1045 + let (*val _ = writeln("### refin''1: pI="^pI);*)
5.1046 + val {thy,ppc,where_,prls,...} = py
5.1047 + val (b, (itms', pre')) = match_itms thy itms (ppc,where_,prls);
5.1048 + in if b then pbls @ [Matches (rev (pblRD @ [pI]),
5.1049 + itms2itemppc thy itms' pre')]
5.1050 + else pbls @ [NoMatch (rev (pblRD @ [pI]),
5.1051 + itms2itemppc thy itms' pre')]
5.1052 + end
5.1053 +(* val pblRD = (rev o tl) pblID; val pbls = [];
5.1054 + val Ptyp (pI,[py],pys) = app_ptyp I pblID (rev pblID) (!ptyps);
5.1055 + *)
5.1056 + | refin'' thy pblRD itms pbls (Ptyp (pI,[py],pys)) =
5.1057 + let (*val _ = writeln("### refin''2: pI="^pI);*)
5.1058 + val {thy,ppc,where_,prls,...} = py
5.1059 + val(b, (itms', pre')) = match_itms thy itms (ppc,where_,prls);
5.1060 + in if b
5.1061 + then let val pbl = Matches (rev (pblRD @ [pI]),
5.1062 + itms2itemppc thy itms' pre')
5.1063 + in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end
5.1064 + else (pbls @ [NoMatch (rev (pblRD @ [pI]),itms2itemppc thy itms' pre')])
5.1065 + end
5.1066 +and refins'' thy pblRD itms pbls [] = pbls
5.1067 + | refins'' thy pblRD itms pbls ((p as Ptyp (pI,_,_))::pts) =
5.1068 + let val pbls' = refin'' thy pblRD itms pbls p
5.1069 + in case last_elem pbls' of
5.1070 + Matches _ => pbls'
5.1071 + | NoMatch _ => refins'' thy pblRD itms pbls' pts end;
5.1072 +
5.1073 +
5.1074 +(*. apply a fun to a ptyps node; copied from get_py .*)
5.1075 +fun app_ptyp f (d:pblID) _ [] =
5.1076 + raise error ("get_pbt not found: "^(strs2str d))
5.1077 + | app_ptyp f d (k::[]) ((p as Ptyp (k',[py],_))::pys) =
5.1078 + if k=k' then f p
5.1079 + else app_ptyp f d ([k]:pblRD) pys
5.1080 + | app_ptyp f d (k::ks) ((Ptyp (k',_,pys))::pys') =
5.1081 + if k=k' then app_ptyp f d ks pys
5.1082 + else app_ptyp f d (k::ks) pys';
5.1083 +
5.1084 +(*. for tactic Refine_Tacitly .*)
5.1085 +(*!!! oris are parsed, pbt contains thy for parsing*)
5.1086 +(* val (thy,pblID) = (assoc_thy dI',pI);
5.1087 + *)
5.1088 +fun refine_ori oris (pblID:pblID) =
5.1089 + let val opt = app_ptyp (refin ((rev o tl) pblID) oris)
5.1090 + pblID (rev pblID) (!ptyps);
5.1091 + in case opt of
5.1092 + Some pblRD => let val (pblID':pblID) =(rev pblRD)
5.1093 + in if pblID' = pblID then None
5.1094 + else Some pblID' end
5.1095 + | None => None end;
5.1096 +
5.1097 +(*. for tactic Refine_Problem .*)
5.1098 +(* val pblID = pI; app_ptyp I pblID (rev pblID) (!ptyps);
5.1099 + *)
5.1100 +fun refine_pbl thy (pblID:pblID) itms =
5.1101 + app_ptyp (refin'' thy ((rev o tl) pblID) itms [])
5.1102 + pblID (rev pblID) (!ptyps);
5.1103 +
5.1104 +
5.1105 +(*. for math-experts .*)
5.1106 +(*19.10.02FIXME: needs thy for parsing fmz*)
5.1107 +(* val fmz = fmz1; val pblID = ["pbla"]; val pblRD = (rev o tl) pblID;
5.1108 + val pbls = []; val ptys = !ptyps;
5.1109 + *)
5.1110 +fun refine (fmz:fmz) (pblID:pblID) =
5.1111 + app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID) (!ptyps);
6.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2 +++ b/src/sml/ME/script.sml Thu Apr 17 18:01:03 2003 +0200
6.3 @@ -0,0 +1,1822 @@
6.4 +(* use"../ME/script.sml";
6.5 + use"ME/script.sml";
6.6 + use"script.sml";
6.7 + *)
6.8 +
6.9 +signature INTERPRETER =
6.10 +sig
6.11 + (*type ets (list of executed tactics) see sequent.sml*)
6.12 +
6.13 + datatype locate
6.14 + = NotLocatable
6.15 + | Steps of (mstep' * mout * ptree * pos' * cid * safe (* ets*)) list
6.16 +(* | ToDo of ets 28.4.02*)
6.17 +
6.18 + (*diss: next-tactic-function*)
6.19 + val next_tac : theory' -> ptree * pos' -> metID -> scr -> ets -> mstep
6.20 + (*diss: locate-function*)
6.21 + val locate_gen : theory'
6.22 + -> mstep'
6.23 + -> ptree * pos' -> scr * rls -> ets -> loc_ -> locate
6.24 +
6.25 + val sel_rules : ptree -> pos' -> mstep list
6.26 + val init_form : scr -> ets -> loc_ * term option
6.27 + val actual_args : term -> term list
6.28 +
6.29 + (*shift to library ...*)
6.30 + val inst_abs : theory' -> term -> term
6.31 + val itms2args : metID -> itm list -> term list
6.32 + val user_interrupt : loc_ * (mstep' * env * env * term * term * safe)
6.33 + (*val empty : term*)
6.34 +end
6.35 +
6.36 +
6.37 +
6.38 +
6.39 +(*
6.40 +structure Interpreter : INTERPRETER =
6.41 +struct
6.42 +*)
6.43 +
6.44 +val string_of_thm' = (implode o tl o drop_last o explode o string_of_thm);
6.45 +(*
6.46 + string_of_thm sym;
6.47 +val it = "\"?s = ?t ==> ?t = ?s\"" : string
6.48 + string_of_thm' sym;
6.49 +val it = "?s = ?t ==> ?t = ?s" : string*)
6.50 +
6.51 +type step = (*data for creating a new node in the ptree;
6.52 + designed for use:
6.53 + fun ass* scrstate steps =
6.54 + ... case ass* scrstate steps of
6.55 + Assoc (scrstate, steps) => ... ass* scrstate steps*)
6.56 + mstep' (*transformed from associated tac*)
6.57 + * mout (*result with indentation etc.*)
6.58 + * ptree (*containing node created by mstep' + resp. scrstate*)
6.59 + * pos' (*position in ptree; ptree * pos' is the proofstate*)
6.60 + * cid(*pos' list TODO*);(*of ptree-nodes ev. cut (by fst mstep')*)
6.61 +
6.62 +fun rule2thm' (Thm (id, thm)) = (id, string_of_thm thm):thm'
6.63 + | rule2thm' r = raise error ("rule2thm': not defined for "^(rule2str r));
6.64 +
6.65 +(*.makes a (rule,term) list to a Step (m, mout, pt', p', cid) for solve;
6.66 + complicated with current t in rrlsstate.*)
6.67 +fun rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) [(r, (f', am))] =
6.68 + let val thy = assoc_thy thy'
6.69 + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
6.70 + val is = RrlsState (f',f'',rss,rts)
6.71 + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
6.72 + val (p', cid, mout, pt') = generate1 thy m is p pt
6.73 + in (is, (m, mout, pt', p', cid)::steps) end
6.74 + | rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa))
6.75 + ((r, (f', am))::rts') =
6.76 + let val thy = assoc_thy thy'
6.77 + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
6.78 + val is = RrlsState (f',f'',rss,rts)
6.79 + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
6.80 + val (p', cid, mout, pt') = generate1 thy m is p pt
6.81 + in rts2steps ((m, mout, pt', p', cid)::steps)
6.82 + ((pt',p'),(f',f'',rss,rts),(thy',ro,er,pa)) rts' end;
6.83 +
6.84 +
6.85 +val trace_locate = ref false; (*23.11.01*)
6.86 +
6.87 +(*. functions for the environment stack .*)
6.88 +fun accessenv id es = the (assoc((top es):env, id))
6.89 + handle _ => error ("accessenv: "^(free2str id)^" not in env");
6.90 +fun updateenv id vl (es:env stack) =
6.91 + (push (overwrite(top es, (id, vl))) (pop es)):env stack;
6.92 +fun pushenv id vl (es:env stack) =
6.93 + (push (overwrite(top es, (id, vl))) es):env stack;
6.94 +val popenv = pop:env stack -> env stack;
6.95 +
6.96 +
6.97 +
6.98 +(*
6.99 +fun envETR2str thy' (_,(ens,env,iar,res,s)) = subst2str' thy' env;
6.100 +fun resETR2str thy' (_,(ens,env,iar,res,s)) =
6.101 + Sign.string_of_term (sign_of (assoc_thy thy')) res;----------------*)
6.102 +
6.103 +
6.104 +(*val empty = Const ("empty",HOLogic.realT);
6.105 +val user_interrupt = ([]:loc_,(User', []:env, []:env, empty, empty, Sundef));*)
6.106 +fun de_esc_underscore str =
6.107 + let fun scan [] = []
6.108 + | scan (s::ss) = if s = "'" then (scan ss)
6.109 + else (s::(scan ss))
6.110 + in (implode o scan o explode) str end;
6.111 +(*
6.112 +> val str = "Rewrite_Set_Inst";
6.113 +> val esc = esc_underscore str;
6.114 +val it = "Rewrite'_Set'_Inst" : string
6.115 +> val des = de_esc_underscore esc;
6.116 + val des = de_esc_underscore esc;*)
6.117 +
6.118 +fun is_listexpr t =
6.119 + (((ids_of o head_of) t) inter (!listexpr)) <> [];
6.120 +
6.121 +
6.122 +(*go at a location in a script and fetch the contents*)
6.123 +fun go [] t = t
6.124 + | go (D::p) (Abs(s,ty,t0)) = go (p:loc_) t0
6.125 + | go (L::p) (t1 $ t2) = go p t1
6.126 + | go (R::p) (t1 $ t2) = go p t2
6.127 + | go l _ = raise error ("go: no "^(loc_2str l));
6.128 +(*
6.129 +> val t = (term_of o the o (parse thy)) "a+b";
6.130 +val it = Const (#,#) $ Free (#,#) $ Free ("b","RealDef.real") : term
6.131 +> val plus_a = go [L] t;
6.132 +> val b = go [R] t;
6.133 +> val plus = go [L,L] t;
6.134 +> val a = go [L,R] t;
6.135 +
6.136 +> val t = (term_of o the o (parse thy)) "a+b+c";
6.137 +val t = Const (#,#) $ (# $ # $ Free #) $ Free ("c","RealDef.real") : term
6.138 +> val pl_pl_a_b = go [L] t;
6.139 +> val c = go [R] t;
6.140 +> val a = go [L,R,L,R] t;
6.141 +> val b = go [L,R,R] t;
6.142 +*)
6.143 +
6.144 +
6.145 +(* get a subterm t with test t, and record location *)
6.146 +fun get l test (t as Const (s,T)) =
6.147 + if test t then Some (l,t) else None
6.148 + | get l test (t as Free (s,T)) =
6.149 + if test t then Some (l,t) else None
6.150 + | get l test (t as Bound n) =
6.151 + if test t then Some (l,t) else None
6.152 + | get l test (t as Var (s,T)) =
6.153 + if test t then Some (l,t) else None
6.154 + | get l test (t as Abs (s,T,body)) =
6.155 + if test t then Some (l:loc_,t) else get ((l@[D]):loc_) test body
6.156 + | get l test (t as t1 $ t2) =
6.157 + if test t then Some (l,t)
6.158 + else case get (l@[L]) test t1 of
6.159 + None => get (l@[R]) test t2
6.160 + | Some (l',t') => Some (l',t');
6.161 +(*18.6.00
6.162 +> val sss = ((term_of o the o (parse thy))
6.163 + "Script Solve_root_equation (eq_::bool) (v_::real) (err_::bool) =\
6.164 + \ (let e_ = Try (Rewrite square_equation_left True eq_) \
6.165 + \ in [e_])");
6.166 + ______ compares head_of !!
6.167 +> get [] (eq_str "Let") sss; [R]
6.168 +> get [] (eq_str "Script.Try") sss; [R,L,R]
6.169 +> get [] (eq_str "Script.Rewrite") sss; [R,L,R,R]
6.170 +> get [] (eq_str "True") sss; [R,L,R,R,L,R]
6.171 +> get [] (eq_str "e_") sss; [R,R]
6.172 +*)
6.173 +
6.174 +fun test_negotiable t = ((strip_thy o (term_str Script.thy) o head_of) t)
6.175 + mem (!negotiable);
6.176 +
6.177 +(*30.4.02: vvv--- doesnt work with curried functions ---> get_tac ------
6.178 +(*18.6.00: below _ALL_ negotiables must be in fun-patterns !
6.179 + then the last (non)pattern must be a subproblem*)
6.180 +fun init_frm thy (Const ("Script.Rewrite",_) $ _ $ _ $ eq) = Some eq
6.181 + | init_frm thy (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ eq) = Some eq
6.182 + | init_frm thy (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ eq) = Some eq
6.183 + | init_frm thy (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ eq) =
6.184 + Some eq
6.185 + | init_frm thy (Const ("Script.Calculate",_) $ _ $ t) = Some t
6.186 + | init_frm thy t =
6.187 + (*if ((strip_thy o (term_str thy) o head_of) t) mem (!subpbls)
6.188 + then None
6.189 + else *)raise error ("init_frm: not impl. for "^
6.190 + (Sign.string_of_term (sign_of thy) t));
6.191 +
6.192 +> val t = (term_of o the o (parse thy))
6.193 + "Rewrite square_equation_left True (sqrt(#9+#4*x)=sqrt x + sqrt(#5+x))";
6.194 +> val Some ini = init_frm thy t;
6.195 +> Sign.string_of_term (sign_of thy) ini;
6.196 +val it = "sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)" : string
6.197 +
6.198 +> val t = (term_of o the o (parse thy))
6.199 + "solve_univar (Reals, [univar,equation], no_met) e1_ v1_";
6.200 +> val ini = init_frm thy t;
6.201 +> Sign.string_of_term (sign_of thy) ini;
6.202 +val it = "empty" : string
6.203 +
6.204 +> val t = (term_of o the o (parse thy))
6.205 + "Rewrite_Set norm_equation False x + #1 = #2";
6.206 +> val Some ini = init_frm thy t;
6.207 +> Sign.string_of_term (sign_of thy) ini;
6.208 +val it = "x + #1 = #2" : string
6.209 +
6.210 +> val t = (term_of o the o (parse thy))
6.211 + "Rewrite_Set_Inst [(bdv,x)] isolate_bdv False x + #1 = #2";
6.212 +> val Some ini = init_frm thy t;
6.213 +> Sign.string_of_term (sign_of thy) ini;
6.214 +val it = "x + #1 = #2" : string *)
6.215 +
6.216 +
6.217 +(*get argument of first tactic in a script for init_form*)
6.218 +fun get_tac thy (h $ body) =
6.219 + let
6.220 + fun get_t y (Const ("Script.Seq",_) $ e1 $ e2) a =
6.221 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.222 + | get_t y (Const ("Script.Seq",_) $ e1 $ e2 $ a) _ =
6.223 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.224 + | get_t y (Const ("Script.Try",_) $ e) a = get_t y e a
6.225 + | get_t y (Const ("Script.Try",_) $ e $ a) _ = get_t y e a
6.226 + | get_t y (Const ("Script.Repeat",_) $ e) a = get_t y e a
6.227 + | get_t y (Const ("Script.Repeat",_) $ e $ a) _ = get_t y e a
6.228 + | get_t y (Const ("Script.Or",_) $e1 $ e2) a =
6.229 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.230 + | get_t y (Const ("Script.Or",_) $e1 $ e2 $ a) _ =
6.231 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.232 + | get_t y (Const ("Script.While",_) $ c $ e) a = get_t y e a
6.233 + | get_t y (Const ("Script.While",_) $ c $ e $ a) _ = get_t y e a
6.234 + | get_t y (Const ("Script.Letpar",_) $ e1 $ Abs (_,_,e2)) a =
6.235 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.236 + | get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
6.237 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.238 + | get_t y (Const ("If",_) $ c $ e1 $ e2) a =
6.239 + (case get_t y e1 a of None => get_t y e2 a | la => la)
6.240 + | get_t y (Abs (_,_,e)) a = get_t y e a
6.241 +
6.242 + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ $ a) _ = Some a
6.243 + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ ) a = Some a
6.244 + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ a) _ = Some a
6.245 + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ ) a = Some a
6.246 + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ a) _ = Some a
6.247 + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ ) a = Some a
6.248 + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $a)_ =Some a
6.249 + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ ) a =Some a
6.250 + | get_t y (Const ("Script.Calculate",_) $ _ $ a) _ = Some a
6.251 + | get_t y (Const ("Script.Calculate",_) $ _ ) a = Some a
6.252 +
6.253 + | get_t y (Const ("Script.Substitute",_) $ _ $ a) _ = Some a
6.254 + | get_t y (Const ("Script.Substitute",_) $ _ ) a = Some a
6.255 +
6.256 + | get_t y (Const ("Script.SubProblem",_) $ _ $ _) _ = None
6.257 +
6.258 + | get_t y x _ = raise error ("get_t yac: not defined for "^
6.259 + (Sign.string_of_term (sign_of y) x))
6.260 +in get_t thy body e_term end;
6.261 +
6.262 +(*FIXME: get 1st tac by next_tac [] instead of ... ?? 29.7.02*)
6.263 +(* val (Script sc,((_,(_,_,env,_,_,_))::_)) = (scr,ets);
6.264 + *)
6.265 +fun init_form thy (Script sc) env =
6.266 + (case get_tac thy sc of
6.267 + None => None (*raise error ("init_form: no 1st tac in "^
6.268 + (Sign.string_of_term (sign_of thy) sc))*)
6.269 + | Some tac => Some (subst_atomic env tac))
6.270 + | init_form _ _ _ = raise error "init_form: no match";
6.271 +
6.272 +(* use"ME/script.sml";
6.273 + use"script.sml";
6.274 + *)
6.275 +
6.276 +
6.277 +
6.278 +(*the 'iteration-argument' of a tac (args not eval)*)
6.279 +fun itr_arg _ (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ v) = v
6.280 + | itr_arg _ (Const ("Script.Rewrite",_) $ _ $ _ $ v) = v
6.281 + | itr_arg _ (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ v) = v
6.282 + | itr_arg _ (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ v) = v
6.283 + | itr_arg _ (Const ("Script.Calculate",_) $ _ $ v) = v
6.284 + | itr_arg _ (Const ("Script.Check'_elementwise",_) $ consts $ _) = consts
6.285 + | itr_arg _ (Const ("Script.Or'_to'_List",_) $ _) = e_term
6.286 + | itr_arg _ (Const ("Script.Mstep",_) $ _) = e_term
6.287 + | itr_arg _ (Const ("Script.SubProblem",_) $ _ $ _) = e_term
6.288 + | itr_arg thy t = raise error
6.289 + ("itr_arg not impl. for "^
6.290 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));
6.291 +(* val t = (term_of o the o (parse thy))"Rewrite rroot_square_inv False e_";
6.292 +> itr_arg "Script.thy" t;
6.293 +val it = Free ("e_","RealDef.real") : term
6.294 +> val t = (term_of o the o (parse thy))"xxx";
6.295 +> itr_arg "Script.thy" t;
6.296 +*** itr_arg not impl. for xxx
6.297 +uncaught exception ERROR
6.298 + raised at: library.ML:1114.35-1114.40*)
6.299 +
6.300 +
6.301 +fun actual_args scr = (fst o split_last o snd o strip_comb) scr;
6.302 +(*
6.303 +> parms scr;
6.304 + [Free ("f_","RealDef.real"),Free ("v_","RealDef.real"),
6.305 + Free ("eqs_","bool List.list")] : term list
6.306 +*)
6.307 +
6.308 +
6.309 +(*update environment; t <> empty if coming from listexpr*)
6.310 +fun upd_env (env:env) (v,t) =
6.311 + let val env' = if t = e_term then env else overwrite (env,(v,t));
6.312 + (*val _= writeln("### upd_env: = "^(subst2str env'));*)
6.313 + in env' end;
6.314 +
6.315 +(*26.5.02: not clear, when a is available in ass_up for eva-_true*)
6.316 +fun upd_env_opt env (Some a, v) = upd_env env (a,v)
6.317 + | upd_env_opt env (None, v) =
6.318 + (writeln("*** upd_env_opt: (None,"^(term2str v)^")");env);
6.319 +
6.320 +
6.321 +type dsc = typ; (*<-> nam..unknow in Descript.thy*)
6.322 +fun typ_str (Type (s,_)) = s
6.323 + | typ_str (TFree(s,_)) = s
6.324 + | typ_str (TVar ((s,i),_)) = s^(string_of_int i);
6.325 +
6.326 +(*get the _result_-type of a description*)
6.327 +fun dsc_valT (Const (_,(Type (_,[_,T])))) = (strip_thy o typ_str) T;
6.328 +(*> val t = (term_of o the o (parse thy)) "equality";
6.329 +> val T = type_of t;
6.330 +val T = "bool => Tools.una" : typ
6.331 +> val dsc = dsc_valT t;
6.332 +val dsc = "una" : string
6.333 +
6.334 +> val t = (term_of o the o (parse thy)) "fixedValues";
6.335 +> val T = type_of t;
6.336 +val T = "bool List.list => Tools.nam" : typ
6.337 +> val dsc = dsc_valT t;
6.338 +val dsc = "nam" : string*)
6.339 +
6.340 +(*make args for script depending on type of description*)
6.341 +fun mk_arg thy d [] = raise error ("mk_arg: no data for "^
6.342 + (Sign.string_of_term (sign_of thy) d))
6.343 + | mk_arg thy d [t] =
6.344 + (case dsc_valT d of
6.345 + "una" => [t]
6.346 + | "nam" =>
6.347 + [case t of
6.348 + r as (Const ("op =",_) $ _ $ _) => r
6.349 + | _ => raise error
6.350 + ("mk_arg: dsc-typ 'nam' applied to non-equality "^
6.351 + (Sign.string_of_term (sign_of thy) t))]
6.352 + | s => raise error ("mk_arg: not impl. for "^s))
6.353 +
6.354 + | mk_arg thy d (t::ts) = (mk_arg thy d [t]) @ (mk_arg thy d ts);
6.355 +(*
6.356 + val d = d_in itm_;
6.357 + val [t] = ts_in itm_;
6.358 +mk_arg thy
6.359 +
6.360 +*)
6.361 +
6.362 +
6.363 +(*create the actual parameters (args) of script: their order
6.364 + is given by the order of "#Given" in ppc in !methods*)
6.365 +(* val mI = methID;
6.366 + *)
6.367 +fun itms2args thy mI (itms:itm list) =
6.368 + let
6.369 + fun test_dsc d (_,_,_,_,itm_) = (d = d_in itm_);
6.370 + fun itm2arg itms (_,(d,_)) =
6.371 + case find_first (test_dsc d) itms of
6.372 + None =>
6.373 + raise error ("itms2args: '"^
6.374 + (Sign.string_of_term (sign_of thy) d)^
6.375 + "' not in itms")
6.376 + | Some (_,_,_,_,itm_) => mk_arg thy (d_in itm_) (ts_in itm_);
6.377 + fun test_given (s,_) = (s = "#Given");
6.378 + val mpc = (#ppc o get_met) mI;
6.379 + val gs = filter test_given mpc;
6.380 + in (flat o (map (itm2arg itms))) gs end;
6.381 +(*
6.382 +> val sc = ... Solve_root_equation ...
6.383 +> val mI = ("Script.thy","sqrt-equ-test");
6.384 +> val PblObj{meth={ppc=itms,...},...} = get_obj I pt [];
6.385 +> val ts = itms2args thy mI itms;
6.386 +> map (Sign.string_of_term (sign_of thy)) ts;
6.387 +["sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)","x","#0"] : string list
6.388 +*)
6.389 +
6.390 +
6.391 +
6.392 +(*detour necessary, because generate1 delivers a string-result*)
6.393 +fun mout2term thy (Form' (FormKF (_,_,_,_,res))) =
6.394 + (term_of o the o (parse (assoc_thy thy))) res
6.395 + | mout2term thy (Form' (PpcKF _)) = e_term;(*3.8.01: res of subpbl
6.396 + at time of detection in script*)
6.397 +
6.398 +(* gets data from script which are necessary for next_tac (=mstep);
6.399 + (other data are fetched from pt in 'appl_in')
6.400 + 12.1.01: returnvalue term is useful for appl_in
6.401 + 26.9.00: still necessary? ~~was ? *)
6.402 +fun tac2mstep' thy (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f) =
6.403 + let val tid = (de_esc_underscore o strip_thy) thmID
6.404 + in (Rewrite (tid, (de_quote o string_of_thm o
6.405 + (assoc_thm' thy)) (tid,"")), f) end
6.406 +(* val (thy,
6.407 + mm as(Const ("Script.Rewrite'_Inst",_) $ sub $ Free(thmID,_) $ _ $ f))
6.408 + = (assoc_thy th,tac);
6.409 + tac2mstep' thy mm;
6.410 +
6.411 + assoc_thm' (assoc_thy "Isac.thy") (tid,"");
6.412 + assoc_thm' Isac.thy (tid,"");
6.413 + *)
6.414 + | tac2mstep' thy (Const ("Script.Rewrite'_Inst",_) $
6.415 + sub $ Free (thmID,_) $ _ $ f) =
6.416 + let val subML = ((map isapair2pair) o isalist2list) sub
6.417 + val subStr = subst2subs subML
6.418 + val tid = (de_esc_underscore o strip_thy) thmID (*4.10.02 unnoetig*)
6.419 + in (Rewrite_Inst
6.420 + (subStr, (tid, (de_quote o string_of_thm o
6.421 + (assoc_thm' thy)) (tid,""))), f) end
6.422 +
6.423 + | tac2mstep' thy (Const ("Script.Rewrite'_Set",_) $ Free (rls,_) $ _ $ f)=
6.424 + (Rewrite_Set ((de_esc_underscore o strip_thy) rls), f)
6.425 +
6.426 + | tac2mstep' thy (Const ("Script.Rewrite'_Set'_Inst",_) $
6.427 + sub $ Free (rls,_) $ _ $ f) =
6.428 + let val subML = ((map isapair2pair) o isalist2list) sub;
6.429 + val subStr = subst2subs subML;
6.430 + in (Rewrite_Set_Inst (subStr,rls), f) end
6.431 +
6.432 + | tac2mstep' thy (Const ("Script.Calculate",_) $ Free (op_,_) $ f) =
6.433 + (Calculate op_, f)
6.434 +
6.435 +(*12.1.01.*)
6.436 + | tac2mstep' thy (Const("Script.Check'_elementwise",_) $ _ $
6.437 + (set as Const ("Collect",_) $ Abs (_,_,pred))) =
6.438 + (Check_elementwise (Sign.string_of_term (sign_of thy) pred), set)
6.439 +
6.440 + | tac2mstep' thy (Const("Script.Or'_to'_List",_) $ _ ) =
6.441 + (Or_to_List, e_term)
6.442 +
6.443 +(*12.1.01.for subproblem_equation_dummy in root-equation *)
6.444 + | tac2mstep' thy (Const ("Script.Mstep",_) $ Free (str,_)) =
6.445 + (Mstep ((de_esc_underscore o strip_thy) str), e_term)
6.446 + (*L_ will come from pt in appl_in*)
6.447 +
6.448 + | tac2mstep' thy (Const ("Script.SubProblem",_) $
6.449 + (Const ("Pair",_) $ Free (thy',_) $
6.450 + (Const ("Pair",_) $ pblID' $
6.451 + (Const ("Pair",_) $ Free (mI1',_) $ Free (mI2',_)))) $
6.452 + ags') =
6.453 + let val pblID = ((map (de_esc_underscore o free2str))
6.454 + o isalist2list) pblID'
6.455 + val thy_ = ((implode o drop_last o explode) thy')^".thy"
6.456 + in (Subproblem (thy_, pblID), subpbl thy' pblID) end
6.457 +
6.458 + | tac2mstep' thy t = raise error
6.459 + ("tac2mstep' TODO: no match for "^
6.460 + (Sign.string_of_term (sign_of thy) t));
6.461 +(*
6.462 +> val t = (term_of o the o (parse thy))
6.463 + "Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False (x=a+#1)";
6.464 +> tac2mstep' t;
6.465 +val it = Rewrite_Set_Inst ([(#,#)],"isolate_bdv") : mstep
6.466 +
6.467 +> val t = (term_of o the o (parse SqRoot.thy))
6.468 +"(SubProblem (SqRoot_,[equation,univariate],(SqRoot_,solve_linear))\
6.469 + \ [bool_ e_, real_ v_])::bool list";
6.470 +> tac2mstep' SqRoot.thy t;
6.471 +val it = (Subproblem ("SqRoot.thy",[#,#]),Const (#,#) $ (# $ # $ (# $ #)))
6.472 +*)
6.473 +
6.474 +fun tac2mstep thy t = (fst o tac2mstep' thy) t;
6.475 +
6.476 +(*24.6.02 unused, use subst_tac instead !*)
6.477 +fun is_tac t =
6.478 + (tac2mstep' Script.thy t; true)
6.479 + handle _ => false;
6.480 +
6.481 +
6.482 +(* instantiate a tactic, and ev. attach (curried) argument
6.483 +args:
6.484 + E environment
6.485 + v current value, is attached to curried tactics
6.486 + tac tactic to be instantiated
6.487 +precond:
6.488 + not (a = None) /\ (v = e_term) /\ (tac curried, i.e. without last arg.)
6.489 + this ........................ is the initialization for assy with l=[],
6.490 + but the 1st tac is
6.491 + (a) curried: then (a = Some _), or
6.492 + (b) not curried: then the values of the initialization are not used
6.493 +*)
6.494 +fun subst_tac E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ $ _ ))=
6.495 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.496 +
6.497 + | subst_tac E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ ))=
6.498 + (case a of Some a' => (subst_atomic E (t $ a'))
6.499 + | None => ((subst_atomic E t) $ v))
6.500 +
6.501 + | subst_tac E a v
6.502 + (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ _ )) =
6.503 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.504 +
6.505 + | subst_tac E a v (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ )) =
6.506 + (case a of Some a' => subst_atomic E (t $ a')
6.507 + | None => ((subst_atomic E t) $ v))
6.508 +
6.509 + | subst_tac E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ _ )) =
6.510 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.511 +
6.512 + | subst_tac E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ )) =
6.513 + (case a of Some a' => subst_atomic E (t $ a')
6.514 + | None => ((subst_atomic E t) $ v))
6.515 +
6.516 + | subst_tac E a v
6.517 + (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ _ )) =
6.518 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.519 +
6.520 + | subst_tac E a v
6.521 + (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ )) =
6.522 + (case a of Some a' => subst_atomic E (t $ a')
6.523 + | None => ((subst_atomic E t) $ v))
6.524 +
6.525 + | subst_tac E a v (t as (Const ("Script.Calculate",_) $ _ $ _ )) =
6.526 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.527 +
6.528 + | subst_tac E a v (t as (Const ("Script.Calculate",_) $ _ )) =
6.529 + (case a of Some a' => subst_atomic E (t $ a')
6.530 + | None => ((subst_atomic E t) $ v))
6.531 +
6.532 + | subst_tac E a v
6.533 + (t as (Const("Script.Check'_elementwise",_) $ _ $ _ )) =
6.534 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.535 +(* val t = (term_of o the o (parseold Isac.thy))
6.536 + "Check_elementwise L_ {v_. Assumptions}";
6.537 + val tactac = subst_atomic E t;
6.538 + atomt tactac;
6.539 + *)
6.540 +
6.541 + | subst_tac E a v (t as (Const("Script.Check'_elementwise",_) $ _ )) =
6.542 + (case a of Some a' => subst_atomic E (t $ a')
6.543 + | None => ((subst_atomic E t) $ v))
6.544 +
6.545 + | subst_tac E a v (t as (Const("Script.Or'_to'_List",_) $ _ )) = t
6.546 +
6.547 + | subst_tac E a v (t as (Const("Script.Or'_to'_List",_))) = (*t $ v*)
6.548 + (case a of Some a' => subst_atomic E (t $ a')
6.549 + | None => ((subst_atomic E t) $ v))
6.550 +
6.551 + | subst_tac E a v (t as (Const ("Script.SubProblem",_) $
6.552 + (Const ("Pair",_) $ Free (thy',_) $
6.553 + (Const ("Pair",_) $ pblID' $
6.554 + (Const ("Pair",_) $ Free (mI1',_) $ Free (mI2',_)))) $
6.555 + ags')) =
6.556 + subst_atomic (case a of Some a => upd_env E (a,v) | None => E) t
6.557 +
6.558 + | subst_tac _ _ _ t = raise error
6.559 + ("subst_tac TODO: no match for "^(term2str t));
6.560 +
6.561 +
6.562 +
6.563 +
6.564 +
6.565 +(*start_at: go to the end of executed tactics; this is
6.566 + - the last element LE in ets, except this is in a let:
6.567 + - the 1st unfinished subexpr. in a let containing LE -
6.568 + within this subexpr. the last elem. wrt. iterations
6.569 + and return the location, local env, and
6.570 + ets (containing ev. parallel tacs/subexpr. in let)
6.571 +
6.572 + language restriction: _sequential_ let's ONLY !
6.573 + miniversion below expects l= l of (last_elem ets)
6.574 +
6.575 +args:
6.576 + l : loc_ which generated given formula: for || let
6.577 + ets: from PblObj
6.578 + sc : script not yet(?) used
6.579 +returns:
6.580 + enr: env, res etc. to be passed over until completion and append to ets
6.581 + 27.4.01: adapt to diss:script-interpreter !!!
6.582 + ets: in future versions eventually modified (|| let) TODO
6.583 +
6.584 +fun start_at ([]:loc_) ([]:ets) (sc:term) =
6.585 + (([]:env, []:env, empty, empty, Sundef), []:ets)
6.586 + (*neither l nor ets should be =[] ...*)
6.587 + | start_at l ets sc =
6.588 + let val (_,(_, ens, env, iar, ret, saf)) = last_elem (drop_last ets)
6.589 + (*TODO 5.9.00: check several 'User' instead ^^^^^^^^^*)
6.590 + in ((ens, env, iar, ret, saf), ets) end;-----------------------3.5.02*)
6.591 +
6.592 +
6.593 +
6.594 +
6.595 +fun tacpbls (h $ body) =
6.596 + let
6.597 + fun scan ts (Const ("Let",_) $ e $ (Abs (v,T,b))) =
6.598 + (scan ts e) @ (scan ts b)
6.599 + | scan ts (Const ("If",_) $ c $ e1 $ e2) = (scan ts e1) @ (scan ts e2)
6.600 + | scan ts (Const ("Script.While",_) $ c $ e $ _) = scan ts e
6.601 + | scan ts (Const ("Script.While",_) $ c $ e) = scan ts e
6.602 + | scan ts (Const ("Script.Repeat",_) $ e $ _) = scan ts e
6.603 + | scan ts (Const ("Script.Repeat",_) $ e) = scan ts e
6.604 + | scan ts (Const ("Script.Try",_) $ e $ _) = scan ts e
6.605 + | scan ts (Const ("Script.Try",_) $ e) = scan ts e
6.606 + | scan ts (Const ("Script.Or",_) $e1 $ e2 $ _) =
6.607 + (scan ts e1) @ (scan ts e2)
6.608 + | scan ts (Const ("Script.Or",_) $e1 $ e2) =
6.609 + (scan ts e1) @ (scan ts e2)
6.610 + | scan ts (Const ("Script.Seq",_) $e1 $ e2 $ _) =
6.611 + (scan ts e1) @ (scan ts e2)
6.612 + | scan ts (Const ("Script.Seq",_) $e1 $ e2) =
6.613 + (scan ts e1) @ (scan ts e2)
6.614 + | scan ts t = if is_listexpr t then [] else [t];
6.615 + in (distinct o (scan [])) body end;
6.616 + (*sc = Solve_root_equation ...
6.617 +> val ts = tacpbls sc;
6.618 +> writeln (terms2str thy ts);
6.619 +["Rewrite square_equation_left True e_",
6.620 + "Rewrite_Set SqRoot_simplify False e_",
6.621 + "Rewrite_Set rearrange_assoc False e_",
6.622 + "Rewrite_Set isolate_root False e_",
6.623 + "Rewrite_Set norm_equation False e_",
6.624 + "Rewrite_Set_Inst [(bdv, v_)] isolate_bdv False e_"]
6.625 +*)
6.626 +
6.627 +
6.628 +(*get the tactics and problems of a script as msteps
6.629 + instantiated with the current environment;
6.630 + l is the location which generated the given formula *)
6.631 +fun is_spec_pos Pbl = true
6.632 + | is_spec_pos Met = true
6.633 + | is_spec_pos _ = false;
6.634 +
6.635 +fun sel_rules pt ((p,p_):pos') =
6.636 + if is_spec_pos p_ then [Mstep "sel_rules not impl. for specify"](*TODO*)
6.637 + else
6.638 + let val pp = par_pblobj pt p;
6.639 + val thy' = (get_obj g_domID pt pp):theory';
6.640 + val thy = assoc_thy thy';
6.641 + val metID = get_obj g_metID pt pp;
6.642 + val metID' = if metID =e_metID then(thd3 o snd)(get_obj g_origin pt pp)
6.643 + else metID;
6.644 + val Script sc = (#scr o get_met) metID';
6.645 + val ScrState (env,_,_,_,_,_) = get_istate pt (p,p_);
6.646 + in map ((tac2mstep thy) o (subst_tac env None e_term)) (tacpbls sc) end;
6.647 +(*
6.648 +> val Script sc = (#scr o get_met) ("SqRoot.thy","sqrt-equ-test");
6.649 +> val env = [((term_of o the o (parse Isac.thy)) "bdv",
6.650 + (term_of o the o (parse Isac.thy)) "x")];
6.651 +> map ((tac2mstep thy) o (subst_tac env None e_term)) (tacpbls sc);
6.652 +*)
6.653 +
6.654 +
6.655 +
6.656 +
6.657 +
6.658 +(*test a term for being a _list_ (set ?) of constants; could be more rigorous*)
6.659 +fun list_of_consts (Const ("List.list.Cons",_) $ _ $ _) = true
6.660 + | list_of_consts (Const ("List.list.Nil",_)) = true
6.661 + | list_of_consts _ = false;
6.662 +(*val ttt = (term_of o the o (parse thy)) "[x=#1,x=#2,x=#3]";
6.663 +> list_of_consts ttt;
6.664 +val it = true : bool
6.665 +> val ttt = (term_of o the o (parse thy)) "[]";
6.666 +> list_of_consts ttt;
6.667 +val it = true : bool*)
6.668 +
6.669 +
6.670 +
6.671 +
6.672 +
6.673 +(* 15.1.01: evaluation of preds only works occasionally,
6.674 + but luckily for the 2 examples of root-equ:
6.675 +> val s = ((term_of o the o (parse thy)) "x",
6.676 + (term_of o the o (parse thy)) "-#5//#12");
6.677 +> val asm = (term_of o the o (parse thy))
6.678 + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)";
6.679 +> val pred = subst_atomic [s] asm;
6.680 +> rewrite_set_ thy false (cterm_of (sign_of thy) pred);
6.681 +val it = None : (cterm * cterm list) option !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6.682 +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
6.683 +val it = false : bool
6.684 +
6.685 +> val s = ((term_of o the o (parse thy)) "x",
6.686 + (term_of o the o (parse thy)) "#4");
6.687 +> val asm = (term_of o the o (parse thy))
6.688 + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#5 + x)";
6.689 +> val pred = subst_atomic [s] asm;
6.690 +> rewrite_set_ thy false (cterm_of (sign_of thy) pred);
6.691 +val it = Some ("True & True",[]) : (cterm * cterm list) option
6.692 +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
6.693 +val it = true : bool`*)
6.694 +
6.695 +(*for check_elementwise: take apart the set, ev. instantiate assumptions*)
6.696 +fun rep_set thy pt p (set as Const ("Collect",_) $ Abs _) =
6.697 + let val (_ $ Abs (bdv,T,pred)) = inst_abs thy set;
6.698 + val bdv = Free (bdv,T);
6.699 + val pred = if pred <> Const ("Script.Assumptions",bool)
6.700 + then pred
6.701 + else (mk_and o (map (term_of o the o (parse thy))) o
6.702 + (map fst)) (get_obj g_asm pt (par_pblobj pt p))
6.703 + in (bdv, pred) end
6.704 + | rep_set thy _ _ set =
6.705 + raise error ("check_elementwise: no set "^ (*from script*)
6.706 + (Sign.string_of_term (sign_of thy) set));
6.707 +(*> val set = (term_of o the o (parse thy)) "{(x::real). Assumptions}";
6.708 +> val p = [];
6.709 +> val pt = union_asm pt p [("#0 <= sqrt x + sqrt (#5 + x)",[11]),
6.710 + ("#0 <= #9 + #4 * x",[22]),
6.711 + ("#0 <= x ^^^ #2 + #5 * x",[33]),
6.712 + ("#0 <= #2 + x",[44])];
6.713 +> val (bdv,pred) = rep_set thy pt p set;
6.714 +val bdv = Free ("x","RealDef.real") : term
6.715 +> writeln (Sign.string_of_term (sign_of thy) pred);
6.716 +((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) &
6.717 + #0 <= x ^^^ #2 + #5 * x) &
6.718 +#0 <= #2 + x
6.719 +*)
6.720 +
6.721 +
6.722 +
6.723 +
6.724 +datatype ass =
6.725 + Ass of mstep' * (*SubProblem gets args instantiated in assod*)
6.726 + term (*for itr_arg,result in ets*)
6.727 +| AssWeak of mstep' *
6.728 + term (*for itr_arg,result in ets*)
6.729 +| NotAss;
6.730 +
6.731 +(*assod: mstep' associated with tac w.r.t. d
6.732 +returns
6.733 + Ass : associated: e.g. thmID in tac = thmID in m
6.734 + +++ arg in tac = arg in m
6.735 + AssWeak: weakly ass.:e.g. thmID in tac = thmID in m, //arg//
6.736 + NotAss : e.g. thmID in tac/=/thmID in m (not =)
6.737 +8.01:
6.738 + mstep' SubProblem with args completed from script
6.739 +*)
6.740 +fun assod d (m as Rewrite_Inst' (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))
6.741 + (Const ("Script.Rewrite'_Inst",_) $ subs_ $ Free (thmID_,idT) $ b $ f_) =
6.742 + if thmID = thmID_ then
6.743 + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
6.744 + else ((*writeln"3### assod ..AssWeak";*)AssWeak(m, f'))
6.745 + else ((*writeln"3### assod ..NotAss";*)NotAss)
6.746 +
6.747 + | assod d (m as Rewrite' (thy,rod,rls,put,(thmID,thm),f,(f',asm)))
6.748 + (t as Const ("Script.Rewrite",_) $ Free (thmID_,idT) $ b $ f_) =
6.749 + ((*writeln("3### assod: tac = "^
6.750 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));
6.751 + writeln("3### assod: f(m)= "^
6.752 + (Sign.string_of_term (sign_of (assoc_thy thy)) f));*)
6.753 + if thmID = thmID_ then
6.754 + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
6.755 + else ((*writeln"### assod ..AssWeak";
6.756 + writeln("### assod: f(m) = "^
6.757 + (Sign.string_of_term (sign_of (assoc_thy thy)) f));
6.758 + writeln("### assod: f(tac)= "^
6.759 + (Sign.string_of_term (sign_of (assoc_thy thy)) f_));*)
6.760 + AssWeak (m,f'))
6.761 + else ((*writeln"3### assod ..NotAss";*)NotAss))
6.762 +
6.763 +(*val f = (term_of o the o (parse thy))"#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0";
6.764 +> val f'= (term_of o the o (parse thy))"#0+(sqrt(sqrt a))^^^#2=#0";
6.765 +> val m = Rewrite'("Script.thy","tless_true","eval_rls",false,
6.766 + ("rroot_square_inv",""),f,(f',[]));
6.767 +> val tac = (term_of o the o (parse thy))
6.768 + "Rewrite rroot_square_inv False (#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0)";
6.769 +> assod e_rls m tac;
6.770 +val it =
6.771 + (Some (Rewrite' (#,#,#,#,#,#,#)),Const ("empty","RealDef.real"),
6.772 + Const ("empty","RealDef.real")) : mstep' option * term * term*)
6.773 +
6.774 + | assod d (m as Rewrite_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
6.775 + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
6.776 + if id_rls rls = rls_ then
6.777 + if f = f_ then Ass (m,f') else AssWeak (m,f')
6.778 + else NotAss
6.779 +
6.780 + | assod d (m as Rewrite_Set' (thy,put,rls,f,(f',asm)))
6.781 + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
6.782 + if id_rls rls = rls_ then
6.783 + if f = f_ then Ass (m,f') else AssWeak (m,f')
6.784 + else NotAss
6.785 +
6.786 + | assod d (m as Calculate' (thy',op_,f,(f',thm')))
6.787 + (Const ("Script.Calculate",_) $ Free (op__,_) $ f_) =
6.788 + if op_ = op__ then
6.789 + if f = f_ then Ass (m,f') else AssWeak (m,f')
6.790 + else NotAss
6.791 +
6.792 + | assod _ (m as Check_elementwise' (consts,_,consts_chkd))
6.793 + (Const ("Script.Check'_elementwise",_) $ consts' $ _) =
6.794 + ((*writeln("### assod Check'_elementwise: consts = "^
6.795 + (Sign.string_of_term (sign_of thy) consts));*)
6.796 + if consts = consts' then Ass (m,consts_chkd)
6.797 + else NotAss)
6.798 +
6.799 + | assod _ (m as Or_to_List' (ors, list))
6.800 + (Const ("Script.Or'_to'_List",_) $ _) =
6.801 + Ass (m, list)
6.802 +
6.803 + | assod _ (m as Mstep' (thy,f,id,f'))
6.804 + (Const ("Script.Mstep",_) $ Free (id',_)) =
6.805 + if id = id' then Ass (m, ((term_of o the o (parse thy)) f'))
6.806 + else NotAss
6.807 +
6.808 + | assod _ (Subproblem' ((domID,pblID,metID),_,f))
6.809 + (Const ("Script.SubProblem",_) $
6.810 + (Const ("Pair",_) $ Free (dI',_) $
6.811 + (Const ("Pair",_) $ pI' $
6.812 + (Const ("Pair",_) $ Free (mI1',_) $ Free (mI2',_)))) $
6.813 + ags') =
6.814 + let val domID' = ((implode o drop_last o explode) dI')^".thy";
6.815 + val pblID' = ((map (de_esc_underscore o free2str))
6.816 + o isalist2list) pI';
6.817 + val metID' as (dI',_) = (((implode o drop_last o explode) mI1')^".thy",
6.818 + de_esc_underscore mI2');
6.819 + (*5.8.02: really take domID for metID ?*)
6.820 + val oris = match_ags (assoc_thy domID) ((#ppc o get_pbt) pblID)
6.821 + (isalist2list ags');
6.822 + in
6.823 +(*writeln("##### assoc: metID' = "^(metID2str metID'));*)
6.824 + if domID = domID' andalso pblID = pblID'
6.825 + then Ass (Subproblem' ((domID, pblID, metID'), oris, f), f)
6.826 + else NotAss
6.827 + end
6.828 +
6.829 + | assod d m t =
6.830 + (
6.831 +(*writeln("### assod: NotAss m= "^(mstep'2str m)^"\n tac= "^(term2str t));*)
6.832 + NotAss);
6.833 +
6.834 +
6.835 +
6.836 +fun mstep'2mstep (Rewrite' (thy,rod,erls,put,(thmID,thm),f,(f',asm))) =
6.837 + Rewrite (thmID,thm)
6.838 +
6.839 + | mstep'2mstep (Rewrite_Inst' (thy,rod,erls,put,sub,(thmID,thm),f,(f',asm)))=
6.840 + Rewrite_Inst (subst2subs sub,(thmID,thm))
6.841 +
6.842 + | mstep'2mstep (Rewrite_Set' (thy,put,rls,f,(f',asm))) =
6.843 + Rewrite_Set (id_rls rls)
6.844 +
6.845 + | mstep'2mstep (Rewrite_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
6.846 + Rewrite_Set_Inst (subst2subs sub,id_rls rls)
6.847 +
6.848 + | mstep'2mstep (Calculate' (thy,op_,t,(t',thm'))) = Calculate (op_)
6.849 +
6.850 + | mstep'2mstep (Check_elementwise' (consts,pred,consts')) =
6.851 + Check_elementwise pred
6.852 +
6.853 + | mstep'2mstep (Or_to_List' _) = Or_to_List
6.854 +
6.855 + | mstep'2mstep (Mstep' (_,f,id,f')) = Mstep id
6.856 +
6.857 + | mstep'2mstep (Subproblem' ((domID, pblID, _), _, _)) =
6.858 + Subproblem (domID, pblID)
6.859 +
6.860 + | mstep'2mstep m =
6.861 + raise error ("mstep'2mstep: not impl. for "^(mstep'2str m));
6.862 +
6.863 +
6.864 +
6.865 +
6.866 +(** decompose mstep' to a rule and to (lhs,rhs)
6.867 + unly needed ~~~ **)
6.868 +
6.869 +val idT = Type ("Script.ID",[]);
6.870 +(*val tt = (term_of o the o (parse thy)) "square_equation_left::ID";
6.871 +type_of tt = idT;
6.872 +val it = true : bool
6.873 +*)
6.874 +(* 13.3.01
6.875 +v
6.876 +*)
6.877 +fun make_rule thy t =
6.878 + let val ct = cterm_of (sign_of thy) (Trueprop $ t)
6.879 + in Thm (string_of_cterm ct, make_thm ct) end;
6.880 +
6.881 +(* val (Rewrite_Inst'(thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))=m;
6.882 + *)
6.883 +(*decompose mstep' to a rule and to (lhs,rhs) for ets*)
6.884 +fun rep_mstep' (Rewrite_Inst'
6.885 + (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) =
6.886 + let val fT = type_of f;
6.887 + val b = if put then HOLogic.true_const else HOLogic.false_const;
6.888 + val sT = (type_of o fst o hd) subs;
6.889 + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
6.890 + (map HOLogic.mk_prod subs);
6.891 + val sT' = type_of subs';
6.892 + val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,(*fT*)bool,fT] ---> fT)
6.893 + $ subs' $ Free (thmID,idT) $ b $ f;
6.894 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
6.895 +(*Fehlersuche 25.4.01
6.896 +(a)----- als String zusammensetzen:
6.897 +ML> Sign.string_of_term (sign_of thy)f;
6.898 +val it = "d_d x #4 + d_d x (x ^^^ #2 + #3 * x)" : string
6.899 +ML> Sign.string_of_term (sign_of thy)f';
6.900 +val it = "#0 + d_d x (x ^^^ #2 + #3 * x)" : string
6.901 +ML> subs;
6.902 +val it = [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real"))] : subst
6.903 +> val tt = (term_of o the o (parse thy))
6.904 + "(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))";
6.905 +> atomty thy tt;
6.906 +ML> writeln(Sign.string_of_term (sign_of thy)tt);
6.907 +(Rewrite_Inst [(bdv,x)] diff_const False d_d x #4 + d_d x (x ^^^ #2 + #3 * x)) =
6.908 + #0 + d_d x (x ^^^ #2 + #3 * x)
6.909 +
6.910 +(b)----- laut rep_mstep':
6.911 +> val ttt=HOLogic.mk_eq (lhs,f');
6.912 +> atomty thy ttt;
6.913 +
6.914 +
6.915 +(*Fehlersuche 1-2Monate vor 4.01:*)
6.916 +> val tt = (term_of o the o (parse thy))
6.917 + "Rewrite_Inst[(bdv,x)]square_equation_left True(x=#1+#2)";
6.918 +> atomty thy tt;
6.919 +
6.920 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
6.921 +> val f' = (term_of o the o (parse thy)) "x=#3";
6.922 +> val subs = [((term_of o the o (parse thy)) "bdv",
6.923 + (term_of o the o (parse thy)) "x")];
6.924 +> val sT = (type_of o fst o hd) subs;
6.925 +> val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
6.926 + (map HOLogic.mk_prod subs);
6.927 +> val sT' = type_of subs';
6.928 +> val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,fT,fT] ---> fT)
6.929 + $ subs' $ Free (thmID,idT) $ HOLogic.true_const $ f;
6.930 +> lhs = tt;
6.931 +val it = true : bool
6.932 +> rep_mstep' (Rewrite_Inst'
6.933 + ("Script.thy","tless_true","eval_rls",false,subs,
6.934 + ("square_equation_left",""),f,(f',[])));
6.935 +*)
6.936 + | rep_mstep' (Rewrite' (thy',rod,rls,put,(thmID,thm),f,(f',asm)))=
6.937 + let
6.938 + val fT = type_of f;
6.939 + val b = if put then HOLogic.true_const else HOLogic.false_const;
6.940 + val lhs = Const ("Script.Rewrite",[idT,HOLogic.boolT,fT] ---> fT)
6.941 + $ Free (thmID,idT) $ b $ f;
6.942 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
6.943 +(*
6.944 +> val tt = (term_of o the o (parse thy)) (*____ ____..test*)
6.945 + "Rewrite square_equation_left True (x=#1+#2) = (x=#3)";
6.946 +
6.947 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
6.948 +> val f' = (term_of o the o (parse thy)) "x=#3";
6.949 +> val Thm (id,thm) =
6.950 + rep_mstep' (Rewrite'
6.951 + ("Script.thy","tless_true","eval_rls",false,
6.952 + ("square_equation_left",""),f,(f',[])));
6.953 +> val Some ct = parse thy
6.954 + "Rewrite square_equation_left True (x=#1+#2)";
6.955 +> rewrite_ Script.thy tless_true eval_rls true thm ct;
6.956 +val it = Some ("x = #3",[]) : (cterm * cterm list) option
6.957 +*)
6.958 + | rep_mstep' (Rewrite_Set_Inst'
6.959 + (thy',put,subs,rls,f,(f',asm))) =
6.960 + let val fT = type_of f;
6.961 + val sT = (type_of o fst o hd) subs;
6.962 + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
6.963 + (map HOLogic.mk_prod subs);
6.964 + val sT' = type_of subs';
6.965 + val b = if put then HOLogic.true_const else HOLogic.false_const
6.966 + val lhs = Const ("Script.Rewrite'_Set'_Inst",
6.967 + [sT',idT,fT,fT] ---> fT)
6.968 + $ subs' $ Free (id_rls rls,idT) $ b $ f;
6.969 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
6.970 +(* ... vals from Rewrite_Inst' ...
6.971 +> rep_mstep' (Rewrite_Set_Inst'
6.972 + ("Script.thy",false,subs,
6.973 + "isolate_bdv",f,(f',[])));
6.974 +*)
6.975 +(* val (Rewrite_Set' (thy',put,rls,f,(f',asm)))=m;
6.976 +*)
6.977 + | rep_mstep' (Rewrite_Set' (thy',put,rls,f,(f',asm)))=
6.978 + let val fT = type_of f;
6.979 + val b = if put then HOLogic.true_const else HOLogic.false_const;
6.980 + val lhs = Const ("Script.Rewrite'_Set",[idT,bool,fT] ---> fT)
6.981 + $ Free (id_rls rls,idT) $ b $ f;
6.982 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
6.983 +(* 13.3.01:
6.984 +val thy = assoc_thy thy';
6.985 +val t = HOLogic.mk_eq (lhs,f');
6.986 +make_rule thy t;
6.987 +--------------------------------------------------
6.988 +val lll = (term_of o the o (parse thy))
6.989 + "Rewrite_Set SqRoot_simplify False (d_d x (x ^^^ #2 + #3 * x) + d_d x #4)";
6.990 +
6.991 +--------------------------------------------------
6.992 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
6.993 +> val f' = (term_of o the o (parse thy)) "x=#3";
6.994 +> val Thm (id,thm) =
6.995 + rep_mstep' (Rewrite_Set'
6.996 + ("Script.thy",false,"SqRoot_simplify",f,(f',[])));
6.997 +val id = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : string
6.998 +val thm = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : thm
6.999 +*)
6.1000 + | rep_mstep' (Calculate' (thy',op_,f,(f',thm')))=
6.1001 + let val fT = type_of f;
6.1002 + val lhs = Const ("Script.Calculate",[idT,fT] ---> fT)
6.1003 + $ Free (op_,idT) $ f
6.1004 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
6.1005 +(*
6.1006 +> val lhs'=(term_of o the o (parse thy))"Calculate plus (#1+#2)";
6.1007 + ... test-root-equ.sml: calculate ...
6.1008 +> val Appl m'=applicable_in p pt (Calculate "plus");
6.1009 +> val (lhs,_)=mstep'2etac m';
6.1010 +> lhs'=lhs;
6.1011 +val it = true : bool*)
6.1012 + | rep_mstep' m = raise error ("rep_mstep': not impl.for "^
6.1013 + (mstep'2str m));
6.1014 +
6.1015 +
6.1016 +fun mstep'2rule m = (fst o rep_mstep') m;
6.1017 +fun mstep'2etac m = (snd o rep_mstep') m;
6.1018 +fun mstep'2tac m = (fst o snd o rep_mstep') m;
6.1019 +fun mstep'2res m = (snd o snd o rep_mstep') m;(*ONLYuse of rep_mstep'
6.1020 + FIXXXXME: simplify rep_mstep'*)
6.1021 +
6.1022 +
6.1023 +(* use"ME/script.sml";
6.1024 + use"script.sml";
6.1025 + *)
6.1026 +
6.1027 +
6.1028 +
6.1029 +
6.1030 +(** locate an applicable tactic in a script **)
6.1031 +
6.1032 +datatype assoc = (*ExprVal in the sense of denotational semantics*)
6.1033 + Assoc of (*the tac is associated, strongly or weakly*)
6.1034 + scrstate * (*the current; returned for next_tac etc. outside ass* *)
6.1035 + (step list) (*list of steps done until associated tac found;
6.1036 + initiated with the data for doing the 1st step,
6.1037 + thus the head holds these data further on,
6.1038 + while the tail holds steps finished (incl.scrstate in ptree)*)
6.1039 +| NasApp of (*tac not associated, but applicable, ptree-node generated*)
6.1040 + scrstate * (step list)
6.1041 +| NasNap of (*tac not associated, not applicable, nothing generated;
6.1042 + for distinction in Or, for leaving iterations, leaving Seq,
6.1043 + evaluate scriptexpressions*)
6.1044 + term * env;
6.1045 +fun assoc2str (Assoc _) = "Assoc"
6.1046 + | assoc2str (NasNap _) = "NasNap"
6.1047 + | assoc2str (NasApp _) = "NasApp";
6.1048 +
6.1049 +
6.1050 +datatype asap = (*arg. of assy _only_ for distinction w.r.t. Or*)
6.1051 + Aundef (*undefined: set only by (topmost) Or*)
6.1052 +| AssOnly (*do not execute appl tacs - there could be an associated
6.1053 + in parallel Or-branch*)
6.1054 +| AssGen; (*no Ass(Weak) found within Or, thus
6.1055 + search for _applicable_ tacs, execute and generate pt*)
6.1056 +(*this constructions doesnt allow arbitrary nesting of Or !!!*)
6.1057 +
6.1058 +
6.1059 +(*assy, ass_up, astep_up scanning for locate_gen at tactic in a script.
6.1060 + search is clearly separated into (1)-(2):
6.1061 + (1) assy is recursive descent;
6.1062 + (2) ass_up resumes interpretation at a location somewhere in the script;
6.1063 + astep_up does only get to the parentnode of the scriptexpr.
6.1064 + consequence:
6.1065 + * call of (2) means _always_ that in this branch below
6.1066 + there was an appl.tac (Repeat, Or e1, ...)
6.1067 +*)
6.1068 +
6.1069 +fun assy ya ((E,l,a,v,S,b),ss)
6.1070 + (Const ("Let",_) $ e $ (Abs (id,T,body))) =
6.1071 + (case assy ya ((E , l@[L,R], a,v,S,b),ss) e of
6.1072 + NasApp ((E',l,a,v,S,bb),ss) =>
6.1073 + let val id' = mk_Free (id, T);
6.1074 + val E' = upd_env E' (id', v);
6.1075 + (*val _=writeln("### assy Let -> NasApp");*)
6.1076 + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
6.1077 + | NasNap (v,E) =>
6.1078 + let val id' = mk_Free (id, T);
6.1079 + val E' = upd_env E (id', v);
6.1080 + (*val _=writeln("### assy Let -> NasNap");*)
6.1081 + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
6.1082 + | ay => ay)
6.1083 +
6.1084 + | assy (ya as (((thy,srls),_),_)) ((E,l,_,v,S,b),ss)
6.1085 + (Const ("Script.While",_) $ c $ e $ a) =
6.1086 + ((*writeln("### assy While $ c $ e $ a, upd_env= "^
6.1087 + (subst2str (upd_env E (a,v))));*)
6.1088 + if eval_true_ thy srls (subst_atomic (upd_env E (a,v)) c)
6.1089 + then assy ya ((E, l@[L,R], Some a,v,S,b),ss) e
6.1090 + else NasNap (v, E))
6.1091 +
6.1092 + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
6.1093 + (Const ("Script.While",_) $ c $ e) =
6.1094 + ((*writeln("### assy While, l= "^(loc_2str l));*)
6.1095 + if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
6.1096 + then assy ya ((E, l@[R], a,v,S,b),ss) e
6.1097 + else NasNap (v, E))
6.1098 +
6.1099 + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
6.1100 + (Const ("If",_) $ c $ e1 $ e2) =
6.1101 + (if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
6.1102 + then assy ya ((E, l@[L,R], a,v,S,b),ss) e1
6.1103 + else assy ya ((E, l@[ R], a,v,S,b),ss) e2)
6.1104 +
6.1105 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Try",_) $ e $ a) =
6.1106 + ((*writeln("### assy Try, l= "^(loc_2str l));*)
6.1107 + case assy ya ((E, l@[L,R], Some a,v,S,b),ss) e of
6.1108 + ay => ay)
6.1109 +
6.1110 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Try",_) $ e) =
6.1111 + ((*writeln("### assy Try, l= "^(loc_2str l));*)
6.1112 + case assy ya ((E, l@[R], a,v,S,b),ss) e of
6.1113 + ay => ay)
6.1114 +
6.1115 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2 $ a) =
6.1116 + ((*writeln("### assy Seq $e1 $ e2 $ a, E= "^(subst2str E));*)
6.1117 + case assy ya ((E, l@[L,L,R], Some a,v,S,b),ss) e1 of
6.1118 + NasNap (v, E) => assy ya ((E, l@[L,R], Some a,v,S,b),ss) e2
6.1119 + | NasApp ((E,_,_,v,_,_),ss) =>
6.1120 + assy ya ((E, l@[L,R], Some a,v,S,b),ss) e2
6.1121 + | ay => ay)
6.1122 +
6.1123 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2) =
6.1124 + (case assy ya ((E, l@[L,R], a,v,S,b),ss) e1 of
6.1125 + NasNap (v, E) => assy ya ((E, l@[R], a,v,S,b),ss) e2
6.1126 + | NasApp ((E,_,_,v,_,_),ss) =>
6.1127 + assy ya ((E, l@[R], a,v,S,b),ss) e2
6.1128 + | ay => ay)
6.1129 +
6.1130 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Repeat",_) $ e $ a) =
6.1131 + assy ya ((E,(l@[L,R]),Some a,v,S,b),ss) e
6.1132 +
6.1133 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Repeat",_) $ e) =
6.1134 + assy ya ((E,(l@[R]),a,v,S,b),ss) e
6.1135 +
6.1136 +(*15.6.02: ass,app Or nochmals "uberlegen FIXXXME*)
6.1137 + | assy (y, Aundef) ((E,l,_,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2 $ a) =
6.1138 + (case assy (y, AssOnly) ((E,(l@[L,L,R]),Some a,v,S,b),ss) e1 of
6.1139 + NasNap (v, E) =>
6.1140 + (case assy (y, AssOnly) ((E,(l@[L,R]),Some a,v,S,b),ss) e2 of
6.1141 + NasNap (v, E) =>
6.1142 + (case assy (y, AssGen) ((E,(l@[L,L,R]),Some a,v,S,b),ss) e1 of
6.1143 + NasNap (v, E) =>
6.1144 + assy (y, AssGen) ((E, (l@[L,R]), Some a,v,S,b),ss) e2
6.1145 + | ay => ay)
6.1146 + | ay =>(ay))
6.1147 + | NasApp _ => raise error ("assy: FIXXXME ///must not return NasApp///")
6.1148 + | ay => (ay))
6.1149 +
6.1150 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2) =
6.1151 + (case assy ya ((E,(l@[L,R]),a,v,S,b),ss) e1 of
6.1152 + NasNap (v, E) =>
6.1153 + assy ya ((E,(l@[R]),a,v,S,b),ss) e2
6.1154 + | ay => (ay))
6.1155 +(* val ((m,_,pt,(p,p_),c)::ss) = [(m,EmptyMout,pt,p,[])];
6.1156 + val t = (term_of o the o (parse Isac.thy)) "Rewrite rmult_1 False";
6.1157 + *)
6.1158 +
6.1159 + | assy (((thy',srls),d),ap) ((E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss) t =
6.1160 + if is_listexpr t
6.1161 + then (writeln"### assy: code listexpr missing"; NasNap (v, E))
6.1162 + else let val p' = case p_ of Frm => p | Res => lev_on p
6.1163 + | _ => raise error ("assy: call by "^(pos'2str (p,p_)));
6.1164 + val tac = subst_tac E a v t;
6.1165 + in case assod d m tac of
6.1166 + Ass (m,v') =>
6.1167 + let val (p'',c',f',pt') = generate1 (assoc_thy thy') m
6.1168 + (ScrState (E,l,a,v',S,true)) (p',p_) pt;
6.1169 + in Assoc ((E,l,a,v',S,true), (m,f',pt',p'',c @ c')::ss) end
6.1170 + | AssWeak (m,v') =>
6.1171 + let val (p'',c',f',pt') = generate1 (assoc_thy thy') m
6.1172 + (ScrState (E,l,a,v',S,false)) (p',p_) pt;
6.1173 + in Assoc ((E,l,a,v',S,false), (m,f',pt',p'',c @ c')::ss) end
6.1174 + | NotAss =>
6.1175 + (case ap of (*switch for Or: 1st AssOnly, 2nd AssGen*)
6.1176 + AssOnly => (NasNap (v, E))
6.1177 + | gen => (case applicable_in (p,p_) pt
6.1178 + (tac2mstep (assoc_thy thy') tac) of
6.1179 + Appl m' =>
6.1180 + let val is = (E,l,a,mstep'2res m',S,false(*FIXXXME*))
6.1181 + val (p'',c',f',pt') =
6.1182 + generate1 (assoc_thy thy') m' (ScrState is) (p',p_) pt;
6.1183 + in NasApp (is,(m,f',pt',p'',c @ c')::ss) end
6.1184 + | Notappl _ =>
6.1185 + (NasNap (v, E))
6.1186 + )
6.1187 + )
6.1188 + end;
6.1189 +(* (astep_up ((thy',scr,d),NasApp_) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])) handle e => print_exn_G e;
6.1190 + *)
6.1191 +
6.1192 +fun ass_up (ys as (y,s,Script sc,d)) ((E,l,a,v,S,b),ss)
6.1193 + (Const ("Let",_) $ _) =
6.1194 + let val l = drop_last l; (*comes from e, goes to Abs*)
6.1195 + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go l sc;
6.1196 + val i = mk_Free (i, T);
6.1197 + val E = upd_env E (i, v);
6.1198 + (*val _=writeln("### ass_up Let e: E="^(subst2str E));*)
6.1199 + in case assy (((y,s),d),Aundef) ((E, l@[R,D], a,v,S,b),ss) body of
6.1200 + Assoc iss => Assoc iss
6.1201 + | NasApp iss => astep_up ys iss
6.1202 + | NasNap (v, E) => astep_up ys ((E,l,a,v,S,b),ss) end
6.1203 +
6.1204 + | ass_up ys iss (Abs (_,_,_)) =
6.1205 + astep_up ys iss (*TODO 5.9.00: env ?*)
6.1206 +
6.1207 + | ass_up ys iss (Const ("Let",_) $ e $ (Abs (i,T,b))) =
6.1208 + astep_up ys iss (*TODO 5.9.00: env ?*)
6.1209 +
6.1210 +
6.1211 + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _ $ _) =
6.1212 + astep_up ysa iss (*all has been done in (*2*) below*)
6.1213 +
6.1214 + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _) =
6.1215 + astep_up ysa iss (*2*: comes from e2*)
6.1216 +
6.1217 + | ass_up (ysa as (y,s,Script sc,d)) ((E,l,a,v,S,b),ss)
6.1218 + (Const ("Script.Seq",_) $ _ ) = (*2*: comes from e1, goes to e2*)
6.1219 + let val up = drop_last l;
6.1220 + val Const ("Script.Seq",_) $ _ $ e2 = go up sc;
6.1221 + in case assy (((y,s),d),Aundef) ((E, up@[R], a,v,S,b),ss) e2 of
6.1222 + NasNap (v,E) => astep_up ysa ((E,up,a,v,S,b),ss)
6.1223 + | NasApp iss => astep_up ysa iss
6.1224 + | ay => ay end
6.1225 +
6.1226 + | ass_up ysa iss (Const ("Script.Try",_) $ e $ _) =
6.1227 + astep_up ysa iss
6.1228 +
6.1229 + | ass_up ysa iss (Const ("Script.Try",_) $ e) =
6.1230 + astep_up ysa iss
6.1231 +
6.1232 + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
6.1233 + (Const ("Script.While",_) $ c $ e $ a) =
6.1234 + ((*writeln("### ass_up: While c= "^
6.1235 + (term2str (subst_atomic (upd_env E (a,v)) c)));*)
6.1236 + if eval_true_ y s (subst_atomic (upd_env E (a,v)) c)
6.1237 + then (case assy (((y,s),d),Aundef) ((E, l@[L,R], Some a,v,S,b),ss) e of
6.1238 + NasNap (v,E') => astep_up ys ((E',l, Some a,v,S,b),ss)
6.1239 + | NasApp ((E',l,a,v,S,b),ss) =>
6.1240 + ass_up ys ((E',l,a,v,S,b),ss) t
6.1241 + | ay => ay)
6.1242 + else astep_up ys ((E,l, Some a,v,S,b),ss)
6.1243 + )
6.1244 +
6.1245 + | ass_up (ys as (y,s,_,d)) ((E,l,a,v,S,b),ss)
6.1246 + (Const ("Script.While",_) $ c $ e) =
6.1247 + if eval_true_ y s (subst_atomic (upd_env_opt E (a,v)) c)
6.1248 + then (case assy (((y,s),d),Aundef) ((E, l@[R], a,v,S,b),ss) e of
6.1249 + NasNap (v,E') => astep_up ys ((E',l, a,v,S,b),ss)
6.1250 + | NasApp ((E',l,a,v,S,b),ss) =>
6.1251 + ass_up ys ((E',l,a,v,S,b),ss) t
6.1252 + | ay => ay)
6.1253 + else astep_up ys ((E,l, a,v,S,b),ss)
6.1254 +
6.1255 + | ass_up y iss (Const ("If",_) $ _ $ _ $ _) = astep_up y iss
6.1256 +
6.1257 + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
6.1258 + (t as Const ("Script.Repeat",_) $ e $ a) =
6.1259 + (case assy (((y,s),d), Aundef) ((E, (l@[L,R]), Some a,v,S,b),ss) e of
6.1260 + NasNap (v,E') => astep_up ys ((E',l, Some a,v,S,b),ss)
6.1261 + | NasApp ((E',l,a,v,S,b),ss) =>
6.1262 + ass_up ys ((E',l,a,v,S,b),ss) t
6.1263 + | ay => ay)
6.1264 +
6.1265 + | ass_up (ys as (y,s,_,d)) (is as ((E,l,a,v,S,b),ss))
6.1266 + (t as Const ("Script.Repeat",_) $ e) =
6.1267 + (case assy (((y,s),d), Aundef) ((E, (l@[R]), a,v,S,b),ss) e of
6.1268 + NasNap (v', E') => astep_up ys ((E',l,a,v',S,b),ss)
6.1269 + | NasApp ((E',l,a,v',S,bb),ss) =>
6.1270 + ass_up ys ((E',l,a,v',S,b),ss) t
6.1271 + | ay => ay)
6.1272 +
6.1273 + | ass_up y iss (Const ("Script.Or",_) $ _ $ _ $ _) = astep_up y iss
6.1274 +
6.1275 + | ass_up y iss (Const ("Script.Or",_) $ _ $ _) = astep_up y iss
6.1276 +
6.1277 + | ass_up y ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $ _ ) =
6.1278 + astep_up y ((E, (drop_last l), a,v,S,b),ss)
6.1279 +
6.1280 + | ass_up y iss t =
6.1281 + raise error ("ass_up not impl for t= "^(term2str t))
6.1282 +
6.1283 +and astep_up (ys as (_,_,Script sc,_)) ((E,l,a,v,S,b),ss) =
6.1284 + if 1 < length l
6.1285 + then
6.1286 + let val up = drop_last l;
6.1287 + (*val _= writeln("### astep_up: v= "^(term2str v));*)
6.1288 + in ass_up ys ((E,up,a,v,S,b),ss) (go up sc) end
6.1289 + else (NasNap (v, E))
6.1290 +;
6.1291 +
6.1292 +
6.1293 +
6.1294 +
6.1295 +
6.1296 +(* use"ME/script.sml";
6.1297 + use"script.sml";
6.1298 + *)
6.1299 +
6.1300 +(*check if there are msteps for rewriting only*)
6.1301 +fun rew_only ([]:step list) = true
6.1302 + | rew_only (((Rewrite' _ ,_,_,_,_))::ss) = rew_only ss
6.1303 + | rew_only (((Rewrite_Inst' _ ,_,_,_,_))::ss) = rew_only ss
6.1304 + | rew_only (((Rewrite_Set' _ ,_,_,_,_))::ss) = rew_only ss
6.1305 + | rew_only (((Rewrite_Set_Inst' _ ,_,_,_,_))::ss) = rew_only ss
6.1306 + | rew_only (((Calculate' _ ,_,_,_,_))::ss) = rew_only ss
6.1307 + | rew_only (((Begin_Trans' _ ,_,_,_,_))::ss) = rew_only ss
6.1308 + | rew_only (((End_Trans' _ ,_,_,_,_))::ss) = rew_only ss
6.1309 + | rew_only _ = false;
6.1310 +
6.1311 +
6.1312 +datatype locate =
6.1313 + Steps of istate (*producing hd of step list (which was latest)
6.1314 + for next_tac, for reporting Safe|Unsafe to DG*)
6.1315 + * step (*(scrstate producing this step is in ptree !)*)
6.1316 + list (*locate_gen may produce intermediate steps*)
6.1317 +| NotLocatable; (*no (m Ass m') or (m AssWeak m') found*)
6.1318 +
6.1319 +
6.1320 +
6.1321 +(* locate_gen tries to locate an input mstep m in the script.
6.1322 + pursuing this goal the script is executed until an (m' equiv m) is found,
6.1323 + or the end of the script
6.1324 +args
6.1325 + m : input by the user, already checked by applicable_in,
6.1326 + (to be searched within Or; and _not_ an m doing the step on ptree !)
6.1327 + p,pt: (incl ets) at the time of input
6.1328 + scr : the script
6.1329 + d : canonical simplifier for locating Take, Substitute, Subproblems etc.
6.1330 + ets : ets at the time of input
6.1331 + l : the location (in scr) of the tac which generated the current formula
6.1332 +returns
6.1333 + Steps: pt,p (incl. ets) with m done
6.1334 + pos' list of proofobjs cut (from generate)
6.1335 + safe: implied from last proofobj
6.1336 + ets:
6.1337 + ///ToDo : ets contains a list of msteps to be done before m can be done
6.1338 + NOT IMPL. -- "error: do other step before"
6.1339 + NotLocatable: thus generate_hard
6.1340 +*)
6.1341 +(* val (Rewrite'(_,ro,er,pa,(id,str),f,_), p, Rfuns {locate_rule=lo,...},
6.1342 + RrlsState (_,f'',rss,rts)) = (m, (p,p_), sc, is);
6.1343 + *)
6.1344 +fun locate_gen (thy',_) (Rewrite'(_,ro,er,pa,(id,str),f,_)) (pt,p)
6.1345 + (Rfuns {locate_rule=lo,...}, d) (RrlsState (_,f'',rss,rts)) =
6.1346 + (case lo rss f (Thm (id, mk_thm (assoc_thy thy') str)) of
6.1347 + [] => NotLocatable
6.1348 + | rts' =>
6.1349 + Steps (rts2steps [] ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) rts'))
6.1350 +(* val p as(p',p_)=(p,p_);val scr as Script(h $ body)=sc;val (E,l,a,v,S,bb)=is;
6.1351 + locate_gen (thy':theory') (m:mstep') ((pt,p):ptree * pos')
6.1352 + (scr,d) (E,l,a,v,S,bb);
6.1353 +
6.1354 + val (p) = (p,p_);
6.1355 + val (scr as Script (h $ body)) = (sc);
6.1356 + val ScrState (E,l,a,v,S,b) = (is);
6.1357 + locate_gen thy' m (pt,p) (Script (h $ body),d) (ScrState(E,l,a,v,S,b));
6.1358 + *)
6.1359 + | locate_gen (ts as (thy',srls)) (m:mstep') ((pt,p):ptree * pos')
6.1360 + (scr as Script (h $ body),d) (ScrState (E,l,a,v,S,b)) =
6.1361 + let (*val _= writeln("### locate_gen: p="^(pos'2str p));*)
6.1362 + val thy = assoc_thy thy';
6.1363 + in case if l=[] then (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),
6.1364 + [(m,EmptyMout,pt,p,[])]) body)
6.1365 + else (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),
6.1366 + [(m,EmptyMout,pt,p,[])]) ) of
6.1367 + Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =>
6.1368 + ((*writeln("### locate_gen: p'="^(pos'2str p'));*)
6.1369 + if bb then Steps (ScrState is, ss)
6.1370 + else if rew_only ss (*andalso 'not bb'= associated weakly*)
6.1371 + then let (*val _=writeln("### locate_gen, bef g1: p="^(pos'2str p));*)
6.1372 + val (po,p_) = p;
6.1373 + val po' = case p_ of Frm => po | Res => lev_on po
6.1374 + val (p'',c'',f'',pt'') = generate1 thy m (ScrState is) (po',p_) pt;
6.1375 + (*val _=writeln("### locate_gen, aft g1: p''="^(pos'2str p''));*)
6.1376 + (*drop the intermediate steps !*)
6.1377 + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
6.1378 + else Steps (ScrState is, ss))
6.1379 +
6.1380 + | NasApp _ (*[((E,l,a,v,S,bb),(m',f',pt',p',c'))] =>
6.1381 + raise error ("locate_gen: should not have got NasApp, ets =")*)
6.1382 + => NotLocatable
6.1383 + | NasNap (_,_) =>
6.1384 + if l=[] then NotLocatable
6.1385 + else (*scan from begin of script for rew_only*)
6.1386 + (case assy ((ts,d),Aundef) ((E,[R],a,v,Unsafe,b),
6.1387 + [(m,EmptyMout,pt,p,[])]) body of
6.1388 + Assoc (iss as (is as (_,_,_,_,_,bb),
6.1389 + ss as ((m',f',pt',p',c')::_))) =>
6.1390 + ((*writeln"4### locate_gen Assoc after Fini";*)
6.1391 + if rew_only ss
6.1392 + then let val(p'',c'',f'',pt'') = generate1 thy m (ScrState is) p' pt;
6.1393 + (*drop the intermediate steps !*)
6.1394 + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
6.1395 + else NotLocatable)
6.1396 + | _ => ((*writeln ("#### locate_gen: after Fini");*)
6.1397 + NotLocatable))
6.1398 + end
6.1399 + | locate_gen _ m _ (sc,_) is =
6.1400 + raise error ("locate_gen: wrong arguments,\n mstep= "^(mstep'2str m)^
6.1401 + ",\n scr= "^(scr2str sc)^",\n istate= "^(istate2str is));
6.1402 +
6.1403 +
6.1404 +
6.1405 +(** find the next tactic in a script **)
6.1406 +
6.1407 +datatype appy = (*ExprVal in the sense of denotational semantics*)
6.1408 + Appy of (*applicable tac found, search stalled*)
6.1409 + loc_ * mstep' (*loc_ not yet used 28.4.02*)
6.1410 + | Napp of (*tac found was not applicable;
6.1411 + this mode may become Skip in Repeat, Try and Or*)
6.1412 + env (*stack*) (*popped while nxt_up*)
6.1413 + | Skip of (*for restart after Appy, for leaving iterations,
6.1414 + for passing the value of scriptexpressions,
6.1415 + and for finishing the script successfully*)
6.1416 + term * env (*stack*);
6.1417 +
6.1418 +(*appy, nxt_up, nstep_up scanning for next_tac.
6.1419 + search is clearly separated into (1)-(2):
6.1420 + (1) appy is recursive descent;
6.1421 + (2) nxt_up resumes interpretation at a location somewhere in the script;
6.1422 + nstep_up does only get to the parentnode of the scriptexpr.
6.1423 + consequence:
6.1424 + * call of (2) means _always_ that in this branch below
6.1425 + there was an appl.tac (Repeat, Or e1, ...)
6.1426 +*)
6.1427 +
6.1428 +datatype appy_ = (*as argument in nxt_up, nstep_up, from appy*)
6.1429 + (* Appy is only (final) returnvalue, not argument during search
6.1430 + |*) Napp_ (*ev. detects 'script is not appropriate for this example'*)
6.1431 + | Skip_; (*detects 'script successfully finished'
6.1432 + also used as init-value for resuming; this works,
6.1433 + because 'nxt_up Or e1' treats as Appy*)
6.1434 +
6.1435 +fun appy thy ptp E l
6.1436 + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
6.1437 + (case appy thy ptp E (l@[L,R]) e a v of
6.1438 + Skip (res, E) =>
6.1439 + let (*val _= writeln("### appy Let "^(term2str t));
6.1440 + val _= writeln("### appy Let: Skip res ="^(term2str res));*)
6.1441 + val (i',b') = variant_abs (i,T,b); (*term.ML FIXXXXXME streichen?*)
6.1442 + val i = mk_Free(i',T);
6.1443 + val E' = upd_env E (i,res);
6.1444 + in appy thy ptp E' (*eno,[](*env'*),iar,res,s*) (l@[R,D]) b(*ody'*) a v end
6.1445 + | ay => ay)
6.1446 +
6.1447 + | appy (thy as (th,sr)) ptp E l
6.1448 + (t as Const ("Script.While"(*1*),_) $ c $ e $ a) _ v = (*ohne n. 28.9.00*)
6.1449 + ((*writeln("### appy While $ c $ e $ a, upd_env= "^
6.1450 + (subst2str (upd_env E (a,v))));*)
6.1451 + if eval_true_ th sr (subst_atomic (upd_env E (a,v)) c)
6.1452 + then appy thy ptp E (l@[L,R]) e (Some a) v
6.1453 + else Skip (v, E))
6.1454 +
6.1455 + | appy (thy as (th,sr)) ptp E l
6.1456 + (t as Const ("Script.While"(*2*),_) $ c $ e) a v =(*ohne nachdenken 28.9.00*)
6.1457 + ((*writeln("### appy While $ c $ e, upd_env= "^
6.1458 + (subst2str (upd_env_opt E (a,v))));*)
6.1459 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
6.1460 + then appy thy ptp E (l@[R]) e a v
6.1461 + else Skip (v, E))
6.1462 +
6.1463 + | appy (thy as (th,sr)) ptp E l (t as Const ("If",_) $ c $ e1 $ e2) a v =
6.1464 + ((*writeln("### appy If: t= "^(term2str t));
6.1465 + writeln("### appy If: c= "^(term2str (subst_atomic (upd_env_opt E (a,v))c)));
6.1466 + writeln("### appy If: thy= "^thy);*)
6.1467 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
6.1468 + then ((*writeln("### appy If: true") ;*)appy thy ptp E (l@[L,R]) e1 a v)
6.1469 + else ((*writeln("### appy If: false");*)appy thy ptp E (l@[ R]) e2 a v))
6.1470 +
6.1471 + | appy thy ptp E (*env*) l
6.1472 + (Const ("Script.Repeat"(*1*),_) $ e $ a) _ v =
6.1473 + ((*writeln("### appy Repeat a: ");*)
6.1474 + appy thy ptp E (*env*) (l@[L,R]) e (Some a) v)
6.1475 +
6.1476 + | appy thy ptp E (*env*) l
6.1477 + (Const ("Script.Repeat"(*2*),_) $ e) a v =
6.1478 + ((*writeln("3### appy Repeat: a= "^
6.1479 + (Sign.string_of_term (sign_of (assoc_thy thy)) a));*)
6.1480 + appy thy ptp E (*env*) (l@[R]) e a v)
6.1481 +
6.1482 + | appy thy ptp E l
6.1483 + (t as Const ("Script.Try",_) $ e $ a) _ v =
6.1484 + (case appy thy ptp E (l@[L,R]) e (Some a) v of
6.1485 + Napp E => ((*writeln("### appy Try "^
6.1486 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
6.1487 + Skip (v, E))
6.1488 + | ay => ay)
6.1489 +(* val (l,t as Const ("Script.Try",_) $ e) = (l@[L,R],e1);
6.1490 + appy thy ptp E l t a v;
6.1491 + *)
6.1492 + | appy thy ptp E l
6.1493 + (t as Const ("Script.Try",_) $ e) a v =
6.1494 + (case appy thy ptp E (l@[R]) e a v of
6.1495 + Napp E => ((*writeln("### appy Try "^
6.1496 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
6.1497 + Skip (v, E))
6.1498 + | ay => ay)
6.1499 +
6.1500 +
6.1501 + | appy thy ptp E l
6.1502 + (Const ("Script.Or"(*1*),_) $e1 $ e2 $ a) _ v =
6.1503 + (case appy thy ptp E (l@[L,L,R]) e1 (Some a) v of
6.1504 + Appy lm => Appy lm
6.1505 + | _ => appy thy ptp E (*env*) (l@[L,R]) e2 (Some a) v)
6.1506 +
6.1507 + | appy thy ptp E l
6.1508 + (Const ("Script.Or"(*2*),_) $e1 $ e2) a v =
6.1509 + (case appy thy ptp E (l@[L,R]) e1 a v of
6.1510 + Appy lm => Appy lm
6.1511 + | _ => appy thy ptp E (l@[R]) e2 a v)
6.1512 +
6.1513 +
6.1514 + | appy thy ptp E l
6.1515 + (Const ("Script.Seq"(*1*),_) $e1 $ e2 $ a) _ v =
6.1516 + ((*writeln("### appy Seq $ e1 $ e2 $ a, upd_env= "^
6.1517 + (subst2str (upd_env E (a,v))));*)
6.1518 + case appy thy ptp E (l@[L,L,R]) e1 (Some a) v of
6.1519 + Skip (v,E) => appy thy ptp E (l@[L,R]) e2 (Some a) v
6.1520 + | ay => ay)
6.1521 +(* val (l,t as Const ("Script.Seq",_) $e1 $ e2) = (up@[R],e2);
6.1522 + appy thy ptp E l t a v;
6.1523 + *)
6.1524 + | appy thy ptp E l
6.1525 + (Const ("Script.Seq",_) $e1 $ e2) a v =
6.1526 + (case appy thy ptp E (l@[L,R]) e1 a v of
6.1527 + Skip (v,E) => appy thy ptp E (l@[R]) e2 a v
6.1528 + | ay => ay)
6.1529 +
6.1530 + (*here at the end, this must be a tactic
6.1531 + wrt. diss. missing checks: tac in ets, tac ready*)
6.1532 +(* val (pt, p) = ptp;
6.1533 + val t = (term_of o the o (parse SqRoot.thy))
6.1534 + "Rewrite square_equation_left True";
6.1535 +
6.1536 + val (pt, p) = ptp;
6.1537 + val t = (term_of o the o (parseold SqRoot.thy))
6.1538 + "Check_elementwise L_ {v_. Assumptions} ";
6.1539 +
6.1540 + val ((pt,p),l,t,a,v) = (ptp,[R],body,None,e_term);
6.1541 + val t = body;
6.1542 + val t = (term_of o the o (parseold SqRoot.thy))
6.1543 + "Rewrite square_equation_left True";
6.1544 + val a = Some ((term_of o the o (parseold SqRoot.thy)) "e_::bool");
6.1545 +
6.1546 + val ((pt,p),l,t,a,v) = (ptp,[R],body,None,e_term);
6.1547 +
6.1548 + val (thy as (th,sr),(pt,p),l,t) = (thy,ptp,l@[R],e);
6.1549 + appy (th,sr) (pt, p) E l t a v;
6.1550 + *)
6.1551 + | appy (thy as (th,sr)) (pt, p) E l t a v =
6.1552 + if is_listexpr t
6.1553 + then ((*writeln("### appy, listexpr= "^(term2str t));
6.1554 + writeln("### appy, eval(..)= "^(term2str
6.1555 + (eval_listexpr_ (assoc_thy thy)
6.1556 + (subst_atomic (upd_env_opt E (a,v)) t))));*)
6.1557 + Skip (eval_listexpr_ (assoc_thy th) sr
6.1558 + (subst_atomic (upd_env_opt E (a,v)) t), E))
6.1559 + else let val tac = subst_tac E a v t;
6.1560 + (*val _= writeln("### appy t, E= "^(subst2str E));
6.1561 +val t =(term_of o the o (parse Isac.thy))"Rewrite_Set make_polyomial False g_";
6.1562 +val v =(term_of o the o (parse Isac.thy))"x+1=0";
6.1563 + val _= writeln("### appy t, a= "^(termopt2str a));
6.1564 + val _= writeln("### appy t, v= "^(term2str v));
6.1565 + val _= writeln("### appy t, tac= "^(term2str tac));
6.1566 + val _= writeln("### appy t, vor tac2mstep");
6.1567 + val _= writeln("### appy t, l = "^(loc_2str l));*)
6.1568 + val (m,_) = tac2mstep' (assoc_thy th) tac;
6.1569 + (*val _= writeln("### appy t, nach tac2mstep, m= "^(mstep2str m));*)
6.1570 + in (case applicable_in p pt m of
6.1571 + Appl m' => ((*writeln("### appy: Appy");*)Appy (l, m'))
6.1572 + | _ => ((*writeln("### appy: Napp");*)Napp E)) end;
6.1573 +
6.1574 +
6.1575 +fun nxt_up thy ptp (scr as (Script sc)) E l ay
6.1576 + (t as Const ("Let",_) $ _) a v = (*comes from let=...*)
6.1577 + if ay = Napp_
6.1578 + then nstep_up thy ptp scr E (drop_last l) Napp_ a v
6.1579 + else (*Skip_*)
6.1580 + let val up = drop_last l;
6.1581 + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go up sc;
6.1582 + in case appy thy ptp (*upd_env*) E (*a,v)*) (up@[R,D]) body a v of
6.1583 + Appy lr => Appy lr
6.1584 + | Napp E => nstep_up thy ptp scr E up Napp_ a v
6.1585 + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end
6.1586 +
6.1587 + | nxt_up thy ptp scr E l ay
6.1588 + (t as Abs (_,_,_)) a v =
6.1589 + ((*writeln("### nxt_up Abs: "^
6.1590 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
6.1591 + nstep_up thy ptp scr E (*enr*) l ay a v)
6.1592 +
6.1593 + | nxt_up thy ptp scr E l ay
6.1594 + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
6.1595 + ((*writeln("### nxt_up Let e Abs: "^
6.1596 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
6.1597 + nstep_up thy ptp scr (*upd_env*) E (*a,v)*)
6.1598 + (*eno,upd_env env (iar,res),iar,res,saf*) l ay a v)
6.1599 +
6.1600 + (*no appy_: never causes Napp -> Helpless*)
6.1601 + | nxt_up (thy as (th,sr)) ptp scr E l _
6.1602 + (Const ("Script.While"(*1*),_) $ c $ e $ _) a v =
6.1603 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
6.1604 + then case appy thy ptp E (l@[L,R]) e a v of
6.1605 + Appy lr => Appy lr
6.1606 + | Napp E => nstep_up thy ptp scr E l Skip_ a v
6.1607 + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
6.1608 + else nstep_up thy ptp scr E l Skip_ a v
6.1609 +
6.1610 + (*no appy_: never causes Napp - Helpless*)
6.1611 + | nxt_up (thy as (th,sr)) ptp scr E l _
6.1612 + (Const ("Script.While"(*2*),_) $ c $ e) a v =
6.1613 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
6.1614 + then case appy thy ptp E (l@[R]) e a v of
6.1615 + Appy lr => Appy lr
6.1616 + | Napp E => nstep_up thy ptp scr E l Skip_ a v
6.1617 + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
6.1618 + else nstep_up thy ptp scr E l Skip_ a v
6.1619 +
6.1620 + | nxt_up thy ptp scr E l ay (Const ("If",_) $ _ $ _ $ _) a v =
6.1621 + nstep_up thy ptp scr E l ay a v
6.1622 +
6.1623 + | nxt_up thy ptp scr E l _ (*no appy_: there was already a tac below*)
6.1624 + (Const ("Script.Repeat"(*1*),T) $ e $ _) a v =
6.1625 + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[L,R]):loc_) e a v of
6.1626 + Appy lr => Appy lr
6.1627 + | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
6.1628 + nstep_up thy ptp scr E l Skip_ a v)
6.1629 + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
6.1630 + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
6.1631 + nstep_up thy ptp scr E l Skip_ a v))
6.1632 +
6.1633 + | nxt_up thy ptp scr E l _ (*no appy_: there was already a tac below*)
6.1634 + (Const ("Script.Repeat"(*2*),T) $ e) a v =
6.1635 + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[R]):loc_) e a v of
6.1636 + Appy lr => Appy lr
6.1637 + | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
6.1638 + nstep_up thy ptp scr E l Skip_ a v)
6.1639 + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
6.1640 + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
6.1641 + nstep_up thy ptp scr E l Skip_ a v))
6.1642 +
6.1643 +(* val (scr,l,t) = (Script sc,up,go up sc);
6.1644 + nxt_up thy ptp scr E l ay t a v;
6.1645 + *)
6.1646 + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
6.1647 + (t as Const ("Script.Try",_) $ e $ _) a v =
6.1648 + ((*writeln("### nxt_up Try "^
6.1649 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
6.1650 + nstep_up thy ptp scr E l Skip_ a v )
6.1651 +
6.1652 + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
6.1653 + (t as Const ("Script.Try"(*2*),_) $ e) a v =
6.1654 + ((*writeln("### nxt_up Try "^
6.1655 + (Sign.string_of_term (sign_of (assoc_thy thy)) t));*)
6.1656 + nstep_up thy ptp scr (*upd_env*) E (*a,v)*) l Skip_ a v)
6.1657 +
6.1658 +
6.1659 + | nxt_up thy ptp scr E l ay
6.1660 + (Const ("Script.Or",_) $ _ $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
6.1661 +
6.1662 + | nxt_up thy ptp scr E l ay
6.1663 + (Const ("Script.Or",_) $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
6.1664 +
6.1665 + | nxt_up thy ptp scr E l ay
6.1666 + (Const ("Script.Or",_) $ _ ) a v =
6.1667 + nstep_up thy ptp scr E (drop_last l) ay a v
6.1668 +
6.1669 +
6.1670 + | nxt_up thy ptp scr E l ay (*all has been done in (*2*) below*)
6.1671 + (Const ("Script.Seq"(*1*),_) $ _ $ _ $ _) a v =
6.1672 + nstep_up thy ptp scr E l ay a v
6.1673 +
6.1674 + | nxt_up thy ptp scr E l ay (*comes from e2*)
6.1675 + (Const ("Script.Seq"(*2*),_) $ _ $ e2) a v =
6.1676 + nstep_up thy ptp scr E l ay a v
6.1677 +(* val (scr as Script sc,l,t) = (Script sc,up,go up sc);
6.1678 + !! Const ("Script.Seq",_ $ _
6.1679 + nxt_up thy ptp scr E l ay t a v;
6.1680 + *)
6.1681 + | nxt_up thy ptp (scr as Script sc) E l ay (*comes from e1*)
6.1682 + (Const ("Script.Seq",_) $ _ ) a v =
6.1683 + if ay = Napp_
6.1684 + then nstep_up thy ptp scr E (drop_last l) Napp_ a v
6.1685 + else (*Skip_*)
6.1686 + let val up = drop_last l;
6.1687 + val Const ("Script.Seq"(*2*),_) $ _ $ e2 = go up sc;
6.1688 + in case appy thy ptp E (up@[R]) e2 a v of
6.1689 + Appy lr => Appy lr
6.1690 + | Napp E => nstep_up thy ptp scr E up Napp_ a v
6.1691 + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end
6.1692 +
6.1693 + | nxt_up (thy,_) ptp scr E l ay t a v =
6.1694 + raise error ("nxt_up not impl for "^
6.1695 + (Sign.string_of_term (sign_of (assoc_thy thy)) t))
6.1696 +
6.1697 +(* val (Script sc, ay) = (sc,Skip_);
6.1698 + val (Script sc, ay) = (scr,Skip_);
6.1699 + *)
6.1700 +and nstep_up thy ptp (Script sc) E l ay a v =
6.1701 + ((*writeln("### nstep_up from: "^(loc_2str l));
6.1702 + writeln("### nstep_up from: "^
6.1703 + (Sign.string_of_term (sign_of (assoc_thy thy)) (go l sc)));*)
6.1704 + if 1 < length l
6.1705 + then
6.1706 + let val up = drop_last l;
6.1707 + in ((*writeln("### nstep_up to: "^
6.1708 + (Sign.string_of_term (sign_of (assoc_thy thy)) (go up sc)));*)
6.1709 + nxt_up thy ptp (Script sc) E up ay (go up sc) a v ) end
6.1710 + else (*interpreted to end*)
6.1711 + if ay = Skip_ then Skip (v, E) else Napp E
6.1712 +);
6.1713 +
6.1714 +(* decide for the next applicable tac in the script;
6.1715 + returns (tactic, value) - the value in case the script is finished
6.1716 + 12.8.02: ~~~~~ and no assumptions ??? FIXME ???
6.1717 + 20.8.02: must return p in case of finished, because the next script
6.1718 + consulted need not be the calling script:
6.1719 + in case of detail ie. _inserted_ PrfObjs, the next tac
6.1720 + has to searched in a script with PblObj.status<>Complete !
6.1721 + (.. not true for other details ..PrfObj ??????????????????
6.1722 + 20.8.02: do NOT return safe (is only changed in locate !!!)
6.1723 +*)
6.1724 +(* val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
6.1725 + (thy', (pt,p), sc, RrlsState (ii t));
6.1726 + val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
6.1727 + (thy', (pt',p'), sc, is');
6.1728 + *)
6.1729 +fun next_tac thy (pt,p) (Rfuns {next_rule=ne,...}) (RrlsState (f,f',rss,_)) =
6.1730 + if f = f' then (End_Detail, (f', Sundef(*FIXME is no value of next_tac!*)))
6.1731 + (*finished*)
6.1732 + else (case ne rss f of
6.1733 + None => (Empty_Mstep, (e_term, Sundef)) (*helpless*)
6.1734 +(* val Some (Thm (id,thm)) = ne rss f;
6.1735 + *)
6.1736 + | Some (Thm (id,thm)) => (Rewrite (id, string_of_thm' thm),
6.1737 + (e_term, Sundef))) (*next tac*)
6.1738 +(* val (thy, ptp as (pt,(p,_)),sc as Script(h $ body)) =
6.1739 + ((thy',srls),(pt,p), sc);
6.1740 +
6.1741 + val (thy, ptp as (pt,(p,_)),sc as Script(h $ body)) =
6.1742 + ((thy',srls),(pt',p'), sc);
6.1743 + val ScrState (E,l,a,v,s,b) = is';
6.1744 + next_tac thy ptp (Script (h $ body)) (ScrState (E,l,a,v,s,b));
6.1745 +*)
6.1746 + | next_tac thy (ptp as (pt,(p,_)):ptree * pos') (sc as Script (h $ body))
6.1747 + (ScrState (E,l,a,v,s,b)) =
6.1748 + ((*writeln("### next_tac: p = "^(ints2str p));
6.1749 + writeln("### next_tac: ist= "^(istate2str (E,l,a,v,s,b)));
6.1750 + writeln("### next_tac: = "^());*)
6.1751 + case if l=[] then appy thy ptp E [R] body None e_term
6.1752 + else nstep_up thy ptp sc E l Skip_ a v of
6.1753 + Skip (v,_) => (*finished*)
6.1754 + (case par_pbl_det pt p of
6.1755 + (true, p', _) =>
6.1756 + let val (_,pblID,_) = get_obj g_spec pt p';
6.1757 + in (Check_Postcond pblID, (v,s)) end
6.1758 + | (_,p',rls') => (End_Detail, (v,s)))
6.1759 + | Napp _ => (Empty_Mstep, (e_term, Sundef)) (*helpless*)
6.1760 + | Appy (_,m') => (mstep'2mstep m', (e_term, Sundef))) (*next tac*)
6.1761 + | next_tac _ _ _ is = raise error ("next_tac: not impl for "^
6.1762 + (istate2str is));
6.1763 +
6.1764 +(* val metID = mI;
6.1765 + *)
6.1766 +fun init_scrstate thy itms metID =
6.1767 + let val ags = itms2args thy metID itms;
6.1768 + val scr as Script sc = (#scr o get_met) metID;
6.1769 + val env = ((actual_args sc) ~~ ags)
6.1770 + handle _ => raise error ("init_scrstate: formal_args = "^
6.1771 + (terms2str (actual_args sc))^
6.1772 + "\ndon't match actual_args ="^
6.1773 + (terms2str ags));
6.1774 + in (ScrState (env,[],None,e_term,Safe,true), scr):istate * scr end;
6.1775 +fun one_scr_arg (Const _ $ arg $ _) = arg
6.1776 + | one_scr_arg t = raise error ("one_scr_arg: called by "^(term2str t));
6.1777 +
6.1778 +(*.decide, where to get script and istate from:
6.1779 + (*1*) from PblObj: script only
6.1780 + (*2*) from PrfObj in case of detail a ruleset.*)
6.1781 +fun from_pblobj_or_detail' thy' (p,p_) pt =
6.1782 + let val (pbl,p',rls') = par_pbl_det pt p
6.1783 + in if pbl
6.1784 + then (*1*)
6.1785 + let val thy = assoc_thy thy'
6.1786 + val PblObj{meth=itms,...} = get_obj I pt p'
6.1787 + val metID = get_obj g_metID pt p'
6.1788 + val {srls,...} = get_met metID
6.1789 + in if last_elem p = 0 (*nothing written to pt yet*)
6.1790 + then let val (is, sc) = init_scrstate thy itms metID
6.1791 + in (srls, is, sc) end
6.1792 + else (srls, get_istate pt (p,p_), (#scr o get_met) metID)
6.1793 + end
6.1794 + else (*2*)
6.1795 +(* val Some rls = assoc(!ruleset', rls');
6.1796 + *)
6.1797 + (*case assoc(!ruleset', rls') of !!!FIXME.3.4.03:re-organize!!!
6.1798 + None => raise error ("unknown ruleset '"^rls'^"'")
6.1799 + | Some rls =>*)(e_rls, (*unused for Rrls in locate_gen, next_tac*)
6.1800 + get_istate pt (p,p_),
6.1801 + case rls' of
6.1802 + Rls {scr=scr,...} => scr
6.1803 + | Rrls {scr=rfuns,...} => rfuns)
6.1804 + end;
6.1805 +(*.get script and istate from PblObj, see (*1*) above.*)
6.1806 +fun from_pblobj' thy' (p,p_) pt =
6.1807 + let val p' = par_pblobj pt p
6.1808 + val thy = assoc_thy thy'
6.1809 + val PblObj{meth=itms,...} = get_obj I pt p'
6.1810 + val metID = get_obj g_metID pt p'
6.1811 + val {srls,scr,...} = get_met metID
6.1812 + in if last_elem p = 0 (*nothing written to pt yet*)
6.1813 + then let val (is, scr) = init_scrstate thy itms metID
6.1814 + in (srls, is, scr) end
6.1815 + else (srls, get_istate pt (p,p_), scr)
6.1816 + end;
6.1817 +
6.1818 +(*
6.1819 +end
6.1820 +open Interpreter;
6.1821 +*)
6.1822 +
6.1823 +(* use"ME/script.sml";
6.1824 + use"script.sml";
6.1825 + *)
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/src/sml/ME/sequent.sml Thu Apr 17 18:01:03 2003 +0200
7.3 @@ -0,0 +1,1265 @@
7.4 +(* use"ME/sequent.sml";
7.5 + use"sequent.sml";
7.6 + W.N.26.10.99
7.7 +
7.8 +writeln (pr_ptree pr_short pt);
7.9 +*)
7.10 +
7.11 +
7.12 +signature PTREE =
7.13 +sig
7.14 + type ptree
7.15 + type envp
7.16 + val e_ptree : ptree
7.17 + exception PTREE of string
7.18 + type branch
7.19 + type ostate
7.20 + type cellID
7.21 + type cid
7.22 + type posel
7.23 + type pos
7.24 + type pos'
7.25 + type loc
7.26 + type domID
7.27 + type pblID
7.28 + type metID
7.29 + type spec
7.30 + type 'a ppc
7.31 + type con
7.32 + type subs
7.33 + type subst
7.34 + type env
7.35 + type ets
7.36 + val ets2str : ets -> string
7.37 + type item
7.38 + type mstep
7.39 + type mstep'
7.40 + val mstep'2str : mstep' -> string
7.41 + type safe
7.42 + val safe2str : safe -> string
7.43 +
7.44 + type meth
7.45 + val cappend_atomic : ptree -> pos -> loc -> cterm' -> mstep
7.46 + -> cterm' -> ostate -> cid -> ptree * posel list * cid
7.47 + val cappend_form : ptree
7.48 + -> pos -> loc -> cterm' -> cid -> ptree * pos * cid
7.49 + val cappend_parent : ptree -> pos -> loc -> cterm' -> mstep
7.50 + -> branch -> cid -> ptree * int list * cid
7.51 + val cappend_problem : ptree -> posel list(*FIXME*) -> loc
7.52 + -> cterm' list * spec -> cid -> ptree * int list * cellID list
7.53 + val append_result : ptree -> pos -> cterm' -> ostate -> ptree * pos
7.54 +
7.55 + type ppobj
7.56 + val g_branch : ppobj -> branch
7.57 + val g_cell : ppobj -> cid
7.58 + val g_args : ppobj -> (int * (term list)) list (*args of scr*)
7.59 + val g_form : ppobj -> cterm'
7.60 + val g_loc : ppobj -> loc
7.61 + val g_met : ppobj -> meth
7.62 + val g_domID : ppobj -> domID
7.63 + val g_metID : ppobj -> metID
7.64 + val g_model : ppobj -> cterm' ppc
7.65 + val g_mstep : ppobj -> mstep
7.66 + val g_origin : ppobj -> cterm' list * spec
7.67 + val g_ostate : ppobj -> ostate
7.68 + val g_pbl : ppobj -> pblID * item ppc
7.69 + val g_result : ppobj -> cterm'
7.70 + val g_spec : ppobj -> spec
7.71 +(* val get_all : (ppobj -> 'a) -> ptree -> 'a list
7.72 + val get_alls : (ppobj -> 'a) -> ptree list -> 'a list *)
7.73 + val get_obj : (ppobj -> 'a) -> ptree -> pos -> 'a
7.74 + val gpt_cell : ptree -> cid
7.75 + val par_pblobj : ptree -> pos -> pos
7.76 + val pre_pos : pos -> pos
7.77 + val lev_dn : int list -> int list
7.78 + val lev_on : pos -> posel list
7.79 + val lev_pred : pos -> pos
7.80 + val lev_up : pos -> pos
7.81 +(* val pr_cell : pos -> ppobj -> string
7.82 + val pr_pos : int list -> string *)
7.83 + val pr_ptree : (pos -> ppobj -> string) -> ptree -> string
7.84 + val pr_short : pos -> ppobj -> string
7.85 +(* val repl : 'a list -> int -> 'a -> 'a list
7.86 + val repl_app : 'a list -> int -> 'a -> 'a list
7.87 + val repl_branch : branch -> ppobj -> ppobj
7.88 + val repl_domID : domID -> ppobj -> ppobj
7.89 + val repl_form : cterm' -> ppobj -> ppobj
7.90 + val repl_met : item ppc -> ppobj -> ppobj
7.91 + val repl_metID : metID -> ppobj -> ppobj
7.92 + val repl_model : cterm' list -> ppobj -> ppobj
7.93 + val repl_mstep : mstep -> ppobj -> ppobj
7.94 + val repl_pbl : item ppc -> ppobj -> ppobj
7.95 + val repl_pblID : pblID -> ppobj -> ppobj
7.96 + val repl_result : cterm' -> ostate -> ppobj -> ppobj
7.97 + val repl_spec : spec -> ppobj -> ppobj
7.98 + val repl_subs : (string * string) list -> ppobj -> ppobj
7.99 + val test_trans : ppobj -> bool
7.100 + val uni__asm : (string * pos) list -> ppobj -> ppobj
7.101 + val uni__cid : cellID list -> ppobj -> ppobj *)
7.102 + val union_asm : ptree -> pos -> (string * pos) list -> ptree
7.103 + val union_cid : ptree -> pos -> cellID list -> ptree
7.104 + val update_branch : ptree -> pos -> branch -> ptree
7.105 + val update_domID : ptree -> pos -> domID -> ptree
7.106 + val update_met : ptree -> pos -> meth -> ptree
7.107 + val update_metppc : ptree -> pos -> item ppc -> ptree
7.108 + val update_metID : ptree -> pos -> metID -> ptree
7.109 + val update_mstep : ptree -> pos -> mstep -> ptree
7.110 + val update_pbl : ptree -> pos -> pblID * item ppc -> ptree
7.111 + val update_pblppc : ptree -> pos -> item ppc -> ptree
7.112 + val update_pblID : ptree -> pos -> pblID -> ptree
7.113 + val update_spec : ptree -> pos -> spec -> ptree
7.114 + val update_subs : ptree -> pos -> (string * string) list -> ptree
7.115 +
7.116 + val rep_pblobj : ppobj
7.117 + -> {branch:branch, cell:cid, env:envp, loc:loc, meth:meth, model:cterm' ppc,
7.118 + origin:cterm' list * spec, ostate:ostate, probl:pblID * item ppc,
7.119 + result:cterm', spec:spec}
7.120 + val rep_prfobj : ppobj
7.121 + -> {branch:branch, cell:cid, form:cterm', loc:loc, mstep:mstep,
7.122 + ostate:ostate, result:cterm'}
7.123 +end
7.124 +
7.125 +(* --------------
7.126 +structure Ptree (**): PTREE (**) =
7.127 +struct
7.128 + -------------- *)
7.129 +
7.130 +type env = (term * term) list;
7.131 +
7.132 +
7.133 +datatype branch = NoBranch | And | Or | Transitive
7.134 + | Sequence | Intersect | Collect;
7.135 +fun branch2str NoBranch = "NoBranch"
7.136 + | branch2str And = "And"
7.137 + | branch2str Or = "Or"
7.138 + | branch2str Transitive = "Transitive"
7.139 + | branch2str Sequence = "Sequence"
7.140 + | branch2str Intersect = "Intersect"
7.141 + | branch2str Collect = "Collect";
7.142 +
7.143 +datatype ostate =
7.144 + Incomplete | Complete | Inconsistent;
7.145 +
7.146 +type cellID = int;
7.147 +type cid = cellID list;
7.148 +
7.149 +type posel = int; (* roundabout for (some of) nice signatures *)
7.150 +type pos = posel list;
7.151 +datatype pos_ =
7.152 + Pbl (*PblObj-position: problem-type*)
7.153 + | Met (*PblObj-position: method*)
7.154 + | Frm (* PrfObj-position: formula*)
7.155 + | Res (*PblObj | PrfObj-position: result*)
7.156 + | Und; (*undefined*)
7.157 +fun pos_2str Pbl = "Pbl"
7.158 + | pos_2str Met = "Met"
7.159 + | pos_2str Frm = "Frm"
7.160 + | pos_2str Res = "Res"
7.161 + | pos_2str Und = "Und";
7.162 +
7.163 +type pos' = pos * pos_;
7.164 +fun pos'2str (p,p_) = pair2str (ints2str p, pos_2str p_);
7.165 +val e_pos' = ([],Und):pos';
7.166 +
7.167 +
7.168 +
7.169 +
7.170 +datatype lrd = (*elements of a path (=loc_) into an Isabelle term*)
7.171 + L (*go left at $*)
7.172 + | R (*go right at $*)
7.173 + | D; (*go down at Abs*)
7.174 +type loc_ = lrd list;
7.175 +fun ldr2str L = "L"
7.176 + | ldr2str R = "R"
7.177 + | ldr2str D = "D";
7.178 +fun loc_2str (k:loc_) = (strs2str' o (map ldr2str)) k;
7.179 +
7.180 +(*26.4.02: never used after introduction of scripts !!!*)
7.181 +type loc = loc_ * (* + interpreter-state *)
7.182 + (loc_ * rls') (* -"- for script of the ruleset*)
7.183 + option;
7.184 +val e_loc = ([],None):loc;
7.185 +val ee_loc = (e_loc,e_loc);
7.186 +
7.187 +
7.188 +datatype safe = Sundef | Safe | Unsafe | Helpless;
7.189 +fun safe2str Sundef = "Sundef"
7.190 + | safe2str Safe = "Safe"
7.191 + | safe2str Unsafe = "Unsafe"
7.192 + | safe2str Helpless = "Helpless";
7.193 +
7.194 +type subs = cterm' list; (*16.11.00 for FE-KE*)
7.195 +fun subst2str' thy' (s:subst) =
7.196 + (strs2str o
7.197 + (map (pair2str o
7.198 + (apsnd (Sign.string_of_term (sign_of (assoc_thy thy')))) o
7.199 + (apfst (Sign.string_of_term (sign_of (assoc_thy thy'))))))) s;
7.200 +
7.201 +type scrstate = (*state for script interpreter*)
7.202 + env(*stack*) (*used to instantiate tac for checking assod*)
7.203 + * loc_ (*location of tac in script*)
7.204 + * term option(*argument of curried functions*)
7.205 + * term (*value obtained by tac executed*)
7.206 + * safe (*estimation of how result will be obtained*)
7.207 + * bool; (*true = strongly .., false = weakly associated:
7.208 + only used during ass_dn/up*)
7.209 +(*21.8.02 ---> definitions.sml for datatype scr
7.210 +type rrlsstate = (*state for reverse rewriting*)
7.211 + (term * (*the current formula*)
7.212 + rule list (*of reverse rewrite set (#1#)*)
7.213 + list * (*may be serveral, eg. in norm_rational*)
7.214 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
7.215 + (term * (*... rewrite with ...*)
7.216 + term list)) (*... assumptions*)
7.217 + list); (*derivation from given term to normalform
7.218 + in reverse order with sym_thm;
7.219 + (#1#) could be extracted from here #1*) --------*)
7.220 +
7.221 +datatype istate = (*interpreter state*)
7.222 + ScrState of scrstate (*for script interpreter*)
7.223 + | RrlsState of rrlsstate; (*for reverse rewriting*)
7.224 +type iist = istate option * istate option;
7.225 +val e_istate = (ScrState ([],[],None,e_term,Sundef,false)):istate;
7.226 +(*val e_iist = (e_istate, e_istate); --- sinnlos f"ur NICHT-equality-type*)
7.227 +fun rta2str (r,(t,a)) = "\n("^(rule2str r)^",("^(term2str t)^", "^
7.228 + (terms2str a)^"))";
7.229 +fun istate2str (ScrState (e,l,to,t,s,b):istate) =
7.230 + "ScrState ("^ subst2str e ^",\n "^
7.231 + loc_2str l ^", "^ termopt2str to ^",\n "^
7.232 + term2str t ^", "^ safe2str s ^", "^ bool2str b ^")"
7.233 + | istate2str (RrlsState (t,t1,rss,rtas)) =
7.234 + "RrlsState ("^(term2str t)^", "^(term2str t1)^", "^
7.235 + ((strs2str o (map (strs2str o (map rule2str)))) rss)^", "^
7.236 + ((strs2str o (map rta2str)) rtas)^")";
7.237 +
7.238 +
7.239 +type spec = domID * pblID * metID;
7.240 +fun spec2str ((dom,pbl,met)(*:spec*)) =
7.241 + "(" ^ (quote dom) ^ ", " ^ (strs2str pbl) ^
7.242 + ", " ^ (pair2str met) ^ ")";
7.243 +(*> spec2str empty_spec;
7.244 +val it = "(\"\", [], (\"\", \"\"))" : string *)
7.245 +val empty_spec = (e_domID,e_pblID,e_metID):spec;
7.246 +
7.247 +
7.248 +datatype con = land | lor;
7.249 +
7.250 +
7.251 +fun subst2subs s = map (pair2str o
7.252 + (apfst (Sign.string_of_term (sign_of thy))) o
7.253 + (apsnd (Sign.string_of_term (sign_of thy)))) s;
7.254 +fun subst2subs' s = map ((apfst (Sign.string_of_term (sign_of thy))) o
7.255 + (apsnd (Sign.string_of_term (sign_of thy)))) s;
7.256 +
7.257 +
7.258 +
7.259 +fun isapair2pair (Const ("Pair",_) $ a $ b) = (a,b);
7.260 +fun subs2subst thy s = map (isapair2pair o term_of o the o (parse thy)) s;
7.261 +(*> subs2subst thy ["(bdv,x)","(err,#0)"];
7.262 +val it =
7.263 + [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real")),
7.264 + (Free ("err","RealDef.real"),Free ("#0","RealDef.real"))]
7.265 + : (term * term) list*)
7.266 +
7.267 +
7.268 +
7.269 +
7.270 +
7.271 +
7.272 +(*FE <-> KE: strings*)
7.273 +datatype mstep =
7.274 + Init_Proof of ((cterm' list) * spec)
7.275 +(*Init_Proo_Hid of (dgmode * (cterm' list) * spec)
7.276 +| Init_Proof 7.6.02java-sml*)
7.277 +| Model_Problem of pblID
7.278 +| Refine_Problem of pblID | Refine_Tacitly of pblID
7.279 +(*| Match_Problem of pblID*)
7.280 +| Add_Given of cterm' | Del_Given of cterm'
7.281 +| Add_Find of cterm' | Del_Find of cterm'
7.282 +| Add_Relation of cterm' | Del_Relation of cterm'
7.283 +
7.284 +| Specify_Domain of domID | Specify_Problem of pblID
7.285 +| Specify_Method of metID
7.286 +| Apply_Method of metID | Check_Postcond of pblID
7.287 +| Free_Solve
7.288 +
7.289 +| Rewrite_Inst of ( subs * thm') | Rewrite of thm'
7.290 + | Rewrite_Asm of thm'
7.291 +| Rewrite_Set_Inst of ( subs * rls') | Rewrite_Set of rls'
7.292 +| Detail (*user_cmd for detailing some _EXISTING_ data*)
7.293 +| End_Detail (*switches back to parent script*)
7.294 +| Detail_Set_Inst of ( subs * rls') | Detail_Set of rls'
7.295 + (*EITHER: an input of me, details rewrites in a Set _after_
7.296 + Rewrite_Set* has created PblObj (+ istate);
7.297 + OR:: set by "solve Detail_Set" as mstep in Transitive --
7.298 + for recognition of "insert pt" detail (versus "cappend pt"*)
7.299 +| Calculate of string | End_Ruleset
7.300 + (* plus | minus | times | cancel | pow | sqrt *)
7.301 +| Substitute of subs | Apply_Assumption of cterm' list
7.302 +
7.303 +| Take of cterm' | Take_Inst of cterm'
7.304 +| Group of (con * int list )
7.305 +(*| Subproblem_Full of (spec * (cterm' list)) *)
7.306 +| Subproblem of (domID * pblID)
7.307 +| CAScmd of cterm' (*6.6.02 URD: Function formula *)
7.308 +| End_Subproblem
7.309 +
7.310 +| Split_And | Conclude_And
7.311 +| Split_Or | Conclude_Or
7.312 +| Begin_Trans | End_Trans
7.313 +| Begin_Sequ | End_Sequ(* substitute root.env *)
7.314 +| Split_Intersect | End_Intersect
7.315 +| Check_elementwise of cterm' | Collect_Trues
7.316 +| Or_to_List
7.317 +
7.318 +| Empty_Mstep | Mstep of string(* eg.'repeat'*)
7.319 +| User (*internal, for ets*) | End_Proof';(* inout*)
7.320 +
7.321 +
7.322 +(* mstep2str /--> library.sml: needed in dialog.sml for 'separable *)
7.323 +fun mstep2str (ma:mstep) = case ma of
7.324 + Init_Proof (ppc, spec) =>
7.325 + "Init_Proof "^(pair2str (strs2str ppc, spec2str spec))
7.326 + | Model_Problem pblID => "Model_Problem "^(strs2str pblID)
7.327 + | Refine_Tacitly pblID => "Refine_Tacitly "^(strs2str pblID)
7.328 + | Refine_Problem pblID => "Refine_Problem "^(strs2str pblID)
7.329 +(*| Match_Problem pblID => "Match_Problem "^(strs2str pblID)*)
7.330 + | Add_Given cterm' => "Add_Given "^cterm'
7.331 + | Del_Given cterm' => "Del_Given "^cterm'
7.332 + | Add_Find cterm' => "Add_Find "^cterm'
7.333 + | Del_Find cterm' => "Del_Find "^cterm'
7.334 + | Add_Relation cterm' => "Add_Relation "^cterm'
7.335 + | Del_Relation cterm' => "Del_Relation "^cterm'
7.336 +
7.337 + | Specify_Domain domID => "Specify_Domain "^(quote domID )
7.338 + | Specify_Problem pblID => "Specify_Problem "^(strs2str pblID )
7.339 + | Specify_Method metID => "Specify_Method "^(spair2str metID)
7.340 + | Apply_Method metID => "Apply_Method "^(spair2str metID)
7.341 + | Check_Postcond pblID => "Check_Postcond "^(strs2str pblID)
7.342 + | Free_Solve => "Free_Solve"
7.343 +
7.344 + | Rewrite_Inst (subs,thm')=>
7.345 + "Rewrite_Inst "^(pair2str (subs2str subs, spair2str thm'))
7.346 + | Rewrite thm' => "Rewrite "^(spair2str thm')
7.347 + | Rewrite_Asm thm' => "Rewrite_Asm "^(spair2str thm')
7.348 + | Rewrite_Set_Inst (subs, rls) =>
7.349 + "Rewrite_Set_Inst "^(pair2str (subs2str subs, quote rls))
7.350 + | Rewrite_Set rls => "Rewrite_Set "^(quote rls )
7.351 + | Detail => "Detail"
7.352 + | End_Detail => "End_Detail"
7.353 + | Detail_Set rls => "Detail_Set "^(quote rls )
7.354 + | Detail_Set_Inst (subs, rls) =>
7.355 + "Detail_Set_Inst "^(pair2str (subs2str subs, quote rls))
7.356 + | Calculate op_ => "Calculate "^op_
7.357 + | Substitute subs => "Substitute "^(subs2str subs)
7.358 + | Apply_Assumption ct's => "Apply_Assumption "^(strs2str ct's)
7.359 +
7.360 + | Take cterm' => "Take "^(quote cterm' )
7.361 + | Take_Inst cterm' => "Take_Inst "^(quote cterm' )
7.362 + | Group (con, ints) =>
7.363 + "Group "^(pair2str (con2str con, ints2str ints))
7.364 + | Subproblem (domID, pblID) =>
7.365 + "Subproblem "^(pair2str (domID, strs2str pblID))
7.366 +(*| Subproblem_Full (spec, cts') =>
7.367 + "Subproblem_Full "^(pair2str (spec2str spec, strs2str cts'))*)
7.368 + | End_Subproblem => "End_Subproblem"
7.369 + | CAScmd cterm' => "CAScmd "^(quote cterm')
7.370 +
7.371 + | Check_elementwise cterm'=> "Check_elementwise "^(quote cterm')
7.372 + | Or_to_List => "Or_to_List "
7.373 + | Collect_Trues => "Collect_Trues"
7.374 +
7.375 + | Empty_Mstep => "Empty_Mstep"
7.376 + | Mstep string => "Mstep "^string
7.377 + | User => "User"
7.378 + | End_Proof' => "mstep End_Proof'"
7.379 + | _ => "mstep2str not impl. for ?!";
7.380 +
7.381 +
7.382 +
7.383 +
7.384 +(*mstep' is made from mstep in applicable_in,
7.385 + and carries all data necessary for generate;*)
7.386 +datatype mstep' =
7.387 +(* datatype mstep = *)
7.388 + Init_Proof' of ((cterm' list) * spec)
7.389 + (* ori list !: code specify -> applicable*)
7.390 +| Model_Problem' of pblID | Refine_Tacitly' of pblID * pblID (*the refined*)
7.391 +| Refine_Problem' of match list
7.392 +(*| Match_Problem' of (pblID * (* *)
7.393 + (bool * (* matches *)
7.394 + (itm list * (* ppc *)
7.395 + item list))) (* preconditions *)----------------*)
7.396 +| Add_Given' of cterm' | Del_Given' of cterm'
7.397 +| Add_Find' of cterm' | Del_Find' of cterm'
7.398 +| Add_Relation' of cterm' | Del_Relation' of cterm'
7.399 + (*4.00.: all.. term: in applicable_in ..? Syn ?only for FormFK?*)
7.400 +
7.401 +| Specify_Domain' of domID
7.402 +| Specify_Problem' of (pblID * (* *)
7.403 + (bool * (* matches *)
7.404 + (itm list * (* ppc *)
7.405 + item list))) (* preconditions *)
7.406 +| Specify_Method' of (metID)(*--- * (* *)
7.407 + (bool * (* matches *)
7.408 + (itm list * (* ppc *)
7.409 + item list))) (* preconditions *)---*)
7.410 +| Apply_Method' of metID | Check_Postcond' of pblID * term
7.411 +| Free_Solve'
7.412 +
7.413 +| Rewrite_Inst' of theory' * rew_ord' * rls
7.414 + * bool * subst * thm' * term * (term * term list)
7.415 + (*... form * (result* asumpts ), saves time*)
7.416 +| Rewrite' of theory' * rew_ord' * rls * bool * thm' *
7.417 + term * (term * term list)
7.418 +| Rewrite_Asm' of theory' * rew_ord' * rls * bool * thm' *
7.419 + term * (term * term list)
7.420 +| Rewrite_Set_Inst' of theory' * bool * subst * rls *
7.421 + term * (term * term list)
7.422 +| Rewrite_Set' of theory' * bool * rls * term * (term * term list)
7.423 +(*Detail' in me detailed into ...*)
7.424 +| End_Detail' of term (*see End_Trans'*)
7.425 +| Detail_Set' of theory' * rls * term(*term is needed for next_tac before 2nd
7.426 + applicable_in*)
7.427 +| Detail_Set_Inst' of theory' * subst * rls * term
7.428 +| End_Ruleset' of term
7.429 +| Calculate' of theory' * string * term * (term * thm')
7.430 +| Substitute' of subst * term (*10.8.00+..*)* term
7.431 +| Apply_Assumption' of term list * term
7.432 +
7.433 +| Take' of term | Take_Inst' of term
7.434 +| Group' of (con * int list * term)
7.435 +| Subproblem' of (spec * (ori list) * term) (*term: Subproblem(dom,pbl)*)
7.436 +| CAScmd' of term
7.437 +| End_Subproblem' of term (*???*)
7.438 +| Split_And' of term | Conclude_And' of term
7.439 +| Split_Or' of term | Conclude_Or' of term
7.440 +| Begin_Trans' of term | End_Trans' of term
7.441 +| Begin_Sequ' | End_Sequ'(* substitute root.env*)
7.442 +| Split_Intersect' of term | End_Intersect' of term
7.443 +| Check_elementwise' of (*special case:*)
7.444 + term * (*(1)the current formula: [x=1,x=...]*)
7.445 + string * (*(2)the pred from Check_elementwise *)
7.446 + term (*(3)composed from (1) and (2): {x. pred}*)
7.447 +| Or_to_List' of term * term (* (a | b, [a,b]) *)
7.448 +| Collect_Trues' of term
7.449 +
7.450 +| Empty_Mstep' | Mstep' of (*for dummies*)
7.451 + theory *
7.452 + string * (*form*)
7.453 + string * (*in Mstep*)
7.454 + string (*result of Mstep".."*)
7.455 +| User' (*internal for ets*) | End_Proof'';(*End_Proof:inout*)
7.456 +(*TODO?: done partially for tests*)
7.457 +fun mstep'2str ma = case ma of
7.458 + Init_Proof' (ppc, spec) =>
7.459 + "Init_Proof' "^(pair2str (strs2str ppc, spec2str spec))
7.460 + | Model_Problem' pblID => "Model_Problem' "^(strs2str pblID )
7.461 + | Refine_Tacitly'(p,prefin)=> "Refine_Tacitly' ("^(strs2str p)^", "^
7.462 + (strs2str prefin)^")"
7.463 + | Refine_Problem' ms => "Refine_Problem' ("^(matchs2str ms)^")"
7.464 +(*| Match_Problem' (pI, (ok, (itms, pre))) =>
7.465 + "Match_Problem' "^(spair2str (strs2str pI,
7.466 + spair2str (bool2str ok,
7.467 + spair2str ("itms2str itms",
7.468 + "items2str pre"))))*)
7.469 + | Add_Given' cterm' => "Add_Given' "(*^cterm'*)
7.470 + | Del_Given' cterm' => "Del_Given' "(*^cterm'*)
7.471 + | Add_Find' cterm' => "Add_Find' "(*^cterm'*)
7.472 + | Del_Find' cterm' => "Del_Find' "(*^cterm'*)
7.473 + | Add_Relation' cterm' => "Add_Relation' "(*^cterm'*)
7.474 + | Del_Relation' cterm' => "Del_Relation' "(*^cterm'*)
7.475 +
7.476 + | Specify_Domain' domID => "Specify_Domain' "^(quote domID )
7.477 + | Specify_Problem' (pI, (ok, (itms, pre))) =>
7.478 + "Specify_Problem' "^(spair2str (strs2str pI,
7.479 + spair2str (bool2str ok,
7.480 + spair2str ("itms2str itms",
7.481 + "items2str pre"))))
7.482 + | Specify_Method' (pI)(*, (ok, (itms, pre)))*) =>
7.483 + "Specify_Method' "^metID2str pI
7.484 + (*---(spair2str (pair2str pI,
7.485 + spair2str (bool2str ok,
7.486 + spair2str ("itms2str itms",
7.487 + "items2str pre"))))--*)
7.488 + | Apply_Method' metID => "Apply_Method' "^(spair2str metID)
7.489 + | Check_Postcond' (pblID,scval) =>
7.490 + "Check_Postcond' "^
7.491 + (spair2str(strs2str pblID,
7.492 + Sign.string_of_term (sign_of thy) scval))
7.493 +
7.494 + | Free_Solve' => "Free_Solve'"
7.495 +
7.496 + | Rewrite_Inst' (*subs,thm'*) _ =>
7.497 + "Rewrite_Inst' "(*^(pair2str (subs2str subs, spair2str thm'))*)
7.498 + | Rewrite' thm' => "Rewrite' "(*^(spair2str thm')*)
7.499 + | Rewrite_Asm' thm' => "Rewrite_Asm' "(*^(spair2str thm')*)
7.500 + | Rewrite_Set_Inst' (*subs,thm'*) _ =>
7.501 + "Rewrite_Set_Inst' "(*^(pair2str (subs2str subs, quote rls))*)
7.502 + | Rewrite_Set'(thy',pasm,rls',f,(f',asm))
7.503 + => "Rewrite_Set' ("^thy'^","^(bool2str pasm)^","^(id_rls rls')^","
7.504 + ^(Sign.string_of_term (sign_of thy) f)^",("^(Sign.string_of_term (sign_of thy) f')
7.505 + ^","^((strs2str o (map (Sign.string_of_term (sign_of thy)))) asm)^"))"
7.506 +
7.507 + | End_Detail' _ => "End_Detail' xxx"
7.508 + | Detail_Set' _ => "Detail_Set' xxx"
7.509 + | Detail_Set_Inst' _ => "Detail_Set_Inst' xxx"
7.510 +
7.511 + | Calculate' _ => "Calculate' "
7.512 + | Substitute' subs => "Substitute' "(*^(subs2str subs)*)
7.513 + | Apply_Assumption' ct's => "Apply_Assumption' "(*^(strs2str ct's)*)
7.514 +
7.515 + | Take' cterm' => "Take' "(*^(quote cterm' )*)
7.516 + | Take_Inst' cterm' => "Take_Inst' "(*^(quote cterm' )*)
7.517 + | Group' (con, ints, _) =>
7.518 + "Group' "^(pair2str (con2str con, ints2str ints))
7.519 + | Subproblem' (spec, oris, pbl_form) =>
7.520 + "Subproblem' "(*^(pair2str (domID, strs2str ,...))*)
7.521 + | End_Subproblem' _ => "End_Subproblem'"
7.522 + | CAScmd' cterm' => "CAScmd' "(*^(quote cterm')*)
7.523 +
7.524 + | Empty_Mstep' => "Empty_Mstep'"
7.525 + | User' => "User'"
7.526 + | Mstep' (_,form,id,result) => "Mstep' (thy,"^form^","^id^","^result^")"
7.527 + | _ => "";
7.528 +
7.529 +(*'executed tactics' (mstep's) with local environment etc.;
7.530 + used for continuing eval script + for generate*)
7.531 +type ets =
7.532 + (loc_ * (* of tactic in scr, tactic (weakly) associated with mstep'*)
7.533 + (mstep' * (* (for generate) *)
7.534 + env * (* with 'tactic=result' as a rule, tactic ev. _not_ ready:
7.535 + for handling 'parallel let'*)
7.536 + env * (* with results of (ready) tacs *)
7.537 + term * (* itr_arg of tactic, for upd. env at Repeat, Try*)
7.538 + term * (* result value of the tac *)
7.539 + safe))
7.540 + list;
7.541 +val Ets = []:ets;
7.542 +
7.543 +
7.544 +fun ets2s (l,(m,eno,env,iar,res,s)) =
7.545 + "\n("^(loc_2str l)^",("^(mstep'2str m)^
7.546 + ",\n ens= "^(subst2str eno)^
7.547 + ",\n env= "^(subst2str env)^
7.548 + ",\n iar= "^(Sign.string_of_term (sign_of thy) iar)^
7.549 + ",\n res= "^(Sign.string_of_term (sign_of thy) res)^
7.550 + ",\n "^(safe2str s)^"))";
7.551 +fun ets2str (ets:ets) = (strs2str o (map ets2s)) ets;
7.552 +
7.553 +
7.554 +type envp = (*assoc-list over variants*)
7.555 + (int * term list) list * (*assoc-list: args of met*)
7.556 + (int * rls) list * (*assoc-list: tacs already done ///15.9.00*)
7.557 + (int * ets) list * (*assoc-list: msteps etc. already done*)
7.558 + (string * pos) list; (*asms * from where*)
7.559 +val empty_envp = ([],[],[],[]):envp;
7.560 +
7.561 +
7.562 +datatype ppobj =
7.563 + PrfObj of {cell : cid, (* 4.00 superfluous: use cid in DG only!!*)
7.564 + form : cterm',
7.565 + mstep : mstep, (*8.01: superfluous -> ets !!!*)
7.566 + loc : istate option * istate option, (*for form, result
7.567 +13.8.02: (None,None) <==> e_istate ! see update_loc, get_loc*)
7.568 + branch: branch,
7.569 + result: cterm', (*20.8.01?->loc/?/// 1.5.02:+[asm]
7.570 + FIXX@ME result:term * term list
7.571 + => applicable_in =..rewrite_set_
7.572 + => rls = {erls: rls (NOT rls'),...}*)
7.573 + ostate: ostate}
7.574 + | PblObj of {cell : cid,
7.575 + origin: (ori list) * spec,
7.576 + model : cterm' ppc, (*1.00. not used anymore*)
7.577 + spec : spec,
7.578 + probl : itm list, (*8.01: TODO a (_*_) list for UNDO*)
7.579 + meth : itm list,
7.580 + env : envp, (*by loc 20.8.01 superfluous;i.e:env<->loc*)
7.581 + loc : istate option * istate option, (*for pbl+met, result
7.582 +20.8.01: loc will hold ets (diss p.94: (mstep',denval(=form|res),loc,env)*)
7.583 + branch: branch,
7.584 + result: cterm', (*20.8.01?->loc/?/// 1.5.02:+[asm]*)
7.585 + ostate: ostate};
7.586 +datatype ptree =
7.587 + EmptyPtree
7.588 + | Nd of ppobj * (ptree list);
7.589 +val e_ptree = EmptyPtree;
7.590 +
7.591 +fun rep_prfobj (PrfObj {cell,form,mstep,loc,branch,result,ostate}) =
7.592 + {cell=cell,form=form,mstep=mstep,loc=loc,branch=branch,result=result,ostate=ostate};
7.593 +fun rep_pblobj (PblObj {cell,origin,model,spec,probl,meth,env,
7.594 + loc,branch,result,ostate}) =
7.595 + {cell=cell,origin=origin,model=model,spec=spec,probl=probl,meth=meth,
7.596 + env=env,loc=loc,branch=branch,result=result,ostate=ostate};
7.597 +fun is_prfobj (PrfObj _) = true
7.598 + | is_prfobj _ =false;
7.599 +(*val is_prfobj' = get_obj is_prfobj; *)
7.600 +fun is_pblobj (PblObj _) = true
7.601 + | is_pblobj _ = false;
7.602 +(*val is_pblobj' = get_obj is_pblobj; 'Error: unbound constructor get_obj'*)
7.603 +
7.604 +
7.605 +exception PTREE of string;
7.606 +fun nth _ [] = raise PTREE "nth _ []"
7.607 + | nth 1 (x::xs) = x
7.608 + | nth n (x::xs) = nth (n-1) xs;
7.609 +(*> nth 2 [11,22,33]; -->> val it = 22 : int*)
7.610 +
7.611 +fun lev_up ([]:pos) = raise PTREE "lev_up []"
7.612 + | lev_up p = (drop_last p):pos;
7.613 +fun lev_on ([]:pos) = raise PTREE "lev_on []"
7.614 + | lev_on pos =
7.615 + let val len = length pos
7.616 + in (drop_last pos) @ [(nth len pos)+1] end;
7.617 +fun lev_pred ([]:pos) = raise PTREE "lev_pred []"
7.618 + | lev_pred (pos:pos) =
7.619 + let val len = length pos
7.620 + in ((drop_last pos) @ [(nth len pos)-1]):pos end;
7.621 +(*lev_pred [1,2,3];
7.622 +val it = [1,2,2] : pos
7.623 +> lev_pred [1];
7.624 +val it = [0] : pos *)
7.625 +fun lev_dn p = p @ [0];
7.626 +(*> (lev_dn o lev_on) [1,2,3];
7.627 +val it = [1,2,4,0] : pos *)
7.628 +fun lev_dn' ((p,p_):pos') = (lev_dn p, Frm):pos';
7.629 +
7.630 +(*4.4.00*)
7.631 +fun lev_up_ ((p,Res):pos') = (lev_up p,Res):pos'
7.632 + | lev_up_ p' = raise error ("lev_up_: called for "^(pos'2str p'));
7.633 +fun lev_dn_ ((p,_):pos') = (lev_dn p,Res):pos'
7.634 +fun ind ((p,_):pos') = length p;
7.635 +
7.636 +(** convert ptree to a string **)
7.637 +
7.638 +(* convert a pos from list to string *)
7.639 +fun pr_pos ps = (space_implode "." (map string_of_int ps))^". ";
7.640 +(* show hd origin or form only *)
7.641 +fun pr_short (p:pos) (PblObj {origin = (ori,_),...}) =
7.642 + ((pr_pos p) ^ " ----- pblobj -----\n")
7.643 +(* ((((Sign.string_of_term (sign_of thy)) o #4 o hd) ori)^" "^
7.644 + (((Sign.string_of_term (sign_of thy)) o hd(*!?!*) o #5 o hd) ori))^
7.645 + "\n") *)
7.646 + | pr_short p (PrfObj {form = form,...}) =
7.647 + ((pr_pos p) ^ form ^ "\n");
7.648 +fun pr_cell (p:pos) (PblObj {cell = c, origin = (ori,_),...}) =
7.649 + ((ints2str c) ^" "^
7.650 + ((((Sign.string_of_term (sign_of thy)) o #4 o hd) ori)^" "^
7.651 + (((Sign.string_of_term (sign_of thy)) o hd(*!?!*) o #5 o hd) ori))^
7.652 + "\n")
7.653 + | pr_cell p (PrfObj {cell = c, form = form,...}) =
7.654 + ((ints2str c) ^" "^ form ^ "\n");
7.655 +
7.656 +
7.657 +(* convert ptree *)
7.658 +fun pr_ptree f pt =
7.659 + let
7.660 + fun pr_pt pfn _ EmptyPtree = ""
7.661 + | pr_pt pfn ps (Nd (b, [])) = pfn ps b
7.662 + | pr_pt pfn ps (Nd (b, ts)) = (pfn ps b)^
7.663 + (prts pfn (ps:pos) 1 ts)
7.664 + and prts pfn ps p [] = ""
7.665 + | prts pfn ps p (t::ts) = (pr_pt pfn (ps @ [p]) t)^
7.666 + (prts pfn ps (p+1) ts)
7.667 + in pr_pt f [] pt end;
7.668 +(*
7.669 +> fun prfn ps b = (pr_pos ps)^" "^b(*TODO*)^"\n";
7.670 +> val pt = ref EmptyPtree;
7.671 +> pt:=Nd("root",
7.672 + [Nd("xx1",[]),
7.673 + Nd("xx2",
7.674 + [Nd("xx2.1.",[]),
7.675 + Nd("xx2.2.",[])]),
7.676 + Nd("xx3",[])]);
7.677 +> writeln (pr_ptree prfn (!pt));
7.678 +*)
7.679 +
7.680 +
7.681 +(** access the branches of ptree **)
7.682 +
7.683 +fun ins_nth 1 e l = e::l
7.684 + | ins_nth n e [] = raise PTREE "ins_nth n e []"
7.685 + | ins_nth n e (l::ls) = l::(ins_nth (n-1) e ls);
7.686 +fun repl [] _ _ = raise PTREE "repl [] _ _"
7.687 + | repl (l::ls) 1 e = e::ls
7.688 + | repl (l::ls) n e = l::(repl ls (n-1) e);
7.689 +fun repl_app ls n e =
7.690 + let val lim = 1 + length ls
7.691 + in if n > lim then raise PTREE "repl_app: n > lim"
7.692 + else if n = lim then ls @ [e]
7.693 + else repl ls n e end;
7.694 +(*
7.695 +> repl [1,2,3] 2 22222;
7.696 +val it = [1,22222,3] : int list
7.697 +> repl_app [1,2,3,4] 5 5555;
7.698 +val it = [1,2,3,4,5555] : int list
7.699 +> repl_app [1,2,3] 2 22222;
7.700 +val it = [1,22222,3] : int list
7.701 +> repl_app [1] 2 22222 ;
7.702 +val it = [1,22222] : int list
7.703 +*)
7.704 +
7.705 +
7.706 +(** get from obj at pos by f : ppobj -> 'a **)
7.707 +
7.708 +fun get_obj f EmptyPtree _ = raise PTREE "get_obj f EmptyPtree"
7.709 + | get_obj f (Nd (b, _)) [] = f b
7.710 + | get_obj f (Nd (b, bs)) (p::ps) =
7.711 + let val _ = (nth p bs) handle _ => raise PTREE ("get_obj: pos = "^
7.712 + (ints2str' (p::ps))^" does not exist");
7.713 + in (get_obj f (nth p bs) (ps:pos))
7.714 + handle _ => raise PTREE ("get_obj: at pos = "^
7.715 + (ints2str' (p::ps))^" wrong type of ppobj")
7.716 + (*FIXME: 'wrong type..' raised also if pos doesn't exist*)
7.717 + end;
7.718 +
7.719 +(* for use by get_obj *)
7.720 +fun g_cell (PblObj {cell = c,...}) = c
7.721 + | g_cell (PrfObj {cell = c,...}) = c;
7.722 +fun g_form (PrfObj {form = f,...}) = f
7.723 + | g_form _ = raise PTREE "g_origin not for PblObj";
7.724 +fun g_origin (PblObj {origin = ori,...}) = ori
7.725 + | g_origin _ = raise PTREE "g_origin not for PrfObj";
7.726 +fun g_model (PblObj {model = f,...}) = f
7.727 + | g_model _ = raise PTREE "g_model not for PrfObj";
7.728 +fun g_spec (PblObj {spec = s,...}) = s
7.729 + | g_spec _ = raise PTREE "g_spec not for PrfObj";
7.730 +fun g_pbl (PblObj {probl = p,...}) = p
7.731 + | g_pbl _ = raise PTREE "g_pbl not for PrfObj";
7.732 +fun g_met (PblObj {meth = p,...}) = p
7.733 + | g_met _ = raise PTREE "g_met not for PrfObj";
7.734 +fun g_domID (PblObj {spec = (d,_,_),...}) = d
7.735 + | g_domID _ = raise PTREE "g_metID not for PrfObj";
7.736 +fun g_metID (PblObj {spec = (_,_,m),...}) = m
7.737 + | g_metID _ = raise PTREE "g_metID not for PrfObj";
7.738 +fun g_args (PblObj {env = (a,_,_,_),...}) = a
7.739 + | g_args _ = raise PTREE "g_args not for PrfObj";
7.740 +fun g_tacs (PblObj {env = (_,a,_,_),...}) = a
7.741 + | g_tacs _ = raise PTREE "g_tacs not for PrfObj";
7.742 +fun g_ets (PblObj {env = (_,_,a,_),...}) = a
7.743 + | g_ets _ = raise PTREE "g_tacs not for PrfObj";
7.744 +fun g_asm (PblObj {env = (_,_,_,a),...}) = a
7.745 + | g_asm _ = raise PTREE "g_asm not for PrfObj";
7.746 +fun g_loc (PblObj {loc = l,...}) = l
7.747 + | g_loc (PrfObj {loc = l,...}) = l;
7.748 +fun g_branch (PblObj {branch = b,...}) = b
7.749 + | g_branch (PrfObj {branch = b,...}) = b;
7.750 +fun g_mstep (PblObj {spec = (d,p,m),...}) = Apply_Method m
7.751 + | g_mstep (PrfObj {mstep = m,...}) = m;
7.752 +fun g_result (PblObj {result = r,...}) = r
7.753 + | g_result (PrfObj {result = r,...}) = r;
7.754 +fun g_ostate (PblObj {ostate = r,...}) = r
7.755 + | g_ostate (PrfObj {ostate = r,...}) = r;
7.756 +
7.757 +fun gpt_cell (Nd (PblObj {cell = c,...},_)) = c
7.758 + | gpt_cell (Nd (PrfObj {cell = c,...},_)) = c;
7.759 +
7.760 +fun existpt pos pt = can (get_obj I pt) pos;
7.761 +
7.762 +(*.find the next parent which is a PblObj in ptree.*)
7.763 +fun par_pblobj pt ([]:pos) = ([]:pos)
7.764 + | par_pblobj pt p =
7.765 + let fun par pt [] = []
7.766 + | par pt p = if is_pblobj (get_obj I pt p) then p
7.767 + else par pt (lev_up p)
7.768 + in par pt (lev_up p) end;
7.769 +(* lev_up for hard_gen operating with pos = [...,0] *)
7.770 +
7.771 +(*.find the next parent, which is either a PblObj (return true)
7.772 + or a PrfObj with mstep = Detail_Set (return false).*)
7.773 +(*FIXME.3.4.03:re-organize par_pbl_det after rls' --> rls*)
7.774 +fun par_pbl_det pt ([]:pos) = (true, []:pos, Erls)
7.775 + | par_pbl_det pt p =
7.776 + let fun par pt [] = (true, [], Erls)
7.777 + | par pt p = if is_pblobj (get_obj I pt p) then (true, p, Erls)
7.778 + else case get_obj g_mstep pt p of
7.779 + Detail_Set rls' => (false, p, assoc_rls rls')
7.780 + | _ => par pt (lev_up p)
7.781 + in par pt (lev_up p) end;
7.782 +
7.783 +(** get from the whole ptree by f : ppobj -> 'a **)
7.784 +
7.785 +fun get_all f EmptyPtree = []
7.786 + | get_all f (Nd (b, [])) = [f b]
7.787 + | get_all f (Nd (b, bs)) = [f b] @ (get_alls f bs)
7.788 +and get_alls f [] = []
7.789 + | get_alls f pts = flat (map (get_all f) pts);
7.790 +
7.791 +
7.792 +(** insert obj b into ptree at pos **)
7.793 +
7.794 +fun insert b EmptyPtree [] = Nd (b, [])
7.795 + | insert b EmptyPtree _ = raise PTREE "insert b Empty _"
7.796 + | insert b (Nd ( _, _)) [] = raise PTREE "insert b _ []"
7.797 + | insert b (Nd (b', bs)) (p::[]) =
7.798 + Nd (b', repl_app bs p (Nd (b,[])))
7.799 + | insert b (Nd (b', bs)) (p::ps) =
7.800 + Nd (b', repl_app bs p (insert b (nth p bs) (ps:pos)));
7.801 +(*
7.802 +> type ppobj = string;
7.803 +> writeln (pr_ptree prfn (!pt));
7.804 + val pt = ref Empty;
7.805 + pt:= insert ("root":ppobj) EmptyPtree [];
7.806 + pt:= insert ("xx1":ppobj) (!pt) [1];
7.807 + pt:= insert ("xx2":ppobj) (!pt) [2];
7.808 + pt:= insert ("xx3":ppobj) (!pt) [3];
7.809 + pt:= insert ("xx2.1":ppobj) (!pt) [2,1];
7.810 + pt:= insert ("xx2.2":ppobj) (!pt) [2,2];
7.811 + pt:= insert ("xx2.1.1":ppobj) (!pt) [2,1,1];
7.812 + pt:= insert ("xx2.1.2":ppobj) (!pt) [2,1,2];
7.813 + pt:= insert ("xx2.1.3":ppobj) (!pt) [2,1,3];
7.814 +*)
7.815 +
7.816 +
7.817 +(** apply f to obj at pos, f: ppobj -> ppobj **)
7.818 +
7.819 +fun appl_to_node f (Nd (b,bs)) = Nd (f b, bs);
7.820 +fun appl_obj f EmptyPtree [] = EmptyPtree
7.821 + | appl_obj f EmptyPtree _ = raise PTREE "appl_obj f Empty _"
7.822 + | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs)
7.823 + | appl_obj f (Nd (b, bs)) (p::[]) =
7.824 + Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs))
7.825 + | appl_obj f (Nd (b, bs)) (p::ps) =
7.826 + Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos)));
7.827 +
7.828 +(* for use by appl_obj *)
7.829 +fun repl_form f (PrfObj {cell=c,form= _,mstep=mstep,loc=loc,
7.830 + branch=branch,result=result,ostate=ostate}) =
7.831 + PrfObj {cell=c,form= f,mstep=mstep,loc=loc,
7.832 + branch=branch,result=result,ostate=ostate}
7.833 + | repl_form _ _ = raise PTREE "repl_form takes no PblObj";
7.834 +fun repl_model f (PblObj {cell=cell,origin=origin,model=_,
7.835 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
7.836 + branch=branch,result=result,ostate=ostate}) =
7.837 + PblObj {cell=cell,origin=origin,model= f,spec=spec,probl=probl,
7.838 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.839 + | repl_model _ _ = raise PTREE "repl_model takes no PrfObj";
7.840 +fun repl_pbl x (PblObj {cell=cell,origin=origin,model=model,
7.841 + spec=spec,probl=_,meth=meth,env=env,loc=loc,
7.842 + branch=branch,result=result,ostate=ostate}) =
7.843 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl= x,
7.844 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.845 + | repl_pbl _ _ = raise PTREE "repl_pbl takes no PrfObj";
7.846 +fun repl_met x (PblObj {cell=cell,origin=origin,model=model,
7.847 + spec=spec,probl=probl,meth=_,env=env,loc=loc,
7.848 + branch=branch,result=result,ostate=ostate}) =
7.849 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.850 + meth= x,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.851 + | repl_met _ _ = raise PTREE "repl_pbl takes no PrfObj";
7.852 +
7.853 +fun repl_spec x (PblObj {cell=cell,origin=origin,model=model,
7.854 + spec= _,probl=probl,meth=meth,env=env,loc=loc,
7.855 + branch=branch,result=result,ostate=ostate}) =
7.856 + PblObj {cell=cell,origin=origin,model=model,spec= x,probl=probl,
7.857 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.858 + | repl_spec _ _ = raise PTREE "repl_domID takes no PrfObj";
7.859 +fun repl_domID x (PblObj {cell=cell,origin=origin,model=model,
7.860 + spec=(_,p,m),probl=probl,meth=meth,env=env,loc=loc,
7.861 + branch=branch,result=result,ostate=ostate}) =
7.862 + PblObj {cell=cell,origin=origin,model=model,spec=(x,p,m),probl=probl,
7.863 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.864 + | repl_domID _ _ = raise PTREE "repl_domID takes no PrfObj";
7.865 +fun repl_pblID x (PblObj {cell=cell,origin=origin,model=model,
7.866 + spec=(d,_,m),probl=probl,meth=meth,env=env,loc=loc,
7.867 + branch=branch,result=result,ostate=ostate}) =
7.868 + PblObj {cell=cell,origin=origin,model=model,spec=(d,x,m),probl=probl,
7.869 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.870 + | repl_pblID _ _ = raise PTREE "repl_pblID takes no PrfObj";
7.871 +fun repl_metID x (PblObj {cell=cell,origin=origin,model=model,
7.872 + spec=(d,p,_),probl=probl,meth=meth,env=env,loc=loc,
7.873 + branch=branch,result=result,ostate=ostate}) =
7.874 + PblObj {cell=cell,origin=origin,model=model,spec=(d,p,x),probl=probl,
7.875 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
7.876 + | repl_metID _ _ = raise PTREE "repl_metID takes no PrfObj";
7.877 +
7.878 +fun repl_result l f' s (PrfObj {cell=cell,form=form,mstep=mstep,loc=_,
7.879 + branch=branch,result = _ ,ostate = _}) =
7.880 + PrfObj {cell=cell,form=form,mstep=mstep,loc= l,
7.881 + branch=branch,result = f',ostate = s}
7.882 + | repl_result l f' s (PblObj {cell=cell,origin=origin,model=model,
7.883 + spec=spec,probl=probl,meth=meth,env=env,loc=_,
7.884 + branch=branch,result= _ ,ostate= _}) =
7.885 + PblObj {cell=cell,origin=origin,model=model,
7.886 + spec=spec,probl=probl,meth=meth,env=env,loc= l,
7.887 + branch=branch,result= f',ostate= s};
7.888 +
7.889 +fun repl_mstep x (PrfObj {cell=cell,form=form,mstep= _,loc=loc,
7.890 + branch=branch,result=result,ostate=ostate}) =
7.891 + PrfObj {cell=cell,form=form,mstep= x,loc=loc,
7.892 + branch=branch,result=result,ostate=ostate}
7.893 + | repl_mstep _ _ = raise PTREE "repl_mstep takes no PblObj";
7.894 +
7.895 +fun repl_branch b (PblObj {cell=cell,origin=origin,model=model,
7.896 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
7.897 + branch= _,result=result,ostate=ostate}) =
7.898 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.899 + meth=meth,env=env,loc=loc,branch= b,result=result,ostate=ostate}
7.900 + | repl_branch b (PrfObj {cell=cell,form=form,mstep=mstep,loc=loc,
7.901 + branch= _,result=result,ostate=ostate}) =
7.902 + PrfObj {cell=cell,form=form,mstep=mstep,loc=loc,
7.903 + branch= b,result=result,ostate=ostate};
7.904 +
7.905 +fun repl_args args
7.906 + (PblObj {cell=cell,origin=origin,model=model,
7.907 + spec=spec,probl=probl,meth=meth,env=(_,tac,ets,asm),loc=loc,
7.908 + branch=branch,result=result,ostate=ostate}) =
7.909 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.910 + meth=meth,env=(args,tac,ets,asm),loc=loc,branch=branch,
7.911 + result=result,ostate=ostate}
7.912 + | repl_args _ _ = raise PTREE "repl_args takes no PrfObj";
7.913 +fun repl_tacs erul
7.914 + (PblObj {cell=cell,origin=origin,model=model,
7.915 + spec=spec,probl=probl,meth=meth,env=(arg,_,ets,asm),loc=loc,
7.916 + branch=branch,result=result,ostate=ostate}) =
7.917 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.918 + meth=meth,env=(arg,erul,ets,asm),loc=loc,branch=branch,
7.919 + result=result,ostate=ostate}
7.920 + | repl_tacs _ _ = raise PTREE "repl_tacs takes no PrfObj";
7.921 +fun repl_ets ets
7.922 + (PblObj {cell=cell,origin=origin,model=model,
7.923 + spec=spec,probl=probl,meth=meth,env=(arg,tac,_,asm),loc=loc,
7.924 + branch=branch,result=result,ostate=ostate}) =
7.925 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.926 + meth=meth,env=(arg,tac,ets,asm),loc=loc,branch=branch,
7.927 + result=result,ostate=ostate}
7.928 + | repl_ets _ _ = raise PTREE "repl_ets takes no PrfObj";
7.929 +
7.930 +fun repl_oris oris
7.931 + (PblObj {cell=cell,origin=(_,spe),model=model,
7.932 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
7.933 + branch=branch,result=result,ostate=ostate}) =
7.934 + PblObj{cell=cell,origin=(oris,spe),model=model,spec=spec,probl=probl,
7.935 + meth=meth,env=env,loc=loc,branch=branch,
7.936 + result=result,ostate=ostate}
7.937 + | repl_oris _ _ = raise PTREE "repl_oris takes no PrfObj";
7.938 +fun repl_orispec spe
7.939 + (PblObj {cell=cell,origin=(oris,_),model=model,
7.940 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
7.941 + branch=branch,result=result,ostate=ostate}) =
7.942 + PblObj{cell=cell,origin=(oris,spe),model=model,spec=spec,probl=probl,
7.943 + meth=meth,env=env,loc=loc,branch=branch,
7.944 + result=result,ostate=ostate}
7.945 + | repl_orispec _ _ = raise PTREE "repl_orispec takes no PrfObj";
7.946 +
7.947 +fun repl_loc l (PblObj {cell=cell,origin=origin,model=model,
7.948 + spec=spec,probl=probl,meth=meth,env=env,loc=_,
7.949 + branch=branch,result=result,ostate=ostate}) =
7.950 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.951 + meth=meth,env=env,loc=l,branch=branch,result=result,ostate=ostate}
7.952 + | repl_loc l (PrfObj {cell=cell,form=form,mstep=mstep,loc=_,
7.953 + branch=branch,result=result,ostate=ostate}) =
7.954 + PrfObj {cell=cell,form=form,mstep=mstep,loc= l,
7.955 + branch=branch,result=result,ostate=ostate};
7.956 +
7.957 +fun uni__asm asm'
7.958 + (PblObj {cell=cell,origin=origin,model=model,
7.959 + spec=spec,probl=probl,meth=meth,env=(arg,tac,ets,asm),loc=loc,
7.960 + branch=branch,result=result,ostate=ostate}) =
7.961 + PblObj {cell=cell,origin=origin,model=model,spec=spec,probl=probl,
7.962 + meth=meth,env=(arg,tac,ets,asm union asm'),loc=loc,branch=branch,
7.963 + result=result,ostate=ostate}
7.964 + | uni__asm _ _ = raise PTREE "uni__asm takes no PrfObj";
7.965 +fun uni__cid cell'
7.966 + (PblObj {cell=cell,origin=origin,model=model,
7.967 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
7.968 + branch=branch,result=result,ostate=ostate}) =
7.969 + PblObj {cell=cell union cell',origin=origin,model=model,spec=spec,probl=probl,
7.970 + meth=meth,env=env,loc=loc,branch=branch,
7.971 + result=result,ostate=ostate}
7.972 + | uni__cid cell'
7.973 + (PrfObj {cell=cell,form=form,mstep=mstep,loc=loc,
7.974 + branch=branch,result=result,ostate=ostate}) =
7.975 + PrfObj {cell=cell union cell',form=form,mstep=mstep,loc=loc,
7.976 + branch=branch,result=result,ostate=ostate};
7.977 +
7.978 +
7.979 +
7.980 +
7.981 +(** applies (snd f) to 1 level of branches if ((fst f) b),
7.982 + f : (ppobj -> bool) * (int -> ptree list -> ptree list) **)
7.983 +
7.984 +fun appl_branch f EmptyPtree [] = (EmptyPtree, false)
7.985 + | appl_branch f EmptyPtree _ = raise PTREE "appl_branch f Empty _"
7.986 + | appl_branch f (Nd ( _, _)) [] = raise PTREE "appl_branch f _ []"
7.987 + | appl_branch f (Nd (b, bs)) (p::[]) =
7.988 + if (fst f) b then (Nd (b, (snd f) (p:posel) bs), true)
7.989 + else (Nd (b, bs), false)
7.990 + | appl_branch f (Nd (b, bs)) (p::ps) =
7.991 + let val (b',bool) = appl_branch f (nth p bs) ps
7.992 + in (Nd (b, repl_app bs p b'), bool) end;
7.993 +
7.994 +(* expl for f as used with appl_branch *)
7.995 +fun test_trans (PrfObj{branch = Transitive,...}) = true
7.996 + | test_trans (PblObj{branch = Transitive,...}) = true
7.997 + | test_trans _ = false;
7.998 +(*
7.999 +val cut_branch = (test_trans, curry take):
7.1000 + (ppobj -> bool) * (int -> ptree list -> ptree list);
7.1001 +.. formlery used for ...
7.1002 +fun cut_tree _ [] = EmptyPtree
7.1003 + | cut_tree pt pos =
7.1004 + let val (pt',cut) = appl_branch cut_branch pt pos
7.1005 + in if cut andalso length pos > 1 then cut_tree pt' (lev_up pos)
7.1006 + else pt' end;
7.1007 +*)
7.1008 +
7.1009 +(* specialized appl_branch for cut + return cuts *)
7.1010 +fun appl_cut EmptyPtree _ = raise PTREE "appl_cut Empty _"
7.1011 + | appl_cut (Nd ( _, _)) [] = raise PTREE "appl_cut _ []"
7.1012 + | appl_cut (Nd (b, bs)) (p::[]) =
7.1013 + if test_trans b
7.1014 + then (Nd (b, take (p:posel, bs)), true,
7.1015 + (flat o (map (get_all g_cell))) (takerest (p,bs)))
7.1016 + else (Nd (b, bs), false, [])
7.1017 + | appl_cut (Nd (b, bs)) (p::ps) =
7.1018 + let val (b',bool,cuts) = appl_cut (nth p bs) ps
7.1019 + in (Nd (b, repl_app bs p b'), bool, cuts) end;
7.1020 +
7.1021 +
7.1022 +(* cut objs below and after a position as long as Transitive
7.1023 + FIXME?: whole ptree copied for each branch-level cut
7.1024 + FIXME!: should return pos list instead cellID list*)
7.1025 +fun cut_tree _ ([]:pos) = raise PTREE "cut_tree _ []"
7.1026 + | cut_tree pt pos =
7.1027 + let
7.1028 + fun cutfn pt cuts pos =
7.1029 + let val (pt', cut, cuts') = appl_cut pt pos;
7.1030 +(* val _ = writeln (foldr (op^) (cuts',"")) *)
7.1031 + in if cut andalso length pos > 1
7.1032 + then cutfn pt' (cuts @ cuts') (lev_up pos)
7.1033 + else (pt',cuts @ cuts') end
7.1034 + in (apsnd flat (cutfn pt [] pos)):ptree * cid end;
7.1035 +(* pt of max_on_surface
7.1036 +> writeln (pr_ptree pr_cell pt);
7.1037 +> val (pt',cutl) = cut_tree pt [4,1,1,1,1];
7.1038 +val cutl = ["[4,1,1,1,2]:","[4,1,1,1,3]:"] : cid list
7.1039 +> writeln (pr_ptree pr_cell pt');
7.1040 +
7.1041 +> val (pt'',cutl) = cut_tree pt [4,1];
7.1042 +val cutl = [] : cid list
7.1043 +> writeln (pr_ptree pr_cell pt'');
7.1044 +
7.1045 +> val (pt''',cutl) = cut_tree pt [1,1];
7.1046 +val cutl =
7.1047 + ["[1,2]:","[2]:","[3]:","[3,1]:","[3,2]:","[4]:","[4,1]:","[4,1,1]:",...]
7.1048 + : cid list
7.1049 +> writeln (pr_ptree pr_cell pt''');
7.1050 +*)
7.1051 +
7.1052 +
7.1053 +
7.1054 +fun append_atomic p l f r f' s pt =
7.1055 + let
7.1056 + val (iss, f) = if existpt p pt andalso get_obj g_mstep pt p=Empty_Mstep
7.1057 + then (*after Take*)
7.1058 + ((fst (get_obj g_loc pt p), Some l),
7.1059 + get_obj g_form pt p)
7.1060 + else ((Some l, None), f)
7.1061 + in insert (PrfObj {cell = [(*3.00. unused*)],
7.1062 + form = f,
7.1063 + mstep = r,
7.1064 + loc = iss,
7.1065 + branch= NoBranch,
7.1066 + result= f',
7.1067 + ostate= s}) pt p end;
7.1068 +
7.1069 +(*20.8.02: cappend_* FIXXXXME cut branches below cannot be decided here:
7.1070 + detail - generate - cappend: inserted, not appended !!!
7.1071 +
7.1072 + cut decided in applicable_in !!!
7.1073 +*)
7.1074 +fun cappend_atomic pt p loc f r f' s =
7.1075 + apfst (append_atomic p loc f r f' s) (cut_tree pt p);
7.1076 +
7.1077 +(* called by Take *)
7.1078 +fun append_form p l f pt =
7.1079 + insert (PrfObj {cell = [(*3.00. unused*)],
7.1080 + form = (*if existpt p pt
7.1081 + andalso get_obj g_mstep pt p = Empty_Mstep
7.1082 + (*distinction from 'old' (+complete!) pobjs*)
7.1083 + then get_obj g_form pt p else*) f,
7.1084 + mstep = Empty_Mstep,
7.1085 + loc = (Some l, None),
7.1086 + branch= NoBranch,
7.1087 + result= empty_cterm',
7.1088 + ostate= Incomplete}) pt p;
7.1089 +fun cappend_form pt p loc f =
7.1090 + apfst (append_form p loc f) (cut_tree pt p);
7.1091 +
7.1092 +
7.1093 +
7.1094 +fun append_result pt p l f s =
7.1095 + (appl_obj (repl_result (fst (get_obj g_loc pt p),
7.1096 + (Some l)) f s) pt p, []);
7.1097 +
7.1098 +
7.1099 +
7.1100 +fun append_parent p l f r b pt =
7.1101 + let
7.1102 + val (ll,f) = if existpt p pt andalso get_obj g_mstep pt p=Empty_Mstep
7.1103 + then ((fst (get_obj g_loc pt p), Some l),
7.1104 + get_obj g_form pt p)
7.1105 + else ((Some l, None), f)
7.1106 + in insert (PrfObj
7.1107 + {cell = [(*unused*)],
7.1108 + form = f,
7.1109 + mstep = r,
7.1110 + loc = ll,
7.1111 + branch= b,
7.1112 + result= empty_cterm',
7.1113 + ostate= Incomplete}) pt p end;
7.1114 +fun cappend_parent pt p loc f r b =
7.1115 + apfst (append_parent p loc f r b) (cut_tree pt p);
7.1116 +
7.1117 +(*13.8.02 deleted again --- istate option
7.1118 +fun init_ptree (strs,spec) =
7.1119 + (Nd (PblObj
7.1120 + {cell = [(*3.00. unused*)],
7.1121 + origin= (strs,spec),
7.1122 + model = empty_ppc_ct',
7.1123 + spec = empty_spec,
7.1124 + probl = []:itm list,
7.1125 + meth = []:itm list,
7.1126 + env = empty_envp,
7.1127 + loc = (None, None),
7.1128 + branch= NoBranch,
7.1129 + result= empty_cterm',
7.1130 + ostate= Incomplete},[]));----------------*)
7.1131 +
7.1132 +fun append_problem [] l (strs,spec) _ =
7.1133 + (Nd (PblObj
7.1134 + {cell = [(*3.00. unused*)],
7.1135 + origin= (strs,spec),
7.1136 + model = empty_ppc_ct',
7.1137 + spec = empty_spec,
7.1138 + probl = []:itm list,
7.1139 + meth = []:itm list,
7.1140 + env = empty_envp,
7.1141 + loc = (Some l, None),
7.1142 + branch= NoBranch,
7.1143 + result= empty_cterm',
7.1144 + ostate= Incomplete},[]))
7.1145 + | append_problem p l (strs,spec) pt =
7.1146 + insert (PblObj
7.1147 + {cell = [(*3.00. unused*)],
7.1148 + origin= (strs,spec),
7.1149 + model = empty_ppc_ct',
7.1150 + spec = empty_spec,
7.1151 + probl = []:itm list,
7.1152 + meth = []:itm list,
7.1153 + env = empty_envp,
7.1154 + loc = (Some l, None),
7.1155 + branch= NoBranch,
7.1156 + result= empty_cterm',
7.1157 + ostate= Incomplete}) pt p;
7.1158 +fun cappend_problem _ [] loc (oris, spec) =
7.1159 + (append_problem [] loc (oris, spec) EmptyPtree,[])
7.1160 + | cappend_problem pt p loc (oris, spec) =
7.1161 + apfst (append_problem p (loc:istate) (oris, spec)) (cut_tree pt p);
7.1162 +
7.1163 +
7.1164 +(* use"ME/sequent.sml";
7.1165 + use"sequent.sml";
7.1166 + *)
7.1167 +
7.1168 +
7.1169 +
7.1170 +(*
7.1171 +fun update_model pt pos x = appl_obj (repl_model x) pt pos;
7.1172 + 1.00 not used anymore*)
7.1173 +fun update_args pt pos x = appl_obj (repl_args x) pt pos;
7.1174 +fun update_tacs pt pos x = appl_obj (repl_tacs x) pt pos;
7.1175 +fun update_ets pt pos x = appl_obj (repl_ets x) pt pos;
7.1176 +fun update_domID pt pos x = appl_obj (repl_domID x) pt pos;
7.1177 +fun update_pblID pt pos x = appl_obj (repl_pblID x) pt pos;
7.1178 +fun update_metID pt pos x = appl_obj (repl_metID x) pt pos;
7.1179 +fun update_spec pt pos x = appl_obj (repl_spec x) pt pos;
7.1180 +
7.1181 +fun update_pbl pt pos x = appl_obj (repl_pbl x) pt pos;
7.1182 +fun update_pblppc pt pos x = appl_obj (repl_pbl x) pt pos;
7.1183 +
7.1184 +fun update_met pt pos x = appl_obj (repl_met x) pt pos;
7.1185 +(*1.09.01 ----
7.1186 +fun update_metppc pt pos x =
7.1187 + let val {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,...} =
7.1188 + get_obj g_met pt pos
7.1189 + in appl_obj (repl_met
7.1190 + {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,ppc=x})
7.1191 + pt pos end;*)
7.1192 +fun update_metppc pt pos x = appl_obj (repl_met x) pt pos;
7.1193 +
7.1194 +fun union_asm pt pos x = appl_obj (uni__asm x) pt pos;
7.1195 +fun union_cid pt pos x = appl_obj (uni__cid x) pt pos;
7.1196 +
7.1197 +fun update_branch pt pos x = appl_obj (repl_branch x) pt pos;
7.1198 +fun update_mstep pt pos x = appl_obj (repl_mstep x) pt pos;
7.1199 +
7.1200 +fun update_oris pt pos x = appl_obj (repl_oris x) pt pos;
7.1201 +fun update_orispec pt pos x = appl_obj (repl_orispec x) pt pos;
7.1202 +
7.1203 + (*done by append_* !! 3.5.02*)
7.1204 +fun update_loc pt (p,_) (ScrState ([],[],None,
7.1205 + Const ("empty",_),Sundef,false)) =
7.1206 + appl_obj (repl_loc (None,None)) pt p
7.1207 + | update_loc pt (p,Res) x =
7.1208 + let val (lform,_) = get_obj g_loc pt p
7.1209 + in appl_obj (repl_loc (lform,Some x)) pt p end
7.1210 +
7.1211 + | update_loc pt (p,_) x =
7.1212 + let val (_,lres) = get_obj g_loc pt p
7.1213 + in appl_obj (repl_loc (Some x,lres)) pt p end;
7.1214 +
7.1215 +(*13.8.02---------------------------
7.1216 +fun get_loc EmptyPtree _ = None
7.1217 + | get_loc pt (p,Res) =
7.1218 + let val (lfrm,lres) = get_obj g_loc pt p
7.1219 + in if lres = e_istate then lfrm else lres end
7.1220 + | get_loc pt (p,_) =
7.1221 + let val (lfrm,lres) = get_obj g_loc pt p
7.1222 + in if lfrm = e_istate then lres else lfrm end; 5.10.00: too liberal ?*)
7.1223 +(*13.8.02: options, because istate is no equalitype any more*)
7.1224 +fun get_loc EmptyPtree _ = e_istate
7.1225 + | get_loc pt (p,Res) =
7.1226 + (case get_obj g_loc pt p of
7.1227 + (Some i, None) => i
7.1228 + | (None , None) => e_istate
7.1229 + | (_ , Some i) => i)
7.1230 + | get_loc pt (p,_) =
7.1231 + (case get_obj g_loc pt p of
7.1232 + (None , Some i) => i (*13.8.02 just copied from ^^^: too liberal ?*)
7.1233 + | (None , None) => e_istate
7.1234 + | (Some i, _) => i);
7.1235 +val get_istate = get_loc; (*3.5.02*)
7.1236 +
7.1237 +fun get_assumptions pt p = (map fst) (get_obj g_asm pt (par_pblobj pt p));
7.1238 +fun get_assumptions' pt p = strs2str (get_assumptions pt p);
7.1239 +
7.1240 +
7.1241 +(*TODO: fun ... writeln (pr_ptree pr_short pt); *)
7.1242 +
7.1243 +(*---------
7.1244 +end
7.1245 +
7.1246 +open Ptree;
7.1247 +----------*)
7.1248 +
7.1249 +(*pos of the formula on FE relative to the current pos,
7.1250 + which is the next writepos*)
7.1251 +fun pre_pos ([]:pos) = []:pos
7.1252 + | pre_pos pp =
7.1253 + let val (ps,p) = split_last pp
7.1254 + in case p of 1 => ps | n => ps @ [n-1] end;
7.1255 +
7.1256 +
7.1257 +
7.1258 +(*
7.1259 + cd ~/Isabelle/Zerlege-Isa98-1/src/HOL/
7.1260 + sml @SMLload=HOL-plus
7.1261 + cd"~/MathEngine99/src/";
7.1262 + use"ROOT.sml";
7.1263 +
7.1264 + use"ME/sequent.sml";
7.1265 + use"sequent.sml";
7.1266 +
7.1267 +*)
7.1268 +
8.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2 +++ b/src/sml/ME/solve.sml Thu Apr 17 18:01:03 2003 +0200
8.3 @@ -0,0 +1,316 @@
8.4 +(* use"../ME/solve.sml";
8.5 + use"ME/solve.sml";
8.6 + use"solve.sml";
8.7 + W.N.10.12.99
8.8 +
8.9 + cd ~/Isabelle/Zerlege-Isa98-1/src/HOL/
8.10 + /src/HOL> sml @SMLload=HOL-plus
8.11 + cd"~/MathEngine99/src/";
8.12 + use"ROOT.sml";
8.13 +*)
8.14 +
8.15 +fun safe (ScrState (_,_,_,_,s,_)) = s
8.16 + | safe (RrlsState _) = Safe;
8.17 +
8.18 +type mstID = string;
8.19 +type mstep_ = mstID * mstep; (*DG <-> ME*)
8.20 +val e_mstep_ = ("Empty_Mstep", Empty_Mstep):mstep_;
8.21 +
8.22 +fun mk_mstep_ m = case m of
8.23 + Init_Proof (ppc, spec) => ("Init_Proof", Init_Proof (ppc, spec ))
8.24 +| Model_Problem pblID => ("Model_Problem", Model_Problem pblID)
8.25 +| Refine_Tacitly pblID => ("Refine_Tacitly", Refine_Tacitly pblID)
8.26 +| Refine_Problem pblID => ("Refine_Problem", Refine_Problem pblID)
8.27 +| Add_Given cterm' => ("Add_Given", Add_Given cterm')
8.28 +| Del_Given cterm' => ("Del_Given", Del_Given cterm')
8.29 +| Add_Find cterm' => ("Add_Find", Add_Find cterm')
8.30 +| Del_Find cterm' => ("Del_Find", Del_Find cterm')
8.31 +| Add_Relation cterm' => ("Add_Relation", Add_Relation cterm')
8.32 +| Del_Relation cterm' => ("Del_Relation", Del_Relation cterm')
8.33 +
8.34 +| Specify_Domain domID => ("Specify_Domain", Specify_Domain domID)
8.35 +| Specify_Problem pblID => ("Specify_Problem", Specify_Problem pblID)
8.36 +| Specify_Method metID => ("Specify_Method", Specify_Method metID)
8.37 +| Apply_Method metID => ("Apply_Method", Apply_Method metID)
8.38 +| Check_Postcond pblID => ("Check_Postcond", Check_Postcond pblID)
8.39 +| Free_Solve => ("Free_Solve",Free_Solve)
8.40 +
8.41 +| Rewrite_Inst (subs, thm') => ("Rewrite_Inst", Rewrite_Inst (subs, thm'))
8.42 +| Rewrite thm' => ("Rewrite", Rewrite thm')
8.43 +| Rewrite_Asm thm' => ("Rewrite_Asm", Rewrite_Asm thm')
8.44 +| Rewrite_Set_Inst (subs, rls')
8.45 + => ("Rewrite_Set_Inst", Rewrite_Set_Inst (subs, rls'))
8.46 +| Rewrite_Set rls' => ("Rewrite_Set", Rewrite_Set rls')
8.47 +| End_Ruleset => ("End_Ruleset", End_Ruleset)
8.48 +
8.49 +| End_Detail => ("End_Detail", End_Detail)
8.50 +| Detail_Set rls' => ("Detail_Set", Detail_Set rls')
8.51 +| Detail_Set_Inst (s, rls') => ("Detail_Set_Inst", Detail_Set_Inst (s, rls'))
8.52 +
8.53 +| Calculate op_ => ("Calculate", Calculate op_)
8.54 +| Substitute subs => ("Substitute", Substitute subs)
8.55 +| Apply_Assumption cts' => ("Apply_Assumption", Apply_Assumption cts')
8.56 +
8.57 +| Take cterm' => ("Take", Take cterm')
8.58 +| Take_Inst cterm' => ("Take_Inst", Take_Inst cterm')
8.59 +| Group (con, ints) => ("Group", Group (con, ints))
8.60 +| Subproblem (domID, pblID) => ("Subproblem", Subproblem (domID, pblID))
8.61 +(*
8.62 +| Subproblem_Full(spec,cts')=> ("Subproblem_Full", Subproblem_Full(spec,cts'))
8.63 +*)
8.64 +| End_Subproblem => ("End_Subproblem",End_Subproblem)
8.65 +| CAScmd cterm' => ("CAScmd", CAScmd cterm')
8.66 +
8.67 +| Split_And => ("Split_And", Split_And)
8.68 +| Conclude_And => ("Conclude_And", Conclude_And)
8.69 +| Split_Or => ("Split_Or", Split_Or)
8.70 +| Conclude_Or => ("Conclude_Or", Conclude_Or)
8.71 +| Begin_Trans => ("Begin_Trans", Begin_Trans)
8.72 +| End_Trans => ("End_Trans", End_Trans)
8.73 +| Begin_Sequ => ("Begin_Sequ", Begin_Sequ)
8.74 +| End_Sequ => ("End_Sequ", Begin_Sequ)
8.75 +| Split_Intersect => ("Split_Intersect", Split_Intersect)
8.76 +| End_Intersect => ("End_Intersect", End_Intersect)
8.77 +| Check_elementwise cterm' => ("Check_elementwise", Check_elementwise cterm')
8.78 +| Or_to_List => ("Or_to_List", Or_to_List)
8.79 +| Collect_Trues => ("Collect_Results", Collect_Trues)
8.80 +
8.81 +| Empty_Mstep => ("Empty_Mstep",Empty_Mstep)
8.82 +| Mstep string => ("Mstep",Mstep string)
8.83 +| User => ("User",User)
8.84 +| End_Proof' => ("End_Proof'",End_Proof');
8.85 +
8.86 +(*Detail*)
8.87 +val empty_mstep_ = (mk_mstep_ Empty_Mstep):mstep_;
8.88 +
8.89 +fun mk_mstep ((_,m):mstep_) = m;
8.90 +fun mk_mstID ((mI,_):mstep_) = mI;
8.91 +
8.92 +fun mstep_2str ((ID,ms):mstep_) = ID ^ (mstep2str ms);
8.93 +(* TODO: mstep2str, mstep_2str NOT tested *)
8.94 +
8.95 +
8.96 +
8.97 +type squ = ptree; (* TODO: safe etc. *)
8.98 +
8.99 +(*13.9.02--------------
8.100 +type ctr = (loc * pos) list;
8.101 +val ops = [("plus","op +"),("minus","op -"),("times","op *"),
8.102 + ("cancel","cancel"),("pow","pow"),("sqrt","sqrt")];
8.103 +fun op_intern op_ =
8.104 + case assoc (ops,op_) of
8.105 + Some op' => op' | None => raise error ("op_intern: no op= "^op_);
8.106 +-----------------------*)
8.107 +
8.108 +
8.109 +
8.110 +(* use"ME/solve.sml";
8.111 + use"solve.sml";
8.112 +
8.113 +val ttt = (term_of o the o (parse thy))"Substitute [(bdv,x)] g";
8.114 +val ttt = (term_of o the o (parse thy))"Rewrite thmid True g";
8.115 +
8.116 + Const ("Script.Rewrite'_Inst",_) $ sub $ Free (thm',_) $ Const (pa,_) $ f'
8.117 + *)
8.118 +
8.119 +
8.120 +
8.121 +val specsteps = ["Init_Proof","Refine_Tacitly","Refine_Problem",
8.122 + "Model_Problem",(*"Match_Problem",*)
8.123 + "Add_Given","Del_Given","Add_Find","Del_Find",
8.124 + "Add_Relation","Del_Relation",
8.125 + "Specify_Domain","Specify_Problem","Specify_Method"];
8.126 +
8.127 +
8.128 +fun solve ("Apply_Method",Apply_Method' mI) ((p,_):pos') (pt:ptree) =
8.129 +(* val ("Apply_Method",Apply_Method' mI)=(mI,m);
8.130 + *)
8.131 + let val {srls,...} = get_met mI;
8.132 + val PblObj{meth=itms,...} = get_obj I pt p;
8.133 + val thy' = get_obj g_domID pt p;
8.134 + val thy = assoc_thy thy';
8.135 + val (is as ScrState (env,_,_,_,_,_), scr) = init_scrstate thy itms mI;
8.136 + val ini = init_form thy scr env;
8.137 + val (p,p_) = (lev_dn p,Res);
8.138 + in
8.139 + case ini of
8.140 + Some t => (* val Some t = ini;
8.141 + *)
8.142 + let val (p,p_) = (lev_on p,Frm); (*implicit Take*)
8.143 + val f = Sign.string_of_term (sign_of (assoc_thy thy')) t;
8.144 + val (pt,ps) = cappend_form pt p is f
8.145 + val {srls,...} = get_met mI;
8.146 + in ((p,p_), [], Form' (FormKF (~1,EdUndef,(length p), Nundef, f)),
8.147 + fst (next_tac (thy',srls) (pt,(p,p_)) scr is), Safe, pt) end
8.148 + | None =>
8.149 + let val (m,_) = next_tac (thy',srls) (pt,(lev_on p,Frm)) scr is
8.150 + val f = case m of
8.151 + Subproblem (domID, pblID) =>
8.152 + Form' (FormKF (~1,EdUndef,(length p), Nundef,
8.153 + (Sign.string_of_term (sign_of (assoc_thy thy'))
8.154 + (subpbl domID pblID))))
8.155 + | _ => EmptyMout
8.156 + (*nothing written to pt !!!*)
8.157 + in ((p,p_), [], f, m, Safe, pt) end
8.158 + end
8.159 +
8.160 + | solve ("Free_Solve", Free_Solve') (p,_) pt =
8.161 + let val _=writeln"###solve Free_Solve";
8.162 + val p' = lev_dn_ (p,Res);
8.163 + val pt = update_metID pt (par_pblobj pt p) e_metID;
8.164 + in (p', [], EmptyMout, Empty_Mstep, Unsafe, pt) end
8.165 +
8.166 +(* val ("Check_Postcond",Check_Postcond' (pI,_)) = (mI,m);
8.167 + *)
8.168 + | solve ("Check_Postcond",Check_Postcond' (pI,_)) (p,p_) pt =
8.169 + let (*val _=writeln"###solve Check_Postcond";*)
8.170 + val pp = par_pblobj pt p;
8.171 + val metID = get_obj g_metID pt pp;
8.172 + val {srls=srls,scr=sc,...} = get_met metID;
8.173 + val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_);
8.174 + (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_)));
8.175 + val _= writeln("### solve Check_postc, is= "^(istate2str is));*)
8.176 + val thy' = get_obj g_domID pt pp;
8.177 + val thy = assoc_thy thy';
8.178 + val (_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is;
8.179 + (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*)
8.180 + in if pp = [] then
8.181 + let val ((p,p_),ps,f,pt) = generate1 thy (Check_Postcond'(pI,scval))
8.182 + (ScrState (E,l,a,scval,scsaf,b)) (pp,Res) pt;
8.183 + in ((p,p_), ps, f, End_Proof', scsaf, pt) end
8.184 + else
8.185 + let
8.186 + (*resume script of parpbl, transfer value of subpbl-script*)
8.187 + val ppp = par_pblobj pt ((**)lev_up(**) p);
8.188 + val thy' = get_obj g_domID pt ppp;
8.189 + val thy = assoc_thy thy';
8.190 + val metID = get_obj g_metID pt ppp;
8.191 + val sc = (#scr o get_met) metID;
8.192 + val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm);
8.193 + (*val _=writeln("### solve Check_postc, parpbl pos= "^(pos'2str(pp,Frm)));
8.194 + val _=writeln("### solve Check_postc, is(pt)= "^(istate2str is));
8.195 + val _=writeln("### solve Check_postc, is'= "^
8.196 + (istate2str (E,l,a,scval,scsaf,b)));*)
8.197 + val ((p,p_),ps,f,pt) = generate1 thy (Check_Postcond'(pI,scval))
8.198 + (ScrState (E,l,a,scval,scsaf,b)) (pp,Res) pt;
8.199 + (*val _=writeln("### solve Check_postc, is(pt')= "^
8.200 + (istate2str (get_istate pt ([3],Res))));*)
8.201 + val (nxt,_) = next_tac (thy',srls) (pt,(p,p_)) sc
8.202 + (ScrState (E,l,a,scval,scsaf,b));
8.203 + in ((p,p_), ps, f, nxt, scsaf, pt) end
8.204 + end
8.205 +(* writeln(istate2str(get_istate pt (p,p_)));
8.206 + *)
8.207 +
8.208 + | solve (_,End_Proof'') (p,p_) pt =
8.209 + ((p,p_), [], EmptyMout, Empty_Mstep, Safe, pt)
8.210 +
8.211 +(*.start interpreter and do one rewrite.*)
8.212 +(* val (_,Detail_Set'(thy',rls',t)) = (mI,m); val p = (p,p_);
8.213 + solve ("",Detail_Set'(thy', rls',t)) p pt;
8.214 + *)
8.215 + | solve (_,Detail_Set'(thy', rls(*'*),t)) p pt =
8.216 + let (*val rls = the (assoc(!ruleset',rls'))
8.217 + handle _ => raise error ("solve: '"^rls'^"' not known");*)
8.218 + val thy = assoc_thy thy';
8.219 + val (srls, sc, is) =
8.220 + case rls of
8.221 + Rrls {scr=sc as Rfuns {init_state=ii,...},...} =>
8.222 + (e_rls, sc, RrlsState (ii t))
8.223 + | Rls {srls=srls,scr=sc as Script s,...} =>
8.224 + (srls, sc, ScrState ([(one_scr_arg s,t)], [],
8.225 + None, e_term, Sundef, true));
8.226 + val pt = update_mstep pt (fst p) (Detail_Set (id_rls rls));
8.227 + val (p,cid,_,pt) = generate1 thy (Begin_Trans' t) is p pt;
8.228 + val (nx,_) = next_tac (thy',srls) (pt,p) sc is;
8.229 + val aopt = applicable_in p pt nx;
8.230 + in case aopt of
8.231 + Notappl s => raise error ("solve Detail_Set: "^s)
8.232 + (* val Appl m = aopt;
8.233 + *)
8.234 + | Appl m => solve ("discardFIXME",m) p pt end
8.235 +
8.236 + | solve (_,End_Detail' t) (p,p_) pt =
8.237 + let val pr as (p',_) = (lev_up p, Res)
8.238 + val pp = par_pblobj pt p
8.239 + val r = get_obj g_result pt p' (*Rewrite_Set* done at Detail_Set**)
8.240 + val thy' = get_obj g_domID pt pp
8.241 + val (srls, is, sc) = from_pblobj' thy' pr pt
8.242 + in (pr, [], Form' (FormKF (~1, EdUndef, length p', Nundef, r)),
8.243 + fst (next_tac (thy',srls) (pt,pr) sc is), Sundef, pt) end
8.244 +(* val (mI,(p,p_)) = ("xxx",p);
8.245 + *)
8.246 + | solve (mI,m) (p,p_) pt =
8.247 + if e_metID = get_obj g_metID pt (par_pblobj pt p)(*29.8.02:
8.248 + could be detail, too !!*)
8.249 + then let val ((p,p_),ps,f,pt) =
8.250 + generate1 (assoc_thy (get_obj g_domID pt (par_pblobj pt p)))
8.251 + m e_istate (p,p_) pt;
8.252 + in ((p,p_),ps,f, Empty_Mstep, Unsafe, pt) end
8.253 + else
8.254 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
8.255 + val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt;
8.256 +(*val _= writeln("### solve, before locate_gen p="^(pos'2str(p,p_)));*)
8.257 + val d = e_rls; (*FIXME: canon.simplifier for domain is missing
8.258 + 8.01: generate from domID?*)
8.259 + in case locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is of
8.260 + Steps (is', (m',f',pt',p',c')::ss) =>
8.261 + (* val Steps (is', (m',f',pt',p',c')::ss) =
8.262 + locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is;
8.263 + *)
8.264 + let val nxt =
8.265 + case p' of (*change from solve to model subprobl*)
8.266 + (_,Pbl) => nxt_model_pbl m'
8.267 + | _ => fst (next_tac (thy',srls) (pt',p') sc is');
8.268 + (*27.8.02: next_tac may change to other branches in ptFIXXXXME*)
8.269 + in (p',c', f', nxt, safe is', pt'(*'*)) end
8.270 + | NotLocatable =>
8.271 + let val (p,ps,f,pt) =
8.272 + generate_hard (assoc_thy "Isac.thy") m (p,p_) pt;
8.273 + in (p,ps,f, Empty_Mstep, Unsafe, pt) end
8.274 + end;
8.275 +
8.276 +
8.277 +(* unused: _____ 4.4.00 TODO: pos list !!!*)
8.278 +fun me ((mI,m):mstep_) (pos' as (p,p_):pos') (c:cid) (pt:ptree) =
8.279 +(* val (pos' as (p,p_),pt) = (p,EmptyPtree);
8.280 +
8.281 + val (mI,m) = nxt; val pos' as (p,p_) = p;
8.282 + *)
8.283 + case applicable_in (p,p_) pt m of
8.284 + Appl m => (* val Appl m = applicable_in (p,p_) pt m;
8.285 + *)
8.286 + (case m of
8.287 + ( Refine_Problem' ms) =>
8.288 + (pos',c, Problems (RefinedKF ms),
8.289 + ("Specify_Problem", Specify_Problem (refined ms)), Safe, pt)
8.290 +
8.291 + | _ => (if mI mem specsteps
8.292 + then let val (p',c,f,m,s,pt) = specify m (p,p_) c pt;
8.293 + in (p',c,f,mk_mstep_ m,s,pt)
8.294 + end
8.295 + else let val ((p,p_),c,f,m,s,pt) = solve (mI,m) (p,p_) pt;
8.296 + in ((p,p_),c,f,mk_mstep_ m,s,pt) end))
8.297 + | Notappl e => ((p,p_),c, Error' (Error_ e),
8.298 + mk_mstep_ Empty_Mstep (*nxtstep ??*), Unsafe,pt);
8.299 +
8.300 +(* val(mI,m)=m;val ppp=p;(*!!!*)val(p,p_)=pos;val(_,pt,_)=ppp(*!!!*);
8.301 + get_form ((mI,m):mstep_) ((p,p_):pos') ppp;
8.302 + *)
8.303 +fun get_form ((mI,m):mstep_) ((p,p_):pos') pt =
8.304 + case applicable_in (p,p_) pt m of
8.305 + Notappl e => Error' (Error_ e)
8.306 + | Appl m =>
8.307 + (* val Appl m=applicable_in (p,p_) pt m;
8.308 + *)
8.309 + if mI mem specsteps
8.310 + then let val (_,_,f,_,_,_) = specify m (p,p_) [] pt
8.311 + in f end
8.312 + else let val (_,_,f,_,_,_) = solve (mI,m) (p,p_) pt
8.313 + in f end;
8.314 +
8.315 +
8.316 +(* use"ME/solve.sml";
8.317 + use"solve.sml";
8.318 + *)
8.319 +
9.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2 +++ b/src/sml/Scripts/ROOT-rearrangeFiles.ML Thu Apr 17 18:01:03 2003 +0200
9.3 @@ -0,0 +1,11 @@
9.4 +(* remarks on reorganisation of files:
9.5 + 8.01:
9.6 +
9.7 +in ListG.ML there should be
9.8 + 'fun eval_listexpr' (in Isa99/interface_ME_ISA_tools.sml)
9.9 + 'val list_rls' (in knowledge/Atools.ML)
9.10 + ^^^^^^^^--- needs eval_binop
9.11 +
9.12 + thus transfer Atools to Isa99 ???
9.13 +
9.14 +*)
9.15 \ No newline at end of file
10.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2 +++ b/src/sml/Scripts/reverse-rew.sml Thu Apr 17 18:01:03 2003 +0200
10.3 @@ -0,0 +1,165 @@
10.4 +(*. reverse rewriting
10.5 + WN.12.8.02
10.6 + use"Isa02/reverse-rew.sml";
10.7 +.*)
10.8 +
10.9 +fun trta2str (t,r,(t',a)) = "\n("^(term2str t)^", "^(rule2str r)^", ("^
10.10 + (term2str t')^", "^(terms2str a)^"))";
10.11 +fun trtas2str trtas = (strs2str o (map trta2str)) trtas;
10.12 +fun rta2str (r,(t,a)) = "\n("^(rule2str r)^", ("^
10.13 + (term2str t)^", "^(terms2str a)^"))";
10.14 +fun rtas2str rtas = (strs2str o (map rta2str)) rtas;
10.15 +
10.16 +
10.17 +(*.A1==>...==>An==>(Lhs = Rhs) goes to A1==>...==>An==>(Rhs = Lhs).*)
10.18 +fun sym_thm thm =
10.19 + let
10.20 + val {sign_ref = sign_ref, der = der, maxidx = maxidx,
10.21 + shyps = shyps, hyps = hyps, prop = prop} = rep_thm_G thm;
10.22 + val (lhs,rhs) = (dest_equals' o strip_trueprop
10.23 + o Logic.strip_imp_concl) prop;
10.24 + val prop' = case strip_imp_prems' prop of
10.25 + None => Trueprop $ (mk_equality (rhs, lhs))
10.26 + | Some cs =>
10.27 + ins_concl cs (Trueprop $ (mk_equality (rhs, lhs)));
10.28 + in assbl_thm sign_ref der maxidx shyps hyps prop' end;
10.29 +(*
10.30 + (sym RS real_mult_div_cancel1) handle e => print_exn e;
10.31 +Exception THM 1 raised:
10.32 +RSN: no unifiers
10.33 +"?s = ?t ==> ?t = ?s"
10.34 +"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n"
10.35 +
10.36 + val thm = real_mult_div_cancel1;
10.37 + val prop = (#prop o rep_thm) thm;
10.38 + atomt prop;
10.39 + val ppp = Logic.strip_imp_concl prop;
10.40 + atomt ppp;
10.41 + ((#prop o rep_thm o sym_thm o sym_thm) thm) = (#prop o rep_thm) thm;
10.42 +val it = true : bool
10.43 + ((sym_thm o sym_thm) thm) = thm;
10.44 +val it = true : bool
10.45 +
10.46 + val thm = real_le_anti_sym;
10.47 + ((sym_thm o sym_thm) thm) = thm;
10.48 +val it = true : bool
10.49 +
10.50 + val thm = real_minus_zero;
10.51 + ((sym_thm o sym_thm) thm) = thm;
10.52 +val it = true : bool
10.53 +*)
10.54 +
10.55 +
10.56 +
10.57 +(*.derive normalform of a rls, or derive until Some goal,
10.58 + and record rules applied and rewrites.
10.59 +val it = fn
10.60 + : theory
10.61 + -> rls
10.62 + -> rule list
10.63 + -> rew_ord : the order of this rls, which 1 theorem of is used
10.64 + for rewriting 1 single step (?14.4.03)
10.65 + -> term option
10.66 + -> term
10.67 + -> (term * : to this term ...
10.68 + rule * : ... this rule is applied yielding ...
10.69 + (term * : ... this term ...
10.70 + term list)) : ... under these assumptions.
10.71 + list :
10.72 +*)
10.73 +fun make_deriv thy erls (rs:rule list) ro(*rew_ord*) goal tt =
10.74 + let
10.75 + datatype switch = Appl | Noap;
10.76 + fun rew_once rts t Noap [] =
10.77 + (case goal of
10.78 + None => rts
10.79 + | Some g =>
10.80 + raise error ("make_deriv: no derivation for "^(term2str t)))
10.81 + | rew_once rts t Appl [] =
10.82 + (*(case rs of Rls _ =>*) rew_once rts t Noap rs
10.83 + (*| Seq _ => rts) FIXXXXXME 14.3.03*)
10.84 + | rew_once rts t apno rs' =
10.85 + (case goal of
10.86 + None => rew_or_calc rts t apno rs'
10.87 + | Some g =>
10.88 + if g = t then rts
10.89 + else rew_or_calc rts t apno rs')
10.90 + and rew_or_calc rts t apno (rrs' as (r::rs')) =
10.91 + case r of
10.92 + Thm (thmid, tm) =>
10.93 + (if not (!trace_rewrite) then () else
10.94 + writeln ("### trying thm '" ^ thmid ^ "'");
10.95 + case rewrite_ thy ro erls true tm t of
10.96 + None => rew_once rts t apno rs'
10.97 + | Some (t',a') =>
10.98 + (if ! trace_rewrite
10.99 + then writeln ("### rewrites to: "^(term2str t')) else ();
10.100 + rew_once (rts@[(t,r,(t',a'))]) t' Appl rrs'))
10.101 + | Calc (c as (op_,_)) =>
10.102 + let val _ = if not (!trace_rewrite) then () else
10.103 + writeln ("### trying calc. '" ^ op_ ^ "'")
10.104 + val t = app_num_tr'2 t
10.105 + in case get_calculation_ thy c t of
10.106 + None => rew_once rts t apno rs'
10.107 + | Some (thmid, tm) =>
10.108 + (let val Some (t',a') = rewrite_ thy ro erls true tm t
10.109 + val _ = if not (!trace_rewrite) then () else
10.110 + writeln("### calc. to: " ^ (term2str t'))
10.111 + val r' = Thm (thmid, tm)
10.112 + in rew_once (rts@[(t,r',(t',a'))]) t' Appl rrs' end)
10.113 + handle _ => raise error "derive_norm, Calc: no rewrite"
10.114 + end
10.115 + (*| Rls_ <> rule list !!! FIXXXXXME 14.3.03*)
10.116 + in rew_once [] tt Noap rs end;
10.117 +(*
10.118 + val t9 = (term_of o the o (parse thy)) "(8*(-1 + x))/(9*(-1 + x))";
10.119 + val rst = make_deriv thy eval_rls make_polynomial None t9;
10.120 + writeln(trtas2str rst);
10.121 +*)
10.122 +fun sym_thmID thmID =
10.123 + case explode thmID of
10.124 + "s"::"y"::"m"::"_"::id => implode id
10.125 + | id => "sym_"^thmID;
10.126 +(*
10.127 + val thmID = "sym_real_mult_2";
10.128 + sym_thmID thmID;
10.129 +val it = "real_mult_2" : string
10.130 + val thmID = "real_num_collect";
10.131 + sym_thmID thmID;
10.132 +val it = "sym_real_num_collect" : string*)
10.133 +
10.134 +fun sym_Thm (Thm (thmID, thm)) = Thm (sym_thmID thmID, sym_thm thm)
10.135 + | sym_Thm r = raise error ("sym_Thm: not for "^(rule2str r));
10.136 +(*
10.137 + val th = Thm ("real_one_collect",num_str real_one_collect);
10.138 + sym_Thm th;
10.139 +val th =
10.140 + Thm ("real_one_collect","?m is_const ==> ?n + ?m * ?n = (1 + ?m) * ?n")
10.141 + : rule
10.142 +ML> val it =
10.143 + Thm ("sym_real_one_collect","?m is_const ==> (1 + ?m) * ?n = ?n + ?m * ?n")*)
10.144 +
10.145 +fun rev_deriv (t, r, (t', a)) = (sym_Thm r, (t, a));
10.146 +fun reverse_deriv trta = (rev o (map rev_deriv)) trta;
10.147 +fun reverse_deriv thy erls (rs:rule list) ro(*rew_ord*) goal t =
10.148 + (rev o (map rev_deriv)) (make_deriv thy erls (rs:rule list) ro goal t);
10.149 +(*
10.150 + val rev_rew = reverse_deriv thy e_rls ;
10.151 + writeln(rtas2str rev_rew);
10.152 +*)
10.153 +
10.154 +
10.155 +fun eq_Thm (Thm (id1,_), Thm (id2,_)) = id1 = id2
10.156 + | eq_Thm (r1, r2) = raise error ("eq_Thm: called with '"^
10.157 + (rule2str r1)^"' '"^(rule2str r2)^"'");
10.158 +fun distinct_Thm r = gen_distinct eq_Thm r;
10.159 +
10.160 +fun eq_Thms thmIDs thm = (id_of_thm thm) mem thmIDs
10.161 + | eq_Thms _ thm = raise error ("eq_Thms: called with '"^(rule2str thm)^"'");
10.162 +
10.163 +
10.164 +
10.165 +
10.166 +(* use"Isa02/reverse-rew.sml";
10.167 + *)
10.168 +
11.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2 +++ b/src/sml/Scripts/rewrite-new-eval_true.sml Thu Apr 17 18:01:03 2003 +0200
11.3 @@ -0,0 +1,525 @@
11.4 +(* 28.8.02: eval_true_ -> ... -> TRUE | FALSE | INDETerminate
11.5 + SqRoot_simplify terminiert nicht mehr ?! siehe test-rootequ.sml
11.6 + aufheben !!! (nehmen, sobald -"- untersucht)
11.7 +
11.8 + use"../Isa02/interface_ME_ISA_tools.sml";
11.9 + use"Isa02/interface_ME_ISA_tools.sml";
11.10 + use"interface_ME_ISA_tools.sml";
11.11 + *)
11.12 +
11.13 +
11.14 +datatype det = TRUE | FALSE | INDET;
11.15 +fun determine dts =
11.16 + let val false_indet =
11.17 + filter_out ((curry op= TRUE) o (#1:det * term -> det)) dts
11.18 + val ts = map (#2: det * term -> term) dts
11.19 + in if nil = false_indet then (TRUE, ts)
11.20 + else if nil = filter ((curry op= FALSE) o (#1:det * term -> det))
11.21 + false_indet
11.22 + then (INDET, ts)
11.23 + else (FALSE, ts) end;
11.24 +(* val dts = [(INDET,e_term), (FALSE,HOLogic.false_const),
11.25 + (INDET,e_term), (TRUE,HOLogic.true_const)];
11.26 + determine dts;
11.27 +val it =
11.28 + (FALSE,
11.29 + [Const ("empty","'a"),Const ("False","bool"),Const ("empty","'a"),
11.30 + Const ("True","bool")]) : det * term list*)
11.31 +
11.32 +exception NO_REWRITE;
11.33 +
11.34 +(*val tthy = ref Main.thy;
11.35 +val ttless = ref termless;
11.36 +val trls = ref empty_rls;
11.37 +val tput_asm = ref false;
11.38 +val tthm = ref refl;
11.39 +val tct = ref ((the o (parse thy)) "#1+#1+#1");
11.40 +val truless = ref empty_rls;*)
11.41 +
11.42 +(*17.6.00: rewrite by going down the term with rew_sub*)
11.43 +fun rewrite_ thy tless rls put_asm thm ct =
11.44 +( (* rewrite_ (!tthy) (!ttless) (!trls) (!tput_asm) (!tthm) (!tct);
11.45 +*)
11.46 +(*tthy := thy;
11.47 +ttless := tless;
11.48 +trls := rls;
11.49 +tput_asm:= put_asm;
11.50 +tthm := thm;
11.51 +tct := ct;*)
11.52 + let
11.53 + val (t',asms,rew) = rew_sub thy tless rls put_asm
11.54 + ((norm o #prop o rep_thm) thm) ct;
11.55 + in if rew then Some (t', asms)
11.56 + else None end
11.57 +)(* val r = (norm o #prop o rep_thm) thm;val t = term_of ct;
11.58 + *)
11.59 +and rew_sub thy tless rls put_asm r t =
11.60 + (let (* see Pure/thm.ML: fun rewritec *)
11.61 + val (lhs,rhs) = (dest_equals' o strip_trueprop
11.62 + o Logic.strip_imp_concl) r
11.63 + val insts = Pattern.match (Sign.tsig_of(sign_of thy)) (lhs,t)
11.64 + (*TODOtest: (-"-) handle _ => raise NO_REWRITE; 12.8.02 ???*)
11.65 + val r' = ren_inst(insts,r,lhs,t)
11.66 + val p' = map strip_trueprop (Logic.strip_imp_prems r')
11.67 + val t' = (snd o dest_equals' o strip_trueprop
11.68 + o Logic.strip_imp_concl) r'
11.69 + val (t'',p'') =
11.70 + (case eval_true_ thy p' rls of
11.71 + (TRUE, _) => (t',[])
11.72 + | (INDET, _) => (t',p')
11.73 + | (FALSE, cs) =>
11.74 + (if ! trace_rewrite
11.75 + then writeln("### prems false: "^
11.76 + (commas (map (Sign.string_of_term
11.77 + (sign_of thy)) cs)))
11.78 + else ();
11.79 + raise NO_REWRITE))
11.80 + in if perm lhs rhs andalso not (tless(t',t))
11.81 + then (if ! trace_rewrite then
11.82 + writeln("### not: \""^
11.83 + (Sign.string_of_term (sign_of thy) t)^"\" > \""^
11.84 + (Sign.string_of_term (sign_of thy) t')^"\"") else ();
11.85 + raise NO_REWRITE )
11.86 + else (t'',p'',true)
11.87 + end)
11.88 + handle _ (*TODOtest: NO_REWRITE *) =>
11.89 + (case t of
11.90 + Const(s,T) => (Const(s,T),[],false)
11.91 + | Free(s,T) => (Free(s,T),[],false)
11.92 + | Var(n,T) => (Var(n,T),[],false)
11.93 + | Bound i => (Bound i,[],false)
11.94 + | Abs(s,T,body) =>
11.95 + let val (t',asms,rew) = rew_sub thy tless rls put_asm r body
11.96 + in (Abs(s,T,t'),asms,rew) end
11.97 + | t1 $ t2 =>
11.98 + let val (t2',asm2,rew2) = rew_sub thy tless rls put_asm r t2
11.99 + in if rew2 then (t1 $ t2',asm2,true)
11.100 + else let val (t1',asm1,rew1) =
11.101 + rew_sub thy tless rls put_asm r t1
11.102 + in if rew1 then (t1' $ t2,asm1,true)
11.103 + else (t1 $ t2,[],false) end
11.104 + end)
11.105 +(* fn : theory -> term list -> rls -> bool
11.106 +
11.107 +> val (cprems',rls)=([cterm_of (sign_of thy) t],(the o assoc')(!ruleset',rls));
11.108 +> eval_true_ thy cprems' rls;
11.109 +> val cp=hd cprems';
11.110 +> rewrite_set_ thy empty_rls false rls cp;
11.111 + *)
11.112 +and eval_true_ thy cs rls =
11.113 +if cs = [HOLogic.true_const] orelse cs = [] then (TRUE, [])
11.114 + else if cs = [HOLogic.false_const] then (FALSE, cs)
11.115 + else
11.116 + let fun eval t =
11.117 + let val taopt = rewrite_set_ thy e_rls false rls t
11.118 + in case taopt of
11.119 + Some (t,_) =>
11.120 + if t = HOLogic.true_const then (TRUE, t)
11.121 + else if t = HOLogic.false_const then (FALSE, t)
11.122 + else (INDET, t)
11.123 + | None => (INDET, t) end
11.124 + in (determine o (map eval)) cs end
11.125 +and rewrite_set_ thy rls put_asm ruless ct =
11.126 + case ruless of
11.127 + Rrls {scr=Rfuns {normal_form=n,...},...} => n ct
11.128 + | Rls _ =>
11.129 + let
11.130 + datatype switch = Appl | Noap;
11.131 + fun rew_once ruls asm ct Noap [] = (ct,asm)
11.132 + | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls
11.133 + | rew_once ruls asm ct apno (rul::thms) =
11.134 + case rul of
11.135 + Thm (thmid, thm) =>
11.136 + (if not (!trace_rewrite) then () else
11.137 + writeln("### trying thm '"^thmid^"'");
11.138 + case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
11.139 + rls put_asm (thm_of_thm rul) ct of
11.140 + None => rew_once ruls asm ct apno thms
11.141 + | Some (ct',asm') => (if ! trace_rewrite
11.142 + then writeln("### rewrites to: "^
11.143 + (Sign.string_of_term (sign_of thy) ct')) else ();
11.144 + rew_once ruls (asm union asm') ct' Appl (rul::thms)))
11.145 + | Calc (cc as (op_,_)) =>
11.146 + (if not (!trace_rewrite) then () else
11.147 + writeln("### trying calc. '"^op_^"'");
11.148 + case get_calculation_ thy cc ct of
11.149 + None => rew_once ruls asm ct apno thms
11.150 + | Some (thmid, thm') =>
11.151 + let
11.152 + val pairopt =
11.153 + rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
11.154 + rls put_asm thm' ct;
11.155 + val _ = if pairopt <> None then ()
11.156 + else raise error("rewrite_set_, rewrite_ \""^
11.157 + (string_of_thm thm')^"\" \""^
11.158 + (Sign.string_of_term (sign_of thy) ct)^"\" = None")
11.159 + val _ = if ! trace_rewrite
11.160 + then writeln("### calc. to: "^
11.161 + (Sign.string_of_term (sign_of thy)
11.162 + ((fst o the) pairopt)))
11.163 + else()
11.164 + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end);
11.165 + val ruls = (#rules o rep_rls) ruless;
11.166 + val (ct',asm') = rew_once ruls [] ct Noap ruls;
11.167 + in if ct = ct' then None else Some (ct',asm') end;
11.168 +
11.169 +(*.variants of rewrite.*)
11.170 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst,
11.171 + thus the argument put_asm IS NOT NECESSARY -- FIXME*)
11.172 +fun rewrite_inst_ (thy:theory) rew_ord (rls:rls)
11.173 + (put_asm:bool) (subs':(cterm' * cterm') list) (thm:thm) (ct:term) =
11.174 + let (*
11.175 + val subs' = ((map (apfst (Sign.string_of_term (sign_of thy))))
11.176 + o (map (apsnd (Sign.string_of_term (sign_of thy))))) subs;*)
11.177 + val subthm = read_instantiate subs' thm (*Pure/drule.ML*)
11.178 + in rewrite_ thy rew_ord rls put_asm subthm ct
11.179 + end;
11.180 +fun rewrite_set_inst_ (thy:theory) (erls:rls)
11.181 + (put_asm:bool) (subs':(cterm' * cterm') list) (rls:rls) (ct:term) =
11.182 + let (*
11.183 + val subs' = ((map (apfst (Sign.string_of_term (sign_of thy))))
11.184 + o (map (apsnd (Sign.string_of_term (sign_of thy))))) subs;*)
11.185 + val subrls = instantiate_rls subs' rls
11.186 + in rewrite_set_ thy erls put_asm subrls ct
11.187 + end;
11.188 +
11.189 +
11.190 +
11.191 +(*search ct for adjacent numerals and calculate them by op_*)
11.192 +fun calculate_ thy op_ ct =
11.193 + let val isaop = (the (assoc (!calc_list,op_)))
11.194 + handle _ => error ("calculate_: "^op_^" not known");
11.195 + in case get_calculation_ thy isaop ct of
11.196 + None => None
11.197 + | Some (thmID, thm) =>
11.198 + (let val Some (rew,_) = rewrite_ thy tless_true e_rls false thm ct
11.199 + in Some (rew,(thmID, thm)) end)
11.200 + handle _ => error ("calculate_: "^thmID^" does not rewrite")
11.201 + end;
11.202 +(*
11.203 +> val thy = InsSort.thy;
11.204 +> val op_ = "le"; (* < *)
11.205 +> val ct = (the o (parse thy))
11.206 + "foldr ins [#2] (if #1 < #3 then #1 # ins [] #3 else [#3, #1])";
11.207 +> calculate_ thy op_ ct;
11.208 + Some
11.209 + ("foldr ins [#2] (if True then #1 # ins [] #3 else [#3, #1])",
11.210 + "(#1 < #3) = True") : (cterm * thm) option *)
11.211 +
11.212 +
11.213 +(* for test-printouts:
11.214 +val _ = writeln("in rew_sub : "^( Sign.string_of_term (sign_of thy) t))
11.215 +val _ = writeln("in eval_true_: prems= "^(commas (map (Sign.string_of_term (sign_of thy)) prems')))
11.216 +*)
11.217 +
11.218 +
11.219 +
11.220 +
11.221 +
11.222 +
11.223 +fun get_rls_scr rs' = ((#scr o rep_rls o the o assoc') (!ruleset',rs'))
11.224 + handle _ => raise error ("get_rls_scr: no script for "^rs');
11.225 +
11.226 +
11.227 +(*make_thm added to Pure/thm.ML*)
11.228 +fun mk_thm thy str = make_thm (cterm_of (sign_of thy) (Trueprop $
11.229 + (term_of o the o (parse thy)) str));
11.230 +(*prints subgoal etc.
11.231 +((goal thy);(topthm()) o ) str; *)
11.232 +(*assume rejects scheme variables
11.233 + assume (cterm_of (sign_of thy) (Trueprop $
11.234 + (term_of o the o (parse thy)) str)); *)
11.235 +
11.236 +
11.237 +(* outcommented 18.11. -------
11.238 +fun rul2rul' (Thm (thmid, thm)) = Thm'(thmid, string_of_thm thm)
11.239 + | rul2rul' (Calc op_) = Calc' op_;
11.240 +fun rul'2rul thy (Thm'(thmid, ct')) =
11.241 + Thm (thmid, mk_thm thy ct')
11.242 + | rul'2rul thy' (Calc' op_) = Calc op_;
11.243 +
11.244 +
11.245 +fun rls2rls' (Rls{preconds=preconds,rew_ord=rew_ord,rules=rules}:rls) =
11.246 + Rls'{preconds'= map string_of_cterm preconds,
11.247 + rew_ord' = fst rew_ord,
11.248 + rules' = map rul2rul' rules}:rlsdat';
11.249 +
11.250 +fun rls'2rls thy' (Rls'{preconds'=preconds,rew_ord'=rew_ord,
11.251 + rules'=rules}:rlsdat') =
11.252 + let val thy = the (assoc' (theory',thy'))
11.253 + in Rls{preconds = map (the o (parse thy)) preconds,
11.254 + rew_ord = (rew_ord, the (assoc'(rew_ord',rew_ord))),
11.255 + rules = map (rul'2rul thy) rules}:rls end;
11.256 +
11.257 +fun assoc_rls (thy':theory') ((rlsid, rlsdat'):rls') =
11.258 + if (hd o explode) rlsid = "#"
11.259 + then Some (rls'2rls thy' rlsdat')
11.260 + else assoc (ruleset'(*the global value*), rlsid);
11.261 +------- *)
11.262 +
11.263 +fun assoc_thm' (thy:theory) ((thmid, ct'):thm') =
11.264 + (case explode thmid of
11.265 + "s"::"y"::"m"::"_"::id =>
11.266 + if hd id = "#"
11.267 + then mk_thm thy ct'
11.268 + else (get_thm thy (implode id)) RS sym
11.269 + | id =>
11.270 + if hd id = "#"
11.271 + then mk_thm thy ct'
11.272 + else get_thm thy thmid
11.273 + ) handle _ =>
11.274 + raise error ("assoc_thm': '"^thmid^"not in '"^
11.275 + (theory2domID thy)^"' (and parents)");
11.276 +(*> assoc_thm' Isac.thy ("sym_#mult_2_3","6 = 2 * 3");
11.277 +val it = "6 = 2 * 3" : thm
11.278 +
11.279 +> assoc_thm' Isac.thy ("real_add_zero_left","");
11.280 +val it = "0 + ?z = ?z" : thm
11.281 +
11.282 +> assoc_thm' Isac.thy ("sym_real_add_zero_left","");
11.283 +val it = "?t = 0 + ?t" [.] : thm
11.284 +
11.285 +> assoc_thm' HOL.thy ("sym_real_add_zero_left","");
11.286 +*** Unknown theorem(s) "real_add_zero_left"
11.287 +*** assoc_thm': 'sym_real_add_zero_leftnot in 'HOL.thy' (and parents)
11.288 +
11.289 +uncaught exception ERROR*)
11.290 +
11.291 +
11.292 +fun parse' (thy:theory') (ct:cterm') =
11.293 + case parse ((the o assoc')(!theory',thy)) ct of
11.294 + None => None
11.295 + | Some ct => Some ((string_of_cterm ct):cterm');
11.296 +
11.297 +
11.298 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
11.299 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
11.300 +fun rewrite (thy':theory') (rew_ord:rew_ord') (rls:rls')
11.301 + (put_asm:bool) (thm:thm') (ct:cterm') =
11.302 + let val thy = (the o assoc')(!theory',thy');
11.303 + in
11.304 + case rewrite_ thy
11.305 + ((the o assoc')(!rew_ord',rew_ord)) ((the o assoc')(!ruleset',rls))
11.306 + put_asm ((assoc_thm' thy) thm)
11.307 + ((term_of o the o (parse thy)) ct) of
11.308 + None => None
11.309 + | Some (t, ts) => Some (Sign.string_of_term (sign_of thy) t,
11.310 + map (Sign.string_of_term (sign_of thy)) ts)
11.311 + end;
11.312 +
11.313 +(*
11.314 +val thy = "RatArith.thy";
11.315 +val rew_ord = "tless_true";
11.316 +val rls = "eval_rls";
11.317 +val put_asm = true;
11.318 +val thm = ("square_equation_left","");
11.319 +val ct = "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
11.320 +
11.321 +val Zthy = ((the o assoc')(!theory',thy));
11.322 +val Zrew_ord = ((the o assoc')(!rew_ord',rew_ord));
11.323 +val Zrls = ((the o assoc')(!ruleset',rls));
11.324 +val Zput_asm = put_asm;
11.325 +val Zthm = ((the o (assoc'_thm' thy)) thm);
11.326 +val Zct = ((the o (parse ((the o assoc')(!theory',thy)))) ct);
11.327 +
11.328 +rewrite_ Zthy Zrew_ord Zrls Zput_asm Zthm Zct;
11.329 +
11.330 + use"Isa99/interface_ME_ISA.sml";
11.331 +*)
11.332 +
11.333 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
11.334 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
11.335 +fun rewrite_set (thy':theory') (erls:rls') (put_asm:bool)
11.336 + (rls:rls') (ct:cterm') =
11.337 + let val thy = (the o assoc')(!theory',thy');
11.338 + in
11.339 + case rewrite_set_ thy
11.340 + ((the o assoc')(!ruleset',erls)) put_asm ((the o assoc')(!ruleset',rls))
11.341 + ((term_of o the o (parse thy)) ct) of
11.342 + None => None
11.343 + | Some (t, ts) => Some (Sign.string_of_term (sign_of thy) t,
11.344 + map (Sign.string_of_term (sign_of thy)) ts)
11.345 + end;
11.346 +
11.347 +(*evaluate list-expressions
11.348 + should work on term, and stand in Isa99/rewrite-parse.sml,
11.349 + but there list_rls <- eval_binop is not yet defined*)
11.350 +fun eval_listexpr' ct =
11.351 + let val rew = rewrite_set "ListG.thy" "eval_rls" false "list_rls" ct;
11.352 + in case rew of
11.353 + Some (res,_) => res
11.354 + | None => ct end;
11.355 +fun eval_listexpr_ thy t =
11.356 + let val rew = rewrite_set_ thy ((the o assoc')(!ruleset',"eval_rls"))
11.357 + false ((the o assoc')(!ruleset',"list_rls")) t;
11.358 + in case rew of
11.359 + Some (res,_) => res
11.360 + | None => t end;
11.361 +
11.362 +
11.363 +fun get_calculation' (thy:theory') op_ (ct:cterm') =
11.364 + case get_calculation_ ((the o assoc')(!theory',thy)) op_
11.365 + ((term_of o the o (parse ((the o assoc')(!theory',thy)))) ct) of
11.366 + None => None
11.367 + | Some (thmid, thm) =>
11.368 + Some ((thmid, string_of_thm thm):thm');
11.369 +
11.370 +fun calculate (thy':theory') op_ (ct:cterm') =
11.371 + let val thy = (the o assoc')(!theory',thy');
11.372 + in
11.373 + case calculate_ thy op_
11.374 + ((term_of o the o (parse thy)) ct) of
11.375 + None => None
11.376 + | Some (ct,(thmID,thm)) =>
11.377 + Some (Sign.string_of_term (sign_of thy) ct,
11.378 + (thmID, string_of_thm thm):thm')
11.379 + end;
11.380 +(*
11.381 +fun instantiate'' thy' subs ((thmid,ct'):thm') =
11.382 + let val thmid_ = implode ("#"::(explode thmid)) (*see type thm'*)
11.383 + in (thmid_, (string_of_thm o (read_instantiate subs))
11.384 + ((the o (assoc_thm' thy')) (thmid_,ct'))):thm' end;
11.385 +
11.386 +fun instantiate_rls' thy' subs (rls:rls') =
11.387 + rls2rls' (instantiate_rls subs ((the o (assoc_rls thy')) rls)):rlsdat';
11.388 +
11.389 +... problem with these functions:
11.390 +> val thm = mk_thm thy "(bdv + a = b) = (bdv = b - a)";
11.391 +val thm = "(bdv + a = b) = (bdv = b - a)" : thm
11.392 +> show_types:=true; thm;
11.393 +val it = "((bdv::'a) + (a::'a) = (b::'a)) = (bdv = b - a)" : thm
11.394 +... and this doesn't match because of too general typing (?!)
11.395 + and read_insitantiate doesn't instantiate the types (?!)
11.396 +=== solutions:
11.397 +(1) hard-coded type-instantiation ("'a", "RatArith.rat")
11.398 +(2) instantiate', instantiate ... no help by isabelle-users@ !!!
11.399 +=== conclusion:
11.400 + rewrite_inst, rewrite_set_inst circumvent the problem,
11.401 + according functions out-commented with 'instantiate''
11.402 +*)
11.403 +
11.404 +(* instantiate''
11.405 +fun instantiate'' thy' subs ((thmid,ct'):thm') =
11.406 + let
11.407 + val thmid_ = implode ("#"::(explode thmid)); (*see type thm'*)
11.408 + val thy = (the o assoc')(!theory',thy');
11.409 + val typs = map (#T o rep_cterm o the o (parse thy))
11.410 + ((snd o split_list) subs);
11.411 + val ctyps = map
11.412 + ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o (parse thy))
11.413 + ((snd o split_list) subs);
11.414 +
11.415 +> val thy' = "RatArith.thy";
11.416 +> val subs = [("bdv","x::rat"),("zzz","z::nat")];
11.417 +> (the o (parse ((the o assoc')(!theory',thy')))) "x::rat";
11.418 +> (#T o rep_cterm o the o (parse ((the o assoc')(!theory',thy'))));
11.419 +
11.420 +> val ctyp = ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o
11.421 + (parse ((the o assoc')(!theory',thy')))) "x::rat";
11.422 +> val bdv = (the o (parse thy)) "bdv";
11.423 +> val x = (the o (parse thy)) "x";
11.424 +> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add)
11.425 + handle e => print_exn e;
11.426 +uncaught exception THM
11.427 + raised at: thm.ML:1085.18-1085.69
11.428 + thm.ML:1092.34
11.429 + goals.ML:536.61
11.430 +
11.431 +> val bdv = (the o (parse thy)) "bdv::nat";
11.432 +> val x = (the o (parse thy)) "x::nat";
11.433 +> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add)
11.434 + handle e => print_exn e;
11.435 +uncaught exception THM
11.436 + raised at: thm.ML:1085.18-1085.69
11.437 + thm.ML:1092.34
11.438 + goals.ML:536.61
11.439 +
11.440 +> (instantiate' [Some ctyp] [] isolate_bdv_add)
11.441 + handle e => print_exn e;
11.442 +uncaught exception TYPE
11.443 + raised at: drule.ML:613.13-615.44
11.444 + goals.ML:536.61
11.445 +
11.446 +> val repct = (rep_cterm o the o (parse ((the o assoc')(!theory',thy')))) "x::rat";
11.447 +*)
11.448 +
11.449 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
11.450 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
11.451 +fun rewrite_inst (thy':theory') (rew_ord:rew_ord') (rls:rls')
11.452 + (put_asm:bool) subs (thm:thm') (ct:cterm') =
11.453 + let
11.454 + val thy = (the o assoc')(!theory',thy');
11.455 + val subthm = read_instantiate subs ((assoc_thm' thy) thm)
11.456 + in
11.457 + case rewrite_ thy
11.458 + ((the o assoc')(!rew_ord',rew_ord)) ((the o assoc')(!ruleset',rls))
11.459 + put_asm subthm ((term_of o the o (parse thy)) ct) of
11.460 + None => None
11.461 + | Some (ctm, ctms) =>
11.462 + Some ((Sign.string_of_term (sign_of thy) ctm):cterm',
11.463 + (map (Sign.string_of_term (sign_of thy)) ctms):cterm' list)
11.464 + end;
11.465 +
11.466 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
11.467 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
11.468 +fun rewrite_set_inst (thy':theory') (erls:rls') (put_asm:bool)
11.469 + subs (rls:rls') (ct:cterm') =
11.470 + let
11.471 + val thy = (the o assoc')(!theory',thy');
11.472 + val subrls = instantiate_rls subs ((the o assoc')(!ruleset',rls))
11.473 + in
11.474 + case rewrite_set_ thy
11.475 + ((the o assoc')(!ruleset',erls)) put_asm subrls
11.476 + ((term_of o the o (parse thy)) ct) of
11.477 + None => None
11.478 + | Some (t, ts) => Some (Sign.string_of_term (sign_of thy) t,
11.479 + map (Sign.string_of_term (sign_of thy)) ts)
11.480 + end;
11.481 +
11.482 +
11.483 +fun eval_true thy ts rls =
11.484 + case eval_true_ thy ts rls of
11.485 + (TRUE, _) => true
11.486 + | _ => false;
11.487 +
11.488 +(*vor check_elementwise: SqRoot_eval_rls .. wie *_simplify ?! TODO *)
11.489 +fun eval_true' (thy':theory') (rls':rls') (Const ("True",_)) = true
11.490 +
11.491 + | eval_true' (thy':theory') (rls':rls') (t:term) =
11.492 +(* val thy'="Isac.thy"; val rls'="eval_rls"; val t=hd pres';
11.493 + *)
11.494 + let val ct' = Sign.string_of_term (sign_of thy) t;
11.495 + in case rewrite_set thy' rls' false rls' ct' of
11.496 + Some ("True",_) => true
11.497 + | _ => false
11.498 + end;
11.499 +
11.500 +(*
11.501 +val test_rls =
11.502 + Rls{preconds = [], rew_ord = ("sqrt_right",sqrt_right),
11.503 + rules = [Calc ("matches",eval_matches "")
11.504 + ],
11.505 + scr = Script ((term_of o the o (parse thy))
11.506 + "empty_script")
11.507 + }:rls;
11.508 +
11.509 +
11.510 +
11.511 + rewrite_set_ Isac.thy eval_rls false test_rls
11.512 + ((the o (parse thy)) "matches (?a = ?b) (x = #0)");
11.513 + val xxx = (term_of o the o (parse thy))
11.514 + "matches (?a = ?b) (x = #0)";
11.515 + eval_matches """" xxx thy;
11.516 +Some ("matches (?a = ?b) (x + #1 + #-1 * #2 = #0) = True",
11.517 + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
11.518 +
11.519 +
11.520 +
11.521 + rewrite_set_ Isac.thy eval_rls false eval_rls
11.522 + ((the o (parse thy)) "contains_root (sqrt #0)");
11.523 +val it = Some ("True",[]) : (cterm * cterm list) option
11.524 +
11.525 +
11.526 +
11.527 +
11.528 +*)