1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/Tools/isac/Build_Isac.thy Wed Aug 25 16:20:07 2010 +0200
1.3 @@ -0,0 +1,103 @@
1.4 +(* Title: ~~~/isac/Isac_Mathengine.thy
1.5 + Author: Walther Neuper, TU Graz
1.6 +
1.7 +$ cd /usr/local/Isabelle2009-1/src/Tools/isac
1.8 +$ /usr/local/isabisac/bin/isabelle emacs Build_Isac.thy &
1.9 +$ /usr/local/isabisac/bin/isabelle jedit Build_Isac.thy &
1.10 +
1.11 +12345678901234567890123456789012345678901234567890123456789012345678901234567890
1.12 + 10 20 30 40 50 60 70 80
1.13 +*)
1.14 +
1.15 +header {* Loading the isac mathengine *}
1.16 +
1.17 +theory Build_Isac
1.18 +(*imports Complex_Main*)
1.19 +imports Complex_Main "ProgLang/Script"
1.20 + (*ListC, Tools, Script*)
1.21 +begin
1.22 +
1.23 +ML {*
1.24 +writeln "**** build the isac kernel = math-engine + Knowledge ***********";
1.25 +writeln "**** build the math-engine *************************************" *}
1.26 +
1.27 +ML {* Toplevel.debug := true; *}
1.28 +use "library.sml"
1.29 +use "calcelems.sml"
1.30 +ML {* check_guhs_unique := true *}
1.31 +
1.32 +use "ProgLang/term.sml"
1.33 +use "ProgLang/calculate.sml"
1.34 +use "ProgLang/rewrite.sml"
1.35 +use_thy"ProgLang/Script"
1.36 +use "ProgLang/scrtools.sml"
1.37 +
1.38 +use "Interpret/mstools.sml"
1.39 +use "Interpret/ctree.sml"
1.40 +use "Interpret/ptyps.sml"
1.41 +use "Interpret/generate.sml"
1.42 +use "Interpret/calchead.sml"
1.43 +use "Interpret/appl.sml"
1.44 +use "Interpret/rewtools.sml"
1.45 +use "Interpret/script.sml"
1.46 +use "Interpret/solve.sml"
1.47 +use "Interpret/inform.sml"
1.48 +use "Interpret/mathengine.sml"
1.49 +
1.50 +use "xmlsrc/mathml.sml"
1.51 +use "xmlsrc/datatypes.sml"
1.52 +use "xmlsrc/pbl-met-hierarchy.sml"
1.53 +use "xmlsrc/thy-hierarchy.sml"
1.54 +use "xmlsrc/interface-xml.sml"
1.55 +
1.56 +use "Frontend/messages.sml"
1.57 +use "Frontend/states.sml"
1.58 +use "Frontend/interface.sml"
1.59 +
1.60 +use "print_exn_G.sml"
1.61 +ML {* writeln "**** build math-engine complete **************************" *}
1.62 +
1.63 +ML {* writeln "**** build the Knowledge *********************************" *}
1.64 +use_thy "Knowledge/Typefix"
1.65 +use_thy "Knowledge/Descript"
1.66 +
1.67 +ML {*
1.68 +
1.69 +111;
1.70 +*}
1.71 +
1.72 +use_thy "Knowledge/Atools"
1.73 +
1.74 +
1.75 +ML {*
1.76 +val str = "1234567890";
1.77 +*}
1.78 +
1.79 +(*
1.80 +use_thy "Knowledge/Simplify"
1.81 +use_thy "Knowledge/Poly"
1.82 +use_thy "Knowledge/Rational"
1.83 +use_thy "Knowledge/PolyMinus"
1.84 +use_thy "Knowledge/Equation"
1.85 +use_thy "Knowledge/LinEq"
1.86 +use_thy "Knowledge/Root"
1.87 +use_thy "Knowledge/RootEq"
1.88 +use_thy "Knowledge/RatEq"
1.89 +use_thy "Knowledge/RootRat"
1.90 +use_thy "Knowledge/RootRatEq"
1.91 +use_thy "Knowledge/PolyEq"
1.92 +use_thy "Knowledge/Vect"
1.93 +use_thy "Knowledge/Calculus"
1.94 +use_thy "Knowledge/Trig"
1.95 +use_thy "Knowledge/LogExp"
1.96 +use_thy "Knowledge/Diff"
1.97 +use_thy "Knowledge/DiffApp"
1.98 +use_thy "Knowledge/Integrate"
1.99 +use_thy "Knowledge/EqSystem"
1.100 +use_thy "Knowledge/Biegelinie"
1.101 +use_thy "Knowledge/AlgEin"
1.102 +use_thy "Knowledge/Test"
1.103 +use_thy "Knowledge/Isac"
1.104 +*)
1.105 +end
1.106 +
2.1 --- a/src/Tools/isac/CLEANUP Wed Aug 25 15:15:01 2010 +0200
2.2 +++ b/src/Tools/isac/CLEANUP Wed Aug 25 16:20:07 2010 +0200
2.3 @@ -21,7 +21,7 @@
2.4 rm *.tar*
2.5 rm *.orig
2.6 cd ..
2.7 -cd FE-interface
2.8 +cd Frontend
2.9 rm *~
2.10 rm #*
2.11 rm .#*
3.1 --- a/src/Tools/isac/FE-interface/interface.sml Wed Aug 25 15:15:01 2010 +0200
3.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3 @@ -1,843 +0,0 @@
3.4 -(* the interface between the isac-kernel and the java-frontend;
3.5 - the isac-kernel holds calc-trees; stdout in XML-format.
3.6 - authors: Walther Neuper 2002
3.7 - (c) due to copyright terms
3.8 -
3.9 -use"FE-interface/interface.sml";
3.10 -use"interface.sml";
3.11 -*)
3.12 -
3.13 -signature INTERFACE =
3.14 - sig
3.15 - val CalcTree : fmz list -> unit
3.16 - val DEconstrCalcTree : calcID -> unit
3.17 - val Iterator : calcID -> unit
3.18 - val IteratorTEST : calcID -> iterID
3.19 - val appendFormula : calcID -> cterm' -> unit
3.20 - val autoCalculate : calcID -> auto -> unit
3.21 - val checkContext : calcID -> pos' -> guh -> unit
3.22 - val fetchApplicableTactics : calcID -> int -> pos' -> unit
3.23 - val fetchProposedTactic : calcID -> unit
3.24 - val applyTactic : calcID -> pos' -> tac -> unit
3.25 - val getAccumulatedAsms : calcID -> pos' -> unit
3.26 - val getActiveFormula : calcID -> unit
3.27 - val getAssumptions : calcID -> pos' -> unit
3.28 - val initContext : calcID -> ketype -> pos' -> unit
3.29 - val getFormulaeFromTo : calcID -> pos' -> pos' -> int -> bool -> unit
3.30 - val getTactic : calcID -> pos' -> unit
3.31 - val interSteps : calcID -> pos' -> unit
3.32 - val modifyCalcHead : calcID -> icalhd -> unit
3.33 - val moveActiveCalcHead : calcID -> unit
3.34 - val moveActiveDown : calcID -> unit
3.35 - val moveActiveDownTEST : calcID -> unit
3.36 - val moveActiveFormula : calcID -> pos' -> unit
3.37 - val moveActiveLevelDown : calcID -> unit
3.38 - val moveActiveLevelUp : calcID -> unit
3.39 - val moveActiveRoot : calcID -> unit
3.40 - val moveActiveRootTEST : calcID -> unit
3.41 - val moveActiveUp : calcID -> unit
3.42 - val moveCalcHead : calcID -> pos' -> unit
3.43 - val moveDown : calcID -> pos' -> unit
3.44 - val moveLevelDown : calcID -> pos' -> unit
3.45 - val moveLevelUp : calcID -> pos' -> unit
3.46 - val moveRoot : calcID -> unit
3.47 - val moveUp : calcID -> pos' -> unit
3.48 - val refFormula : calcID -> pos' -> unit
3.49 - val replaceFormula : calcID -> cterm' -> unit
3.50 - val resetCalcHead : calcID -> unit
3.51 - val modelProblem : calcID -> unit
3.52 - val refineProblem : calcID -> pos' -> guh -> unit
3.53 - val setContext : calcID -> pos' -> guh -> unit
3.54 - val setMethod : calcID -> metID -> unit
3.55 - val setNextTactic : calcID -> tac -> unit
3.56 - val setProblem : calcID -> pblID -> unit
3.57 - val setTheory : calcID -> thyID -> unit
3.58 - end
3.59 -
3.60 -
3.61 -(*------------------------------------------------------------------*)
3.62 -structure interface : INTERFACE =
3.63 -struct
3.64 -(*------------------------------------------------------------------*)
3.65 -
3.66 -(*.encode "Isabelle"-strings as seen by the user to the
3.67 - format accepted by Isabelle.
3.68 - encode "^" ---> "^^^"; see IsacKnowledge/Atools.thy;
3.69 - called for each cterm', icalhd, fmz in this interface;
3.70 - + see "fun decode" in xmlsrc/mathml.sml.*)
3.71 -fun encode (str:cterm') =
3.72 - let fun enc [] = []
3.73 - | enc ("^"::cs) = "^"::"^"::"^"::(enc cs)
3.74 - | enc (c::cs) = c::(enc cs)
3.75 - in (implode o enc o explode) str:cterm' end;
3.76 -fun encode_imodel (imodel:imodel) =
3.77 - let fun enc (Given ifos) = Given (map encode ifos)
3.78 - | enc (Find ifos) = Find (map encode ifos)
3.79 - | enc (Relate ifos) = Relate (map encode ifos)
3.80 - in map enc imodel:imodel end;
3.81 -fun encode_icalhd ((pos', headl, imodel, pos_, spec):icalhd) =
3.82 - (pos', encode headl, encode_imodel imodel, pos_, spec):icalhd;
3.83 -fun encode_fmz ((ifos, spec):fmz) = (map encode ifos, spec):fmz;
3.84 -
3.85 -
3.86 -(***. CalcTree .***)
3.87 -
3.88 -(** add and delete users **)
3.89 -
3.90 -(*.'Iterator 1' must exist with each CalcTree;
3.91 - the only for updating the calc-tree
3.92 - WN.0411: only 'Iterator 1' is stored,
3.93 - all others are just calculated on the fly
3.94 - TODO: adapt Iterator, add_user(= add_iterator!),etc. accordingly .*)
3.95 -fun Iterator (cI:calcID) = (*returned ID unnecessary after WN.0411*)
3.96 - (adduserOK2xml cI (add_user (cI:calcID)))
3.97 - handle _ => sysERROR2xml cI "error in kernel";
3.98 -fun IteratorTEST (cI:calcID) = add_user (cI:calcID);
3.99 -(*fun DEconstructIterator (cI:calcID) (uI:iterID) =
3.100 - deluserOK2xml (del_user cI uI);*)
3.101 -
3.102 -(*.create a calc-tree; for calls from java: thus ^^^ decoded to ^;
3.103 - compare "fun CalcTreeTEST" which does NOT decode.*)
3.104 -fun CalcTree
3.105 - [(fmz, sp):fmz] (*for several variants lateron*) =
3.106 -(* val[(fmz,sp):fmz]=[(["fixedValues [r=Arbfix]","maximum A","valuesFor [a,b]",
3.107 - "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]",
3.108 - "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]",
3.109 - "relations [A=a*b, a/2=r*sin alpha, b/2=r*cos alpha]",
3.110 - "boundVariable a","boundVariable b","boundVariable alpha",
3.111 - "interval {x::real. 0 <= x & x <= 2*r}",
3.112 - "interval {x::real. 0 <= x & x <= 2*r}",
3.113 - "interval {x::real. 0 <= x & x <= pi}",
3.114 - "errorBound (eps=(0::real))"],
3.115 - ("DiffApp.thy", ["maximum_of","function"],
3.116 - ["DiffApp","max_by_calculus"]))];
3.117 -
3.118 - *)
3.119 - (let val cs = nxt_specify_init_calc (encode_fmz (fmz, sp))
3.120 - (*FIXME.WN.8.03: error-handling missing*)
3.121 - val cI = add_calc cs
3.122 - in calctreeOK2xml cI end)
3.123 - handle _ => sysERROR2xml 0 "error in kernel";
3.124 -
3.125 -fun DEconstrCalcTree (cI:calcID) =
3.126 - deconstructcalctreeOK2xml (del_calc cI);
3.127 -
3.128 -
3.129 -fun getActiveFormula (cI:calcID) = iteratorOK2xml cI (get_pos cI 1);
3.130 -
3.131 -fun moveActiveFormula (cI:calcID) (p:pos') =
3.132 - let val ((pt,_),_) = get_calc cI
3.133 - in if existpt' p pt then (upd_ipos cI 1 p; iteratorOK2xml cI p)
3.134 - else sysERROR2xml cI "frontend sends a non-existing pos" end;
3.135 -
3.136 -(*. set the next tactic to be applied: dont't change the calc-tree,
3.137 - but remember the envisaged changes for fun autoCalculate;
3.138 - compare force NextTactic .*)
3.139 -(* val (cI, tac) = (1, Add_Given "equality (x ^^^ 2 + 4 * x + 3 = 0)");
3.140 - val (cI, tac) = (1, Specify_Theory "PolyEq.thy");
3.141 - val (cI, tac) = (1, Specify_Problem ["normalize","polynomial",
3.142 - "univariate","equation"]);
3.143 - val (cI, tac) = (1, Subproblem ("Poly.thy",
3.144 - ["polynomial","univariate","equation"]));
3.145 - val (cI, tac) = (1, Model_Problem["linear","univariate","equation","test"]);
3.146 - val (cI, tac) = (1, Detail_Set "Test_simplify");
3.147 - val (cI, tac) = (1, Apply_Method ["Test", "solve_linear"]);
3.148 - val (cI, tac) = (1, Rewrite_Set "Test_simplify");
3.149 - *)
3.150 -fun setNextTactic (cI:calcID) tac =
3.151 - let val ((pt, _), _) = get_calc cI
3.152 - val ip = get_pos cI 1
3.153 - in case locatetac tac (pt, ip) of
3.154 -(* val ("ok", (tacis, c, (_,p'))) = locatetac tac (pt, ip);
3.155 - *)
3.156 - ("ok", (tacis, _, _)) =>
3.157 - (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "ok")
3.158 - | ("unsafe-ok", (tacis, _, _)) =>
3.159 - (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "unsafe-ok")
3.160 - | ("not-applicable",_) => setnexttactic2xml cI "not-applicable"
3.161 - | ("end-of-calculation",_) =>
3.162 - setnexttactic2xml cI "end-of-calculation"
3.163 - | ("failure",_) => sysERROR2xml cI "failure"
3.164 - end;
3.165 -
3.166 -(*. apply a tactic at a position and update the calc-tree if applicable .*)
3.167 -(*WN080226 java-code is missing, errors smltest/IsacKnowledge/polyminus.sml*)
3.168 -(* val (cI, ip, tac) = (1, p, hd appltacs);
3.169 - val (cI, ip, tac) = (1, p, (hd (sel_appl_atomic_tacs pt p)));
3.170 - *)
3.171 -fun applyTactic (cI:calcID) ip tac =
3.172 - let val ((pt, _), _) = get_calc cI
3.173 - val p = get_pos cI 1
3.174 - in case locatetac tac (pt, ip) of
3.175 -(* val ("ok", (tacis, c, (pt',p'))) = locatetac tac (pt, ip);
3.176 - *)
3.177 - ("ok", (_, c, ptp as (_,p'))) =>
3.178 - (upd_calc cI (ptp, []); upd_ipos cI 1 p';
3.179 - autocalculateOK2xml cI p (if null c then p'
3.180 - else last_elem c) p')
3.181 - | ("unsafe-ok", (_, c, ptp as (_,p'))) =>
3.182 - (upd_calc cI (ptp, []); upd_ipos cI 1 p';
3.183 - autocalculateOK2xml cI p (if null c then p'
3.184 - else last_elem c) p')
3.185 - | ("end-of-calculation", (_, c, ptp as (_,p'))) =>
3.186 - (upd_calc cI (ptp, []); upd_ipos cI 1 p';
3.187 - autocalculateOK2xml cI p (if null c then p'
3.188 - else last_elem c) p')
3.189 -
3.190 -
3.191 - | (str,_) => autocalculateERROR2xml cI "failure"
3.192 - end;
3.193 -
3.194 -
3.195 -
3.196 -(* val cI = 1;
3.197 - *)
3.198 -fun fetchProposedTactic (cI:calcID) =
3.199 - (case step (get_pos cI 1) (get_calc cI) of
3.200 - ("ok", (tacis, _, _)) =>
3.201 - let val _= upd_tacis cI tacis
3.202 - val (tac,_,_) = last_elem tacis
3.203 - in fetchproposedtacticOK2xml cI tac end
3.204 - | ("helpless",_) => fetchproposedtacticERROR2xml cI "helpless"
3.205 - | ("no-fmz-spec",_) => fetchproposedtacticERROR2xml cI "no-fmz-spec"
3.206 - | ("end-of-calculation",_) =>
3.207 - fetchproposedtacticERROR2xml cI "end-of-calculation")
3.208 - handle _ => sysERROR2xml cI "error in kernel";
3.209 -
3.210 -(*datatype auto = FIXXXME040624: does NOT match interfaces/ITOCalc.java
3.211 - Step of int (*1 do #int steps (may stop in model/specify)
3.212 - IS VERY INEFFICIENT IN MODEL/SPECIY*)
3.213 -| CompleteModel (*2 complete modeling
3.214 - if model complete, finish specifying*)
3.215 -| CompleteCalcHead (*3 complete model/specify in one go*)
3.216 -| CompleteToSubpbl (*4 stop at the next begin of a subproblem,
3.217 - if none, complete the actual (sub)problem*)
3.218 -| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*)
3.219 -| CompleteCalc; (*6 complete the calculation as a whole*)*)
3.220 -fun autoCalculate (cI:calcID) auto =
3.221 -(* val (cI, auto) = (1,CompleteCalc);
3.222 - val (cI, auto) = (1,CompleteModel);
3.223 - val (cI, auto) = (1,CompleteCalcHead);
3.224 - val (cI, auto) = (1,Step 1);
3.225 - *)
3.226 - (let val pold = get_pos cI 1
3.227 - val x = autocalc [] pold (get_calc cI) auto
3.228 - in
3.229 - case x of
3.230 -(* val (str, c, ptp as (_,p)) = x;
3.231 - *)
3.232 - ("ok", c, ptp as (_,p)) =>
3.233 - (upd_calc cI (ptp, []); upd_ipos cI 1 p;
3.234 - autocalculateOK2xml cI pold (if null c then pold
3.235 - else last_elem c) p)
3.236 - | ("end-of-calculation", c, ptp as (_,p)) =>
3.237 - (upd_calc cI (ptp, []); upd_ipos cI 1 p;
3.238 - autocalculateOK2xml cI pold (if null c then pold
3.239 - else last_elem c) p)
3.240 - | (str, _, _) => autocalculateERROR2xml cI str
3.241 - end)
3.242 - handle _ => sysERROR2xml cI "error in kernel";
3.243 -
3.244 -
3.245 -(* val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) =
3.246 - (1, (([],Pbl), "not used here",
3.247 - [Given ["fixedValues [r=Arbfix]"],
3.248 - Find ["maximum A", "valuesFor [a,b]"(*new input*)],
3.249 - Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl,
3.250 - ("DiffApp.thy", ["maximum_of","function"],
3.251 - ["DiffApp","max_by_calculus"])));
3.252 - val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) =
3.253 - (1, (([],Pbl),"solve (x+1=2, x)",
3.254 - [Given ["equality (x+1=2)", "solveFor x"],
3.255 - Find ["solutions L"]],
3.256 - Pbl,
3.257 - ("Test.thy", ["linear","univariate","equation","test"],
3.258 - ["Test","solve_linear"])));
3.259 - val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) =
3.260 - (1, (([],Pbl),"solveTest (1+-1*2+x=0,x)", [], Pbl, ("", [], [])));
3.261 - val (cI, p:pos')=(1, ([1],Frm));
3.262 - val (cI, p:pos')=(1, ([1,2,1,3],Res));
3.263 - *)
3.264 -fun getTactic cI (p:pos') =
3.265 - (let val ((pt,_),_) = get_calc cI
3.266 - val (form, tac, asms) = pt_extract (pt, p)
3.267 - in case tac of
3.268 -(* val SOME ta = tac;
3.269 - *)
3.270 - SOME ta => gettacticOK2xml cI ta
3.271 - | NONE => gettacticERROR2xml cI ("no tactic at position "^pos'2str p)
3.272 - end)
3.273 - handle _ => sysERROR2xml cI "syserror in getTactic";
3.274 -
3.275 -(*. see ICalcIterator#fetchApplicableTactics
3.276 - @see #TACTICS_ALL
3.277 - @see #TACTICS_CURRENT_THEORY
3.278 - @see #TACTICS_CURRENT_METHOD ..the only impl.WN040307.*)
3.279 -(*. fetch tactics to be applied to a particular step.*)
3.280 -(* WN071231 kept this version for later parametrisation*)
3.281 -(*.version 1: fetch _all_ tactics from script .*)
3.282 -fun fetchApplicableTactics cI (scope:int) (p:pos') =
3.283 - (let val ((pt, _), _) = get_calc cI
3.284 - in (applicabletacticsOK cI (sel_rules pt p))
3.285 - handle PTREE str => sysERROR2xml cI str
3.286 - end)
3.287 - handle _ => sysERROR2xml cI "error in kernel";
3.288 -(*.version 2: fetch _applicable_ _elementary_ (ie. recursively
3.289 - decompose rule-sets) Rewrite*, Calculate .*)
3.290 -fun fetchApplicableTactics cI (scope:int) (p:pos') =
3.291 - (let val ((pt, _), _) = get_calc cI
3.292 - in (applicabletacticsOK cI (sel_appl_atomic_tacs pt p))
3.293 - handle PTREE str => sysERROR2xml cI str
3.294 - end)
3.295 - handle _ => sysERROR2xml cI "error in kernel";
3.296 -
3.297 -fun getAssumptions cI (p:pos') =
3.298 - (let val ((pt,_),_) = get_calc cI
3.299 - val (_, _, asms) = pt_extract (pt, p)
3.300 - in getasmsOK2xml cI asms end)
3.301 - handle _ => sysERROR2xml cI "syserror in getAssumptions";
3.302 -
3.303 -(*WN0502 @see ME/ctree: type asms: illdesigned, thus no positions returned*)
3.304 -fun getAccumulatedAsms cI (p:pos') =
3.305 - (let val ((pt, _), _) = get_calc cI
3.306 - val ass = map fst (get_assumptions_ pt p)
3.307 - in (*getaccuasmsOK2xml cI (get_assumptions_ pt p)*)
3.308 - getasmsOK2xml cI ass end)
3.309 - handle _ => sysERROR2xml cI "syserror in getAccumulatedAsms";
3.310 -
3.311 -
3.312 -(*since moveActive* does NOT transfer pos java --> sml (only sml --> java)
3.313 - refFormula might become involved in far-off errors !!!*)
3.314 -fun refFormula cI (p:pos') = (*WN0501 rename to 'fun getElement' !*)
3.315 -(* val (cI, uI) = (1,1);
3.316 - *)
3.317 - (let val ((pt,_),_) = get_calc cI
3.318 - val (form, tac, asms) = pt_extract (pt, p)
3.319 - in refformulaOK2xml cI p form end)
3.320 - handle _ => sysERROR2xml cI "error in kernel";
3.321 -
3.322 -(*.get formulae 'from' 'to' w.r.t. ordering in Position#compareTo(Position p);
3.323 - in case of CalcHeads only the headline is taken
3.324 - (the pos' allows distinction between PrfObj and PblObj anyway);
3.325 - 'level' is adjusted such that an 'interval' of formulae is returned;
3.326 - 'from' 'to' are designed for use by iterators of calcChangedEvent;
3.327 - thus 'from' is the last unchanged position.*)
3.328 -fun getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Pbl):pos')_ false =
3.329 -(*special case because 'from' is _before_ the first elements to be returned*)
3.330 -(* val (cI, from, to, level) = (1, ([],Pbl), ([],Pbl), 1);
3.331 - *)
3.332 - ((let val ((pt,_),_) = get_calc cI
3.333 - val (ModSpec (_,_,headline,_,_,_),_,_) = pt_extract (pt, to)
3.334 - in getintervalOK cI [(to, headline)] end)
3.335 - handle _ => sysERROR2xml cI "error in kernel")
3.336 -
3.337 - | getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Met):pos')_ false =
3.338 - getFormulaeFromTo cI ([],Pbl) ([],Pbl) (~00000) false
3.339 -
3.340 - | getFormulaeFromTo cI (from:pos') (to:pos') level false =
3.341 -(* val (cI, from, to, level) = (1, unc, gen, 0);
3.342 - val (cI, from, to, level) = (1, unc, gen, 1);
3.343 - val (cI, from, to, level) = (1, ([],Pbl), ([],Met), 1);
3.344 - *)
3.345 - (if from = to then sysERROR2xml cI "getFormulaeFromTo: From = To"
3.346 - else
3.347 - (case from of
3.348 - ([],Res) => sysERROR2xml cI "getFormulaeFromTo does: moveDown \
3.349 - \from=([],Res) .. goes beyond result"
3.350 - | _ => let val ((pt,_),_) = get_calc cI
3.351 - val f = move_dn [] pt from
3.352 - fun max (a,b) = if a < b then b else a
3.353 - (*must reach margins ...*)
3.354 - val lev = max (level, max (lev_of from, lev_of to))
3.355 - in getintervalOK cI (get_interval f to lev pt) end)
3.356 - handle _ => sysERROR2xml cI "error in getFormulaeFromTo")
3.357 -
3.358 - | getFormulaeFromTo cI from to level true =
3.359 - sysERROR2xml cI "getFormulaeFromTo impl.for formulae only,\
3.360 - \i.e. last arg only impl. for false, _NOT_ true";
3.361 -
3.362 -
3.363 -(* val (cI, ip) = (1, ([1,9], Res));
3.364 - val (cI, ip) = (1, ([], Res));
3.365 - val (cI, ip) = (1, ([2], Res));
3.366 - val (cI, ip) = (1, ([3,1], Res));
3.367 - val (cI, ip) = (1, ([1,2,1], Res));
3.368 - *)
3.369 -fun interSteps cI ip =
3.370 - (let val ((pt,p), tacis) = get_calc cI
3.371 - in if (not o is_interpos) ip
3.372 - then interStepsERROR cI "only formulae with position (_,Res) \
3.373 - \may have intermediate steps above them"
3.374 - else let val ip' = lev_pred' pt ip
3.375 -(* val (str, pt', lastpos) = detailstep pt ip;
3.376 - *)
3.377 - in case detailstep pt ip of
3.378 - ("detailrls", pt(*, pos'forms*), lastpos) =>
3.379 - (upd_calc cI ((pt, p), tacis);
3.380 - interStepsOK cI (*pos'forms*) ip' ip' lastpos)
3.381 - | ("no-Rewrite_Set...", _, _) =>
3.382 - sysERROR2xml cI "no Rewrite_Set..."
3.383 - | (_, _(*, pos'formshds*), lastpos) =>
3.384 - interStepsOK cI (*pos'formshds*) ip' ip' lastpos
3.385 - end
3.386 - end)
3.387 - handle _ => sysERROR2xml cI "error in kernel";
3.388 -
3.389 -fun modifyCalcHead (cI:calcID) (ichd as ((p,_),_,_,_,_):icalhd) =
3.390 - (let val ((pt,_),_) = get_calc cI
3.391 - val (pt, chd as (_,p_,_,_,_,_)) = input_icalhd pt ichd
3.392 - in (upd_calc cI ((pt, (p,p_)), []);
3.393 - modifycalcheadOK2xml cI chd) end)
3.394 - handle _ => sysERROR2xml cI "error in kernel";
3.395 -
3.396 -(*.at the activeFormula set the Model, the Guard and the Specification
3.397 - to empty and return a CalcHead;
3.398 - the 'origin' remains (for reconstructing all that).*)
3.399 -fun resetCalcHead (cI:calcID) =
3.400 - (let val (ptp,_) = get_calc cI
3.401 - val ptp = reset_calchead ptp
3.402 - in (upd_calc cI (ptp, []);
3.403 - modifycalcheadOK2xml cI (get_ocalhd ptp)) end)
3.404 - handle _ => sysERROR2xml cI "error in kernel";
3.405 -
3.406 -(*.at the activeFormula insert all the Descriptions in the Model
3.407 - (_not_ in the Guard) and return a CalcHead;
3.408 - the Descriptions are for user-guidance; the rest of the items
3.409 - are left empty for user-input;
3.410 - includes a resetCalcHead for the Model and the Guard.*)
3.411 -fun modelProblem (cI:calcID) =
3.412 - (let val (ptp, _) = get_calc cI
3.413 - val ptp = reset_calchead ptp
3.414 - val (_, _, ptp) = nxt_specif Model_Problem ptp
3.415 - in (upd_calc cI (ptp, []);
3.416 - modifycalcheadOK2xml cI (get_ocalhd ptp)) end)
3.417 - handle _ => sysERROR2xml cI "error in kernel";
3.418 -
3.419 -
3.420 -(*.set the context determined on a knowledgebrowser to the current calc.*)
3.421 -fun setContext (cI:calcID) (ip as (_,p_):pos') (guh:guh) =
3.422 - (case (implode o (take_fromto 1 4) o explode) guh of
3.423 - "thy_" =>
3.424 -(* val (cI, ip as (_,p_), guh) = (1, p, "thy_isac_Test-rls-Test_simplify");
3.425 - *)
3.426 - if member op = [Pbl,Met] p_
3.427 - then message2xml cI "thy-context not to calchead"
3.428 - else if ip = ([],Res) then message2xml cI "no thy-context at result"
3.429 - else if no_thycontext guh then message2xml cI ("no thy-context for '"^
3.430 - guh ^ "'")
3.431 - else let val (ptp as (pt,pold),_) = get_calc cI
3.432 - val is = get_istate pt ip
3.433 - val subs = subs_from is "dummy" guh
3.434 - val tac = guh2rewtac guh subs
3.435 - in case locatetac tac (pt, ip) of (*='fun setNextTactic'+step*)
3.436 - ("ok", (tacis, c, ptp as (_,p))) =>
3.437 -(* val (str, (tacis, c, ptp as (_,p))) = locatetac tac (pt, ip);
3.438 - *)
3.439 - (upd_calc cI ((pt,p), []);
3.440 - autocalculateOK2xml cI pold (if null c then pold
3.441 - else last_elem c) p)
3.442 - | ("unsafe-ok", (tacis, c, ptp as (_,p))) =>
3.443 - (upd_calc cI ((pt,p), []);
3.444 - autocalculateOK2xml cI pold (if null c then pold
3.445 - else last_elem c) p)
3.446 - | ("end-of-calculation",_) =>
3.447 - message2xml cI "end-of-calculation"
3.448 - | ("failure",_) => sysERROR2xml cI "failure"
3.449 - | ("not-applicable",_) => (*the rule comes from anywhere..*)
3.450 - (case applicable_in ip pt tac of
3.451 -
3.452 - Notappl e => message2xml cI ("'" ^ tac2str tac ^
3.453 - "' not-applicable")
3.454 - | Appl m =>
3.455 - let val (p,c,_,pt) = generate1 (assoc_thy"Isac.thy")
3.456 - m Uistate ip pt
3.457 - in upd_calc cI ((pt,p),[]);
3.458 - autocalculateOK2xml cI pold (if null c then pold
3.459 - else last_elem c) p
3.460 - end)
3.461 - end
3.462 -(* val (cI, ip as (_,p_), guh) = (1, pos, guh);
3.463 - *)
3.464 - | "pbl_" =>
3.465 - let val pI = guh2kestoreID guh
3.466 - val ((pt, _), _) = get_calc cI
3.467 - (*val ip as (_, p_) = get_pos cI 1*)
3.468 - in if member op = [Pbl, Met] p_
3.469 - then let val (pt, chd) = set_problem pI (pt, ip)
3.470 - in (upd_calc cI ((pt, ip), []);
3.471 - modifycalcheadOK2xml cI chd) end
3.472 - else sysERROR2xml cI "setContext for pbl requires ActiveFormula \
3.473 - \on CalcHead"
3.474 - end
3.475 -(* val (cI, ip as (_,p_), guh) = (1, pos, "met_eq_lin");
3.476 - *)
3.477 - | "met_" =>
3.478 - let val mI = guh2kestoreID guh
3.479 - val ((pt, _), _) = get_calc cI
3.480 - in if member op = [Pbl, Met] p_
3.481 - then let val (pt, chd) = set_method mI (pt, ip)
3.482 - in (upd_calc cI ((pt, ip), []);
3.483 - modifycalcheadOK2xml cI chd) end
3.484 - else sysERROR2xml cI "setContext for met requires ActiveFormula \
3.485 - \on CalcHead"
3.486 - end)
3.487 - handle _ => sysERROR2xml cI "error in kernel";
3.488 -
3.489 -
3.490 -(*.specify the Method at the activeFormula and return a CalcHead
3.491 - containing the Guard.
3.492 - WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*)
3.493 -fun setMethod (cI:calcID) (mI:metID) =
3.494 -(* val (cI, mI) = (1, ["Test","solve_linear"]);
3.495 - *)
3.496 - (let val ((pt, _), _) = get_calc cI
3.497 - val ip as (_, p_) = get_pos cI 1
3.498 - in if member op = [Pbl,Met] p_
3.499 - then let val (pt, chd) = set_method mI (pt, ip)
3.500 - in (upd_calc cI ((pt, ip), []);
3.501 - modifycalcheadOK2xml cI chd) end
3.502 - else sysERROR2xml cI "setMethod requires ActiveFormula on CalcHead"
3.503 - end)
3.504 - handle _ => sysERROR2xml cI "error in kernel";
3.505 -
3.506 -(*.specify the Problem at the activeFormula and return a CalcHead
3.507 - containing the Model; special case of checkContext;
3.508 - WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem '.*)
3.509 -fun setProblem (cI:calcID) (pI:pblID) =
3.510 - (let val ((pt, _), _) = get_calc cI
3.511 - val ip as (_, p_) = get_pos cI 1
3.512 - in if member op = [Pbl,Met] p_
3.513 - then let val (pt, chd) = set_problem pI (pt, ip)
3.514 - in (upd_calc cI ((pt, ip), []);
3.515 - modifycalcheadOK2xml cI chd) end
3.516 - else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead"
3.517 - end)
3.518 - handle _ => sysERROR2xml cI "error in kernel";
3.519 -
3.520 -(*.specify the Theory at the activeFormula and return a CalcHead;
3.521 - special case of checkContext;
3.522 - WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*)
3.523 -fun setTheory (cI:calcID) (tI:thyID) =
3.524 - (let val ((pt, _), _) = get_calc cI
3.525 - val ip as (_, p_) = get_pos cI 1
3.526 - in if member op = [Pbl,Met] p_
3.527 - then let val (pt, chd) = set_theory tI (pt, ip)
3.528 - in (upd_calc cI ((pt, ip), []);
3.529 - modifycalcheadOK2xml cI chd) end
3.530 - else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead"
3.531 - end)
3.532 - handle _ => sysERROR2xml cI "error in kernel";
3.533 -
3.534 -
3.535 -(**. without update of CalcTree .**)
3.536 -
3.537 -(*.match the model of a problem at pos p
3.538 - with the model-pattern of the problem with pblID*)
3.539 -(*fun tryMatchProblem cI pblID =
3.540 - (let val ((pt,_),_) = get_calc cI
3.541 - val p = get_pos cI 1
3.542 - val chd = trymatch pblID pt p
3.543 - in trymatchOK2xml cI chd end)
3.544 - handle _ => sysERROR2xml cI "error in kernel";*)
3.545 -
3.546 -(*.refinement for the parent-problem of the position.*)
3.547 -(* val (cI, (p,p_), guh) = (1, ([1],Res), "pbl_equ_univ");
3.548 - *)
3.549 -fun refineProblem cI ((p,p_) : pos') (guh : guh) =
3.550 - (let val pblID = guh2kestoreID guh
3.551 - val ((pt,_),_) = get_calc cI
3.552 - val pp = par_pblobj pt p
3.553 - val chd = tryrefine pblID pt (pp, p_)
3.554 - in matchpbl2xml cI chd end)
3.555 - handle _ => sysERROR2xml cI "error in kernel";
3.556 -
3.557 -(* val (cI, ifo) = (1, "-2 * 1 + (1 + x) = 0");
3.558 - val (cI, ifo) = (1, "x = 2");
3.559 - val (cI, ifo) = (1, "[x = 3 + -2*1]");
3.560 - val (cI, ifo) = (1, "-1 + x = 0");
3.561 - val (cI, ifo) = (1, "x - 4711 = 0");
3.562 - val (cI, ifo) = (1, "2+ -1 + x = 2");
3.563 - val (cI, ifo) = (1, " x - ");
3.564 - val (cI, ifo) = (1, "(-3 * x + 4 * y + -1 * x * y) / (x * y)");
3.565 - val (cI, ifo) = (1, "(4 * y + -3 * x) / (x * y) + -1");
3.566 - *)
3.567 -fun appendFormula cI (ifo:cterm') =
3.568 - (let val cs = get_calc cI
3.569 - val pos as (_,p_) = get_pos cI 1
3.570 - in case step pos cs of
3.571 -(* val (str, cs') = step pos cs;
3.572 - *)
3.573 - ("ok", cs') =>
3.574 - (case inform cs' (encode ifo) of
3.575 -(* val (str, (_, c, ptp as (_,p))) = inform cs' (encode ifo);
3.576 - *)
3.577 - ("ok", (_(*use in DG !!!*), c, ptp as (_,p))) =>
3.578 - (upd_calc cI (ptp, []); upd_ipos cI 1 p;
3.579 - appendformulaOK2xml cI pos (if null c then pos
3.580 - else last_elem c) p)
3.581 - | ("same-formula", (_, c, ptp as (_,p))) =>
3.582 - (upd_calc cI (ptp, []); upd_ipos cI 1 p;
3.583 - appendformulaOK2xml cI pos (if null c then pos
3.584 - else last_elem c) p)
3.585 - | (msg, _) => appendformulaERROR2xml cI msg)
3.586 - | (msg, cs') => appendformulaERROR2xml cI msg
3.587 - end)
3.588 - handle _ => sysERROR2xml cI "error in kernel";
3.589 -
3.590 -
3.591 -
3.592 -(*.replace a formula with_in_ a calculation;
3.593 - this situation applies for initial CAS-commands, too.*)
3.594 -(* val (cI, ifo) = (2, "-1 + x = 0");
3.595 - val (cI, ifo) = (1, "-1 + x = 0");
3.596 - val (cI, ifo) = (1, "x - 1 = 0");
3.597 - val (cI, ifo) = (1, "x = 1");
3.598 - val (cI, ifo) = (1, "solve(x+1=2,x)");
3.599 - val (cI, ifo) = (1, "Simplify (2*a + 3*a)");
3.600 - val (cI, ifo) = (1, "Diff (x^2 + x + 1, x)");
3.601 - *)
3.602 -fun replaceFormula cI (ifo:cterm') =
3.603 - (let val ((pt, _), _) = get_calc cI
3.604 - val p = get_pos cI 1
3.605 - in case inform (([], [], (pt, p)): calcstate') (encode ifo) of
3.606 - ("ok", (_(*tacs used for DG ?*), c, ptp' as (pt',p'))) =>
3.607 -(* val (str, (_,c, ptp' as (pt',p')))= inform ([], [], (pt, p)) (encode ifo);
3.608 - *)
3.609 - let val unc = if null (fst p) then p else move_up [] pt p
3.610 - val _ = upd_calc cI (ptp', [])
3.611 - val _ = upd_ipos cI 1 p'
3.612 - in replaceformulaOK2xml cI unc
3.613 - (if null c then unc
3.614 - else last_elem c) p'(*' NEW*) end
3.615 - | ("same-formula", _) =>
3.616 - (*TODO.WN0501 MESSAGE !*)
3.617 - replaceformulaERROR2xml cI "formula not changed"
3.618 - | (msg, _) => replaceformulaERROR2xml cI msg
3.619 - end)
3.620 - handle _ => sysERROR2xml cI "error in kernel";
3.621 -
3.622 -
3.623 -
3.624 -(***. CalcIterator
3.625 - moveActive*: set the pos' of the active formula stored with the calctree
3.626 - could take pos' as argument for consistency checks
3.627 - move*: compute the new iterator from the old one on the fly
3.628 -
3.629 -.***)
3.630 -
3.631 -fun moveActiveRoot cI =
3.632 - (let val _ = upd_ipos cI 1 ([],Pbl)
3.633 - in iteratorOK2xml cI ([],Pbl) end)
3.634 - handle e => sysERROR2xml cI "error in kernel";
3.635 -fun moveRoot cI =
3.636 - (iteratorOK2xml cI ([],Pbl))
3.637 - handle e => sysERROR2xml cI "";
3.638 -fun moveActiveRootTEST cI =
3.639 - (let val _ = upd_ipos cI 1 ([],Pbl)
3.640 - in (*iteratorOK2xml cI ([],Pbl)*)() end)
3.641 - handle e => sysERROR2xml cI "error in kernel";
3.642 -
3.643 -(* val (cI, uI) = (1,1);
3.644 - val (cI, uI) = (1,2);
3.645 - *)
3.646 -fun moveActiveDown cI =
3.647 - ((let val ((pt,_),_) = get_calc cI
3.648 -(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI);
3.649 - val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI);
3.650 -
3.651 - print_depth 7;pt
3.652 - *)
3.653 - val ip' = move_dn [] pt (get_pos cI 1)
3.654 - val _ = upd_ipos cI 1 ip'
3.655 - in iteratorOK2xml cI ip' end)
3.656 - handle (PTREE e) => iteratorERROR2xml cI)
3.657 - handle _ => sysERROR2xml cI "error in kernel";
3.658 -fun moveDown cI (p:pos') =
3.659 - ((let val ((pt,_),_) = get_calc cI
3.660 -(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI);
3.661 - val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI);
3.662 -
3.663 - print_depth 7;pt
3.664 - *)
3.665 - val ip' = move_dn [] pt p
3.666 - in iteratorOK2xml cI ip' end)
3.667 - handle (PTREE e) => iteratorERROR2xml cI)
3.668 - handle _ => sysERROR2xml cI "error in kernel";
3.669 -fun moveActiveDownTEST cI =
3.670 - let val ((pt,_),_) = get_calc cI
3.671 - val ip = get_pos cI 1
3.672 - val ip' = (move_dn [] pt ip)
3.673 - handle _ => ip
3.674 - val _ = upd_ipos cI 1 ip'
3.675 - in (*iteratorOK2xml cI uI*)() end;
3.676 -
3.677 -fun moveActiveLevelDown cI =
3.678 - ((let val ((pt,_),_) = get_calc cI
3.679 - val ip' = movelevel_dn [] pt (get_pos cI 1)
3.680 - val _ = upd_ipos cI 1 ip'
3.681 - in iteratorOK2xml cI ip' end)
3.682 - handle (PTREE e) => iteratorERROR2xml cI)
3.683 - handle _ => sysERROR2xml cI "error in kernel";
3.684 -fun moveLevelDown cI (p:pos') =
3.685 - ((let val ((pt,_),_) = get_calc cI
3.686 - val ip' = movelevel_dn [] pt p
3.687 - in iteratorOK2xml cI ip' end)
3.688 - handle (PTREE e) => iteratorERROR2xml cI)
3.689 - handle _ => sysERROR2xml cI "error in kernel";
3.690 -
3.691 -fun moveActiveUp cI =
3.692 - ((let val ((pt,_),_) = get_calc cI
3.693 - val ip' = move_up [] pt (get_pos cI 1)
3.694 - val _ = upd_ipos cI 1 ip'
3.695 - in iteratorOK2xml cI ip' end)
3.696 - handle PTREE e => iteratorERROR2xml cI)
3.697 - handle _ => sysERROR2xml cI "error in kernel";
3.698 -fun moveUp cI (p:pos') =
3.699 - ((let val ((pt,_),_) = get_calc cI
3.700 - val ip' = move_up [] pt p
3.701 - in iteratorOK2xml cI ip' end)
3.702 - handle PTREE e => iteratorERROR2xml cI)
3.703 - handle _ => sysERROR2xml cI "error in kernel";
3.704 -
3.705 -fun moveActiveLevelUp cI =
3.706 - ((let val ((pt,_),_) = get_calc cI
3.707 - val ip' = movelevel_up [] pt (get_pos cI 1)
3.708 - val _ = upd_ipos cI 1 ip'
3.709 - in iteratorOK2xml cI ip' end)
3.710 - handle PTREE e => iteratorERROR2xml cI)
3.711 - handle _ => sysERROR2xml cI "error in kernel";
3.712 -fun moveLevelUp cI (p:pos') =
3.713 - ((let val ((pt,_),_) = get_calc cI
3.714 - val ip' = movelevel_up [] pt p
3.715 - in iteratorOK2xml cI ip' end)
3.716 - handle PTREE e => iteratorERROR2xml cI)
3.717 - handle _ => sysERROR2xml cI "error in kernel";
3.718 -
3.719 -fun moveActiveCalcHead cI =
3.720 - ((let val ((pt,_),_) = get_calc cI
3.721 - val ip' = movecalchd_up pt (get_pos cI 1)
3.722 - val _ = upd_ipos cI 1 ip'
3.723 - in iteratorOK2xml cI ip' end)
3.724 - handle PTREE e => iteratorERROR2xml cI)
3.725 - handle _ => sysERROR2xml cI "error in kernel";
3.726 -fun moveCalcHead cI (p:pos') =
3.727 - ((let val ((pt,_),_) = get_calc cI
3.728 - val ip' = movecalchd_up pt p
3.729 - in iteratorOK2xml cI ip' end)
3.730 - handle PTREE e => iteratorERROR2xml cI)
3.731 - handle _ => sysERROR2xml cI "error in kernel";
3.732 -
3.733 -
3.734 -(*.initContext Thy_ is conceptually impossible at [Pbl,Met]
3.735 - and at positions with Check_Postcond and End_Trans;
3.736 - at possible pos's there can be NO rewrite (returned as a context, too).*)
3.737 -(* val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1], Frm));
3.738 - val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([], Res));
3.739 - val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([2], Res));
3.740 - val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1,1], Frm));
3.741 - *)
3.742 -fun initContext (cI:calcID) Thy_ (pos as (p,p_):pos') =
3.743 - ((if member op = [Pbl,Met] p_
3.744 - then message2xml cI "thy-context not to calchead"
3.745 - else if pos = ([],Res) then message2xml cI "no thy-context at result"
3.746 - else let val cs as (ptp as (pt,_),_) = get_calc cI
3.747 - in if exist_lev_on' pt pos
3.748 - then let val pos' = lev_on' pt pos
3.749 - val tac = get_tac_checked pt pos'
3.750 - in if is_rewtac tac
3.751 - then contextthyOK2xml cI (context_thy (pt,pos) tac)
3.752 - else message2xml cI ("no thy-context at tac '" ^
3.753 - tac2str tac ^ "'")
3.754 - end
3.755 - else if is_curr_endof_calc pt pos
3.756 - then case step pos cs of
3.757 -(* val (str, (tacis, _, (pt,_))) = step pos cs;
3.758 - val ("ok", (tacis, _, (pt,_))) = step pos cs;
3.759 - *)
3.760 - ("ok", (tacis, _, (pt,_))) =>
3.761 - let val tac = fst3 (last_elem tacis)
3.762 - in if is_rewtac tac
3.763 - then contextthyOK2xml
3.764 - cI (context_thy ptp tac)
3.765 - else message2xml cI ("no thy-context at tac '" ^
3.766 - tac2str tac ^ "'")
3.767 - end
3.768 - | (msg, _) => message2xml cI msg
3.769 - else message2xml cI "no thy-context at this position"
3.770 - end)
3.771 - handle _ => sysERROR2xml cI "error in kernel")
3.772 -
3.773 -(* val (cI, Pbl_, pos as (p,p_)) = (1, Pbl_, ([],Pbl));
3.774 - *)
3.775 - | initContext cI Pbl_ (pos as (p,p_):pos') =
3.776 - ((let val ((pt,_),_) = get_calc cI
3.777 - val pp = par_pblobj pt p
3.778 - val chd = initcontext_pbl pt (pp,p_)
3.779 - in matchpbl2xml cI chd end)
3.780 - handle _ => sysERROR2xml cI "error in kernel")
3.781 -
3.782 - | initContext cI Met_ (pos as (p,p_):pos') =
3.783 - ((let val ((pt,_),_) = get_calc cI
3.784 - val pp = par_pblobj pt p
3.785 - val chd = initcontext_met pt (pp,p_)
3.786 - in matchmet2xml cI chd end)
3.787 - handle _ => sysERROR2xml cI "error in kernel");
3.788 -
3.789 -
3.790 -
3.791 -(*.match a theorem, a ruleset (etc., selected in the knowledge-browser)
3.792 -with the formula in the focus on the worksheet;
3.793 -string contains the thy, thus it is unique as thmID, rlsID for this thy;
3.794 -take the substitution from the istate of the formula.*)
3.795 -(* use"../smltest/IsacKnowledge/poly.sml";
3.796 - val (cI, pos as (p,p_), guh) = (1, ([1,1,1], Frm),
3.797 - "thy_Poly-thm-real_diff_minus");
3.798 - val (cI, pos as (p,p_), guh) = (1, ([1,1], Frm), "norm_Poly");
3.799 - val (cI, pos as (p,p_), guh) =
3.800 - (1, ([1], Res), "thy_isac_Test-rls-Test_simplify");
3.801 - *)
3.802 -fun checkContext (cI:calcID) (pos:pos' as (p,p_)) (guh:guh) =
3.803 - (case (implode o (take_fromto 1 4) o explode) guh of
3.804 - "thy_" =>
3.805 - if member op = [Pbl,Met] p_
3.806 - then message2xml cI "thy-context not to calchead"
3.807 - else if pos = ([],Res) then message2xml cI "no thy-context at result"
3.808 - else if no_thycontext guh then message2xml cI ("no thy-context for '"^
3.809 - guh ^ "'")
3.810 - else let val (ptp as (pt,_),_) = get_calc cI
3.811 - val is = get_istate pt pos
3.812 - val subs = subs_from is "dummy" guh
3.813 - val tac = guh2rewtac guh subs
3.814 - in contextthyOK2xml cI (context_thy (pt, pos) tac) end
3.815 -
3.816 - (*.match the model of a problem at pos p
3.817 - with the model-pattern of the problem with pblID.*)
3.818 -(* val (cI, pos:pos' as (p,p_), guh) =
3.819 - (1, p, kestoreID2guh Pbl_ ["univariate","equation"]);
3.820 - val (cI, pos:pos' as (p,p_), guh) =
3.821 - (1, ([],Pbl), kestoreID2guh Pbl_ ["univariate","equation"]);
3.822 - val (cI, pos:pos' as (p,p_), guh) =
3.823 - (1, ([],Pbl), "pbl_equ_univ");
3.824 - *)
3.825 - | "pbl_" =>
3.826 - let val ((pt,_),_) = get_calc cI
3.827 - val pp = par_pblobj pt p
3.828 - val keID = guh2kestoreID guh
3.829 - val chd = context_pbl keID pt pp
3.830 - in matchpbl2xml cI chd end
3.831 -(* val (cI, pos:pos' as (p,p_), guh) =
3.832 - (1, ([],Pbl), kestoreID2guh Met_ ["LinEq", "solve_lineq_equation"]);
3.833 - *)
3.834 - | "met_" =>
3.835 - let val ((pt,_),_) = get_calc cI
3.836 - val pp = par_pblobj pt p
3.837 - val keID = guh2kestoreID guh
3.838 - val chd = context_met keID pt pp
3.839 - in matchmet2xml cI chd end)
3.840 - handle _ => sysERROR2xml cI "error in kernel";
3.841 -
3.842 -
3.843 -(*------------------------------------------------------------------*)
3.844 -end
3.845 -open interface;
3.846 -(*------------------------------------------------------------------*)
4.1 --- a/src/Tools/isac/FE-interface/messages.sml Wed Aug 25 15:15:01 2010 +0200
4.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
4.3 @@ -1,43 +0,0 @@
4.4 -(* all messages are encoded to integers for the multi-language system
4.5 - use"FE-interface/messages.sml";
4.6 - use"messages.sml";
4.7 - *)
4.8 -
4.9 -datatype language = English | German | Japanese;
4.10 -fun language2str English = "English"
4.11 - | language2str German = "German"
4.12 - | language2str Japanese = "Japanese";
4.13 -
4.14 -val language = English;
4.15 -
4.16 -(*1000 system*)
4.17 -fun msg2str 1000 English =
4.18 - "msg 1000 English"
4.19 - | msg2str 1000 German =
4.20 - "msg 1000 German"
4.21 -
4.22 -(*2000 user in model- and specify-phase*)
4.23 - | msg2str 2020 English =
4.24 - "Kernel cannot propose a tactic (helpless!)"
4.25 -
4.26 -
4.27 -(*3000 user in solve-phase*)
4.28 -
4.29 -(*4000 general*)
4.30 -
4.31 -(*5000 general*)
4.32 -
4.33 -(*6000 general*)
4.34 -
4.35 -(*7000 general*)
4.36 -
4.37 -(*1000 general*)
4.38 -
4.39 -(*1000 general*)
4.40 -
4.41 -(*1000 general*)
4.42 -
4.43 -(*1000 general*)
4.44 -
4.45 - | msg2str i l = raise error ("no message for No. "^
4.46 - string_of_int i^" "^language2str l);
5.1 --- a/src/Tools/isac/FE-interface/states.sml Wed Aug 25 15:15:01 2010 +0200
5.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
5.3 @@ -1,487 +0,0 @@
5.4 -(* states for calculation in global refs
5.5 - use"../states.sml";
5.6 - use"states.sml";
5.7 - *)
5.8 -
5.9 -(*
5.10 -type hide = (pblID *
5.11 - string list * (*hide: tacs +
5.12 - "ALL", .. result immediately
5.13 - "MODELPBL", .. modeling hidden
5.14 - "SPEC", .. specifying hidden
5.15 - "MODELMET", .. (additional itms !)
5.16 - "APPLY", .. solving hidden
5.17 - detail: rls
5.18 - "Rewrite_*" (as strings) must _not_ be ..
5.19 - .. contained in this list, rls _only_ !*)
5.20 - bool) (*inherit to children in pbl-herarchy*)
5.21 - list;
5.22 -
5.23 -(*. points a pbl/metID to a sub-hierarchy of key ?.*)
5.24 -fun is_child_of child key =
5.25 - let fun is_ch [] [] = true (*is child of itself*)
5.26 - | is_ch (c::_) [] = true
5.27 - | is_ch [] (k::_) = false
5.28 - | is_ch (c::cs) (k::ks) =
5.29 - if c = k then is_ch cs ks else false
5.30 - in is_ch (rev child) (rev key) end;
5.31 -(*
5.32 -is_child_of ["root","univar","equation"] ["univar","equation"];
5.33 -val it = true : bool
5.34 -is_child_of ["root","univar","equation"] ["system","equation"];
5.35 -val it = false : bool
5.36 -is_child_of ["equation"] ["system","equation"];
5.37 -val it = false : bool
5.38 -is_child_of ["root","univar","equation"] ["linear","univar","equation"];
5.39 -val it = false : bool
5.40 -*)
5.41 -
5.42 -(*.what tactics have to be hidden (in model/specify these may be several).*)
5.43 -datatype hid =
5.44 - Show (**)
5.45 - | Hundef (**)
5.46 - | Htac (*a tactic has to be hidden*)
5.47 - | Hmodel (*the model of the (sub)problem has to be hidden*)
5.48 - | Hspecify (*the specification of the (sub)problem has to be hidden*)
5.49 - | Happly; (*solving the (sub)problem has to be hidden*)
5.50 -
5.51 -(*. search all pbls if there is some tactic or model/spec/calc to hide .*)
5.52 -fun is_hid pblID arg [] = Show
5.53 - | is_hid pblID arg ((pblID', strs, inherit)::pts) =
5.54 - let fun is_mem arg =
5.55 - if arg mem strs then Htac
5.56 - else if arg mem ["Add_Given","Add_Find","Add_Relation"]
5.57 - andalso "MODEL" mem strs then Hmodel
5.58 - else if arg mem ["Specify_Theory","Specify_Problem",
5.59 - "Specify_Method"]
5.60 - andalso "SPEC" mem strs then Hspecify
5.61 - else if "APPLY" mem strs then Htac
5.62 - else Hundef
5.63 - in if inherit then
5.64 - if is_child_of (pblID:pblID) pblID'
5.65 - then case is_mem arg of Hundef => is_hid pblID arg (pts:hide)
5.66 - | hid => hid
5.67 - else is_hid pblID arg pts
5.68 - else if pblID = pblID'
5.69 - then case is_mem arg of Hundef => is_hid pblID arg (pts:hide)
5.70 - | hid => hid
5.71 - else is_hid pblID arg pts
5.72 - end;
5.73 -(*val hide = [([],["Refine_Tacitly"],true),
5.74 - (["univar","equation"],["Apply_Method","Model_Problem","SPEC"],
5.75 - false)]
5.76 - :hide;
5.77 -is_hid [] "Rewrite" hide;
5.78 -val it = Show
5.79 -is_hid ["any","problem"] "Refine_Tacitly" hide;
5.80 -val it = Htac
5.81 -is_hid ["root","univar","equation"] "Apply_Method" hide;
5.82 -val it = Show
5.83 -is_hid ["univar","equation"] "Apply_Method" hide;
5.84 -val it = Htac
5.85 -is_hid ["univar","equation"] "Specify_Problem" hide;
5.86 -val it = Hspecify
5.87 -*)
5.88 -
5.89 -fun is_hide pblID (tac as (Subproblem (_,pI))) (det:detail) =
5.90 - is_hid pblID "SELF" det
5.91 - | is_hide pblID (tac as (Rewrite (thmID,_))) det =
5.92 - is_hid pblID thmID det
5.93 - | is_hide pblID (tac as (Rewrite_Inst (_,(thmID,_)))) det =
5.94 - is_hid pblID thmID det
5.95 - | is_hide pblID (tac as (Rewrite_Set rls)) det =
5.96 - is_hid pblID rls det
5.97 - | is_hide pblID (tac as (Rewrite_Set_Inst (_,rls))) det =
5.98 - is_hid pblID rls det
5.99 - | is_hide pblID tac det = is_hid pblID (tac2IDstr tac) det;
5.100 -(*val hide = [([],["Refine_Tacitly"],true),
5.101 - (["univar","equation"],["Apply_Method","Model_Problem",
5.102 - "SPEC","SELF"],
5.103 - false)]
5.104 - :hide;
5.105 -is_hide [] (Rewrite ("","")) hide;
5.106 -val it = Show
5.107 -is_hide ["any","problem"] (Refine_Tacitly []) hide;
5.108 -val it = Htac
5.109 -is_hide ["root","univar","equation"] (Apply_Method []) hide;
5.110 -val it = Show
5.111 -is_hide ["univar","equation"] (Apply_Method []) hide;
5.112 -val it = Htac
5.113 -is_hide ["univar","equation"] (Specify_Problem []) hide;
5.114 -val it = Hspecify
5.115 -is_hide ["univar","equation"] (Subproblem (e_domID,["univar","equation"]))hide;
5.116 -val it = Htac
5.117 -is_hide ["equation"] (Subproblem (e_domID,["univar","equation"]))hide;
5.118 -val it = Show
5.119 -*)
5.120 -
5.121 -
5.122 -(*. search all pbls in detail if there is some rls' to be detailed .*)
5.123 -fun is_det pblID arg [] = false
5.124 - | is_det pblID arg ((pblID', rlss, inherit)::pts) =
5.125 - if inherit then
5.126 - if is_child_of (pblID:pblID) pblID'
5.127 - then if arg mem rlss then true
5.128 - else is_det pblID arg (pts:detail)
5.129 - else is_det pblID arg pts
5.130 - else if pblID = pblID'
5.131 - then if arg mem rlss then true
5.132 - else is_det pblID arg (pts:detail)
5.133 - else is_det pblID arg pts;
5.134 -
5.135 -(*fun is_detail pblID (tac as (Subproblem (_,pI))) (det:detail) =
5.136 - is_det pblID "SELF" det*)
5.137 -fun is_detail pblID (tac as (Rewrite_Set rls)) det =
5.138 - is_det pblID rls det
5.139 - | is_detail pblID (tac as (Rewrite_Set_Inst (_,rls))) det =
5.140 - is_det pblID rls det
5.141 - | is_detail _ _ _ = false;
5.142 -----------------------------------------*)
5.143 -
5.144 -type iterID = int;
5.145 -type calcID = int;
5.146 -
5.147 -(*FIXME.WN.9.03: ev. resdesign calcstate + pos for CalcIterator
5.148 -type state =
5.149 - (*pos' * set by the CalcIterator ---> for each user*)
5.150 - calcstate; (*to which ev.included 'preview' tac_s could be applied*)
5.151 -val e_state = (e_pos', e_calcstate):state;
5.152 -val states = ref ([]:(iterID * (calcID * state) list) list);
5.153 -*)
5.154 -
5.155 -val states =
5.156 - ref ([]:(calcID *
5.157 - (calcstate *
5.158 - (iterID * (*1 sets the 'active formula'*)
5.159 - pos' (*for iterator of a user *)
5.160 - ) list)) list);
5.161 -(*
5.162 -states:= [(3,(e_calcstate, [(1,e_pos'),
5.163 - (3,e_pos')])),
5.164 - (4,(e_calcstate, [(1,e_pos'),
5.165 - (2,e_pos')]))];
5.166 -*)
5.167 -
5.168 -(** create new instances of users and ptrees
5.169 - new keys are the lowest possible in the association list **)
5.170 -
5.171 -(* add users *)
5.172 -fun new_key u n = case assoc (u, n) of
5.173 - NONE => n
5.174 -| SOME _ => new_key u (n+1);
5.175 -(*///10.10
5.176 -fun get_calcID (u:(calcID * (calcstate * (iterID * pos') list)) list) =
5.177 - (new_key u 1):calcID;*)
5.178 -(*
5.179 -val new_iterID = get_calcID (!states);
5.180 -val it = 1 : int
5.181 -states:= (!states) @ [(new_iterID, [])];
5.182 -!states;
5.183 -val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[])]
5.184 -*)
5.185 -
5.186 -(*///7.10.03/// add states to a users active states
5.187 -fun get_calcID (uI:iterID) (p:(iterID * (calcID * state) list) list) =
5.188 - case assoc (p, uI) of
5.189 - NONE => raise error ("get_calcID: no iterID " ^
5.190 - (string_of_int uI))
5.191 - | SOME ps => (new_key ps 1):calcID;
5.192 -> get_calcID 1 (!states);
5.193 -val it = 1 : calcID
5.194 -*)
5.195 -(* add users to a calcstate *)
5.196 -fun get_iterID (cI:calcID)
5.197 - (p:(calcID * (calcstate * (iterID * pos') list)) list) =
5.198 - case assoc (p, cI) of
5.199 - NONE => raise error ("get_iterID: no iterID " ^ (string_of_int cI))
5.200 - | SOME (_, us) => (new_key us 1):iterID;
5.201 -(* get_iterID 3 (!states);
5.202 -val it = 2 : iterID*)
5.203 -
5.204 -
5.205 -(** retrieve, update, delete a state by iterID, calcID **)
5.206 -
5.207 -(*//////7.10.
5.208 -fun get_cal (uI:iterID) (pI:calcID) (p:(iterID * (calcID * state) list) list) =
5.209 - (the (assoc2 (p,(uI, pI))))
5.210 - handle _ => raise error ("get_state " ^ (string_of_int uI) ^
5.211 - " " ^ (string_of_int pI) ^ " not existent");
5.212 -> get_cal 3 1 (!states);
5.213 -val it = (((EmptyPtree,(#,#)),[]),([],[])) : state
5.214 -*)
5.215 -
5.216 -(*///7.10.
5.217 -fun get_state (uI:iterID) (pI:calcID) = get_cal uI pI (!states);
5.218 -fun get_calc (uI:iterID) (pI:calcID) = (snd o (get_cal uI pI)) (!states);
5.219 -*)
5.220 -fun get_calc (cI:calcID) =
5.221 - case assoc (!states, cI) of
5.222 - NONE => raise error ("get_calc "^(string_of_int cI)^" not existent")
5.223 - | SOME (c, _) => c;
5.224 -fun get_pos (cI:calcID) (uI:iterID) =
5.225 - case assoc (!states, cI) of
5.226 - NONE => raise error ("get_pos: calc " ^ (string_of_int cI)
5.227 - ^ " not existent")
5.228 - | SOME (_, us) =>
5.229 - (case assoc (us, uI) of
5.230 - NONE => raise error ("get_pos: user " ^ (string_of_int uI)
5.231 - ^ " not existent")
5.232 - | SOME p => p);
5.233 -
5.234 -
5.235 -fun del_assoc ([],_) = []
5.236 - | del_assoc a =
5.237 - let fun del ([], key) ps = ps
5.238 - | del ((keyi, xi) :: pairs, key) ps =
5.239 - if key = keyi then ps @ pairs
5.240 - else del (pairs, key) (ps @ [(keyi, xi)])
5.241 - in del a [] end;
5.242 -(*
5.243 -> val ps = [(1,"1"),(2,"2"),(3,"3"),(4,"4")];
5.244 -> del_assoc (ps,3);
5.245 -val it = [(1,"1"),(2,"2"),(4,"4")] : (int * string) list
5.246 -*)
5.247 -
5.248 -(* delete doesn't report non existing elements *)
5.249 -(*/////7.10.
5.250 -fun del_assoc2 (uI:iterID) (pI:calcID) ps =
5.251 - let val new_ps = del_assoc (the (assoc (ps, uI)), pI)
5.252 - in overwrite (ps, (uI, new_ps)) end;*)
5.253 -(*
5.254 -> states:= del_assoc2 4 41 (!states);
5.255 -> !states;
5.256 -val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#)]),(1,[(#,#)])] : states
5.257 -
5.258 -> del_user 3;
5.259 -> !states;
5.260 -val it = [(4,[(#,#)]),(1,[(#,#)])] : states
5.261 -*)
5.262 -fun del_assoc2 (cI:calcID) (uI:iterID) ps =
5.263 - case assoc (ps, cI) of
5.264 - NONE => ps
5.265 - | SOME (cs, us) =>
5.266 - overwrite (ps, (cI, (cs, del_assoc (us, uI))));
5.267 -(*
5.268 -> del_assoc2 4 1 (!states);
5.269 -val it =
5.270 - [(3, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (3, ([], Und))])),
5.271 - (4, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]*)
5.272 -
5.273 -(*///7.10.
5.274 -fun overwrite2 (ps, (((uI:iterID), (pI:calcID)), p)) =
5.275 - let val new_ps = overwrite (the (assoc (ps, uI)), (pI, p))
5.276 - in (overwrite (ps, (uI, new_ps)))
5.277 - handle _ => raise error ("overwrite2 " ^ (string_of_int uI) ^
5.278 - " " ^ (string_of_int pI) ^ " not existent")
5.279 - end;*)
5.280 -fun overwrite2 (ps, (((cI:calcID), (uI:iterID)), p)) =
5.281 - case assoc (ps, cI) of
5.282 - NONE =>
5.283 - raise error ("overwrite2: calc " ^ (string_of_int uI) ^" not existent")
5.284 - | SOME (cs, us) =>
5.285 - overwrite (ps, (cI ,(cs, overwrite (us, (uI, p)))));
5.286 -
5.287 -fun upd_calc (cI:calcID) cs =
5.288 - case assoc (!states, cI) of
5.289 - NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent")
5.290 - | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us)));
5.291 -(*WN051210 testing before initac: only 1 taci in calcstate so far:
5.292 -fun upd_calc (cI:calcID) (cs as (_, tacis):calcstate) =
5.293 - (if length tacis > 1
5.294 - then raise error ("upd_calc, |tacis|>1: "^tacis2str tacis)
5.295 - else ();
5.296 - case assoc (!states, cI) of
5.297 - NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent")
5.298 - | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us)))
5.299 - );*)
5.300 -
5.301 -
5.302 -(*///7.10.
5.303 -fun upd_tacis (uI:iterID) (pI:calcID) tacis =
5.304 - let val (p, (ptp,_)) = get_state uI pI
5.305 - in states:=
5.306 - overwrite2 ((!states), ((uI, pI), (p, (ptp, tacis)))) end;*)
5.307 -fun upd_tacis (cI:calcID) tacis =
5.308 - case assoc (!states, cI) of
5.309 - NONE =>
5.310 - raise error ("upd_tacis: calctree "^(string_of_int cI)^" not existent")
5.311 - | SOME ((ptp,_), us) =>
5.312 - states:= overwrite (!states, (cI, ((ptp, tacis), us)));
5.313 -(*///7.10.
5.314 -fun upd_ipos (uI:iterID) (pI:calcID) (ip:pos') =
5.315 - let val (_, calc) = get_state uI pI
5.316 - in states:= overwrite2 ((!states), ((uI, pI), (ip, calc))) end;*)
5.317 -fun upd_ipos (cI:calcID) (uI:iterID) (ip:pos') =
5.318 - case assoc (!states, cI) of
5.319 - NONE =>
5.320 - raise error ("upd_ipos: calctree "^(string_of_int cI)^" not existent")
5.321 - | SOME (cs, us) =>
5.322 - states:= overwrite2 (!states, ((cI, uI), ip));
5.323 -
5.324 -
5.325 -(** add and delete calcs **)
5.326 -
5.327 -(*///7.10
5.328 -fun add_pID (uI:iterID) (s:state) (p:(iterID * (calcID * state) list) list) =
5.329 - let val new_ID = get_calcID uI p;
5.330 - val new_states = (the (assoc (p, uI))) @ [(new_ID, s)];
5.331 - in (new_ID, (overwrite (p, (uI, new_states)))) end;*)
5.332 -(*
5.333 -> val (new_calcID, new_states) = add_pID 1 (!states);
5.334 -> states:= new_states;
5.335 -> !states;
5.336 -val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states
5.337 -> val (new_calcID, new_states) = add_pID 3 (!states);
5.338 -> states:= new_states;
5.339 -> !states;
5.340 -val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states
5.341 -> assoc2 (!states, (3, 1));
5.342 -val it = SOME EmptyPtree : ptree option
5.343 -> assoc2 (!states, (3, 2));
5.344 -val it = NONE : ptree option
5.345 -*)
5.346 -(*///7.10
5.347 -fun add_calc (uI:iterID) (s:state) =
5.348 - let val (new_calcID, new_calcs) = add_pID uI s (!states)
5.349 - in states:= new_calcs;
5.350 - new_calcID end; *)
5.351 -fun add_user (cI:calcID) =
5.352 - case assoc (!states, cI) of
5.353 - NONE =>
5.354 - raise error ("add_user: calctree "^(string_of_int cI)^" not existent")
5.355 - | SOME (cs, us) =>
5.356 - let val new_uI = new_key us 1
5.357 - in states:= overwrite2 (!states, ((cI, new_uI), e_pos'));
5.358 - new_uI:iterID end;
5.359 -
5.360 -(*///10.10.
5.361 -fun del_calc (uI:iterID) (pI:calcID) =
5.362 - (states:= del_assoc2 uI pI (!states); pI);*)
5.363 -fun del_user (cI:calcID) (uI:iterID) =
5.364 - (states:= del_assoc2 cI uI (!states); uI);
5.365 -
5.366 -
5.367 -(** add and delete calculations **)
5.368 -(**///7.10 add and delete users **)
5.369 -(*///7.10
5.370 -fun add_user () =
5.371 - let val new_uI = get_calcID (!states)
5.372 - in states:= (!states) @ [(new_uI, [])];
5.373 - new_uI end;*)
5.374 -fun add_calc (cs:calcstate) =
5.375 - let val new_cI = new_key (!states) 1
5.376 - in states:= (!states) @ [(new_cI, (cs, []))];
5.377 - new_cI:calcID end;
5.378 -
5.379 -(* delete doesn't report non existing elements *)
5.380 -(*///7.10
5.381 -fun del_user (uI:userID) =
5.382 - (states:= del_assoc (!states, uI); uI);*)
5.383 -fun del_calc (cI:calcID) =
5.384 - (states:= del_assoc (!states, cI); cI:calcID);
5.385 -
5.386 -(* -------------- test all exported funs --------------
5.387 -///7.10
5.388 -Compiler.Control.Print.printDepth:=8;
5.389 -states:=[];
5.390 -add_user (); add_user (); !states;
5.391 -ML> val it = 1 : userID
5.392 -ML> val it = 2 : userID
5.393 -ML> val it = [(1,[]),(2,[])]
5.394 -
5.395 -val (hide,detail) = ([(["pI"],["tac"],true)]:hide,
5.396 - [(["pI"],["tac"],true)]:detail);
5.397 -add_calc 1 e_state;
5.398 -add_calc 1 (e_calcstate,(hide,detail)); !states;
5.399 -ML> val it = 1 : calcID
5.400 -ML> val it = 2 : calcID
5.401 -ML> val it =
5.402 - [(1,
5.403 - [(1,(((EmptyPtree,(#,#)),[]),([],[]))),
5.404 - (2,(((EmptyPtree,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])]
5.405 -
5.406 -val (pt,(p,p_)) = (EmptyPtree,e_pos');
5.407 -val (pt,_) = cappend_problem pt p Uistate ([],e_spec);
5.408 -upd_calc 1 2 ((pt,(p,p_)),[]); !states;
5.409 -ML> val it =
5.410 - [(1,
5.411 - [(1,(((EmptyPtree,(#,#)),[]),([],[]))),
5.412 - (2,(((Nd #,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])]
5.413 -(* ~~~~~~~~~~~~~~~~~~~~ unchanged !!!*)
5.414 -
5.415 -get_state 1 1; get_state 1 2;
5.416 -ML> val it = (((EmptyPtree,([],Und)),[]),([],[])) : state
5.417 -ML> val it =
5.418 - (((Nd
5.419 - (PblObj
5.420 - {branch=NoBranch,cell=[],env=(#,#,#,#),loc=(#,#),meth=[],
5.421 - model={Find=#,Given=#,Relate=#,Where=#,With=#},origin=(#,#),
5.422 - ostate=Incomplete,probl=[],result=(#,#),spec=(#,#,#)},[]),([],Und)),
5.423 - []),([(["pI"],["tac"],true)],[(["pI"],["tac"],true)])) : state
5.424 -
5.425 -del_calc 2 1 (*non existent - NO msg!*); del_calc 1 2; !states;
5.426 -ML> val it = [(1,[(1,(((EmptyPtree,(#,#)),[]),([],[])))]),(2,[])]
5.427 -
5.428 -del_user 1; !states;
5.429 -ML> val it = [(2,[])]
5.430 -
5.431 -add_user (); add_user (); !states;
5.432 -ML> val it = 1 : userID
5.433 -ML> val it = 3 : userID
5.434 -ML> val it = [(2,[]),(1,[]),(3,[])]
5.435 -*)
5.436 -
5.437 -
5.438 -(* -------------- test all exported funs --------------
5.439 -print_depth 9;
5.440 -states:=[];
5.441 -add_calc e_calcstate; add_calc e_calcstate; !states;
5.442 -|val it = 1 : calcID
5.443 -|val it = 2 : calcID
5.444 -|val it =
5.445 -| [(1, (((EmptyPtree, ([], Und)), []), [])),
5.446 -| (2, (((EmptyPtree, ([], Und)), []), []))]
5.447 -
5.448 -add_user 2; add_user 2; !states;
5.449 -|val it = 1 : userID
5.450 -|val it = 2 : userID
5.451 -|val it =
5.452 -| [(1, (((EmptyPtree, ([], Und)), []), [])),
5.453 -| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))]
5.454 -
5.455 -
5.456 -val cs = ((EmptyPtree, ([111], Und)), []) : calcstate;
5.457 -upd_calc 1 cs; !states;
5.458 -|val it =
5.459 -| [(1, (((EmptyPtree, ([111], Und)), []), [])),
5.460 -| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))]
5.461 -
5.462 -get_calc 1; get_calc 2;
5.463 -|val it = ((EmptyPtree, ([111], Und)), []) : calcstate
5.464 -|val it = ((EmptyPtree, ([], Und)), []) : calcstate
5.465 -
5.466 -del_user 2 3 (*non existent - NO msg!*); del_user 2 1; !states;
5.467 -|val it = 3 : userID
5.468 -|val it = 1 : userID
5.469 -|val it =
5.470 -| [(1, (((EmptyPtree, ([111], Und)), []), [])),
5.471 -| (2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]
5.472 -
5.473 -del_calc 1; !states;
5.474 -|val it = 1 : calcID
5.475 -|val it = [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]
5.476 -
5.477 -add_calc e_calcstate; add_calc e_calcstate; !states;
5.478 -|val it = 1 : calcID
5.479 -|val it = 3 : calcID
5.480 -|val it =
5.481 -| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))])),
5.482 -| (1, (((EmptyPtree, ([], Und)), []), [])),
5.483 -| (3, (((EmptyPtree, ([], Und)), []), []))]
5.484 -
5.485 -add_user 2; !states;
5.486 -|val it =
5.487 -| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und)), (1, ([], Und))])),
5.488 -| (1, (((EmptyPtree, ([], Und)), []), [])),
5.489 -| (3, (((EmptyPtree, ([], Und)), []), []))]
5.490 -*)
5.491 \ No newline at end of file
6.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2 +++ b/src/Tools/isac/Frontend/interface.sml Wed Aug 25 16:20:07 2010 +0200
6.3 @@ -0,0 +1,843 @@
6.4 +(* the interface between the isac-kernel and the java-frontend;
6.5 + the isac-kernel holds calc-trees; stdout in XML-format.
6.6 + authors: Walther Neuper 2002
6.7 + (c) due to copyright terms
6.8 +
6.9 +use"Frontend/interface.sml";
6.10 +use"interface.sml";
6.11 +*)
6.12 +
6.13 +signature INTERFACE =
6.14 + sig
6.15 + val CalcTree : fmz list -> unit
6.16 + val DEconstrCalcTree : calcID -> unit
6.17 + val Iterator : calcID -> unit
6.18 + val IteratorTEST : calcID -> iterID
6.19 + val appendFormula : calcID -> cterm' -> unit
6.20 + val autoCalculate : calcID -> auto -> unit
6.21 + val checkContext : calcID -> pos' -> guh -> unit
6.22 + val fetchApplicableTactics : calcID -> int -> pos' -> unit
6.23 + val fetchProposedTactic : calcID -> unit
6.24 + val applyTactic : calcID -> pos' -> tac -> unit
6.25 + val getAccumulatedAsms : calcID -> pos' -> unit
6.26 + val getActiveFormula : calcID -> unit
6.27 + val getAssumptions : calcID -> pos' -> unit
6.28 + val initContext : calcID -> ketype -> pos' -> unit
6.29 + val getFormulaeFromTo : calcID -> pos' -> pos' -> int -> bool -> unit
6.30 + val getTactic : calcID -> pos' -> unit
6.31 + val interSteps : calcID -> pos' -> unit
6.32 + val modifyCalcHead : calcID -> icalhd -> unit
6.33 + val moveActiveCalcHead : calcID -> unit
6.34 + val moveActiveDown : calcID -> unit
6.35 + val moveActiveDownTEST : calcID -> unit
6.36 + val moveActiveFormula : calcID -> pos' -> unit
6.37 + val moveActiveLevelDown : calcID -> unit
6.38 + val moveActiveLevelUp : calcID -> unit
6.39 + val moveActiveRoot : calcID -> unit
6.40 + val moveActiveRootTEST : calcID -> unit
6.41 + val moveActiveUp : calcID -> unit
6.42 + val moveCalcHead : calcID -> pos' -> unit
6.43 + val moveDown : calcID -> pos' -> unit
6.44 + val moveLevelDown : calcID -> pos' -> unit
6.45 + val moveLevelUp : calcID -> pos' -> unit
6.46 + val moveRoot : calcID -> unit
6.47 + val moveUp : calcID -> pos' -> unit
6.48 + val refFormula : calcID -> pos' -> unit
6.49 + val replaceFormula : calcID -> cterm' -> unit
6.50 + val resetCalcHead : calcID -> unit
6.51 + val modelProblem : calcID -> unit
6.52 + val refineProblem : calcID -> pos' -> guh -> unit
6.53 + val setContext : calcID -> pos' -> guh -> unit
6.54 + val setMethod : calcID -> metID -> unit
6.55 + val setNextTactic : calcID -> tac -> unit
6.56 + val setProblem : calcID -> pblID -> unit
6.57 + val setTheory : calcID -> thyID -> unit
6.58 + end
6.59 +
6.60 +
6.61 +(*------------------------------------------------------------------*)
6.62 +structure interface : INTERFACE =
6.63 +struct
6.64 +(*------------------------------------------------------------------*)
6.65 +
6.66 +(*.encode "Isabelle"-strings as seen by the user to the
6.67 + format accepted by Isabelle.
6.68 + encode "^" ---> "^^^"; see Knowledge/Atools.thy;
6.69 + called for each cterm', icalhd, fmz in this interface;
6.70 + + see "fun decode" in xmlsrc/mathml.sml.*)
6.71 +fun encode (str:cterm') =
6.72 + let fun enc [] = []
6.73 + | enc ("^"::cs) = "^"::"^"::"^"::(enc cs)
6.74 + | enc (c::cs) = c::(enc cs)
6.75 + in (implode o enc o explode) str:cterm' end;
6.76 +fun encode_imodel (imodel:imodel) =
6.77 + let fun enc (Given ifos) = Given (map encode ifos)
6.78 + | enc (Find ifos) = Find (map encode ifos)
6.79 + | enc (Relate ifos) = Relate (map encode ifos)
6.80 + in map enc imodel:imodel end;
6.81 +fun encode_icalhd ((pos', headl, imodel, pos_, spec):icalhd) =
6.82 + (pos', encode headl, encode_imodel imodel, pos_, spec):icalhd;
6.83 +fun encode_fmz ((ifos, spec):fmz) = (map encode ifos, spec):fmz;
6.84 +
6.85 +
6.86 +(***. CalcTree .***)
6.87 +
6.88 +(** add and delete users **)
6.89 +
6.90 +(*.'Iterator 1' must exist with each CalcTree;
6.91 + the only for updating the calc-tree
6.92 + WN.0411: only 'Iterator 1' is stored,
6.93 + all others are just calculated on the fly
6.94 + TODO: adapt Iterator, add_user(= add_iterator!),etc. accordingly .*)
6.95 +fun Iterator (cI:calcID) = (*returned ID unnecessary after WN.0411*)
6.96 + (adduserOK2xml cI (add_user (cI:calcID)))
6.97 + handle _ => sysERROR2xml cI "error in kernel";
6.98 +fun IteratorTEST (cI:calcID) = add_user (cI:calcID);
6.99 +(*fun DEconstructIterator (cI:calcID) (uI:iterID) =
6.100 + deluserOK2xml (del_user cI uI);*)
6.101 +
6.102 +(*.create a calc-tree; for calls from java: thus ^^^ decoded to ^;
6.103 + compare "fun CalcTreeTEST" which does NOT decode.*)
6.104 +fun CalcTree
6.105 + [(fmz, sp):fmz] (*for several variants lateron*) =
6.106 +(* val[(fmz,sp):fmz]=[(["fixedValues [r=Arbfix]","maximum A","valuesFor [a,b]",
6.107 + "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]",
6.108 + "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]",
6.109 + "relations [A=a*b, a/2=r*sin alpha, b/2=r*cos alpha]",
6.110 + "boundVariable a","boundVariable b","boundVariable alpha",
6.111 + "interval {x::real. 0 <= x & x <= 2*r}",
6.112 + "interval {x::real. 0 <= x & x <= 2*r}",
6.113 + "interval {x::real. 0 <= x & x <= pi}",
6.114 + "errorBound (eps=(0::real))"],
6.115 + ("DiffApp.thy", ["maximum_of","function"],
6.116 + ["DiffApp","max_by_calculus"]))];
6.117 +
6.118 + *)
6.119 + (let val cs = nxt_specify_init_calc (encode_fmz (fmz, sp))
6.120 + (*FIXME.WN.8.03: error-handling missing*)
6.121 + val cI = add_calc cs
6.122 + in calctreeOK2xml cI end)
6.123 + handle _ => sysERROR2xml 0 "error in kernel";
6.124 +
6.125 +fun DEconstrCalcTree (cI:calcID) =
6.126 + deconstructcalctreeOK2xml (del_calc cI);
6.127 +
6.128 +
6.129 +fun getActiveFormula (cI:calcID) = iteratorOK2xml cI (get_pos cI 1);
6.130 +
6.131 +fun moveActiveFormula (cI:calcID) (p:pos') =
6.132 + let val ((pt,_),_) = get_calc cI
6.133 + in if existpt' p pt then (upd_ipos cI 1 p; iteratorOK2xml cI p)
6.134 + else sysERROR2xml cI "frontend sends a non-existing pos" end;
6.135 +
6.136 +(*. set the next tactic to be applied: dont't change the calc-tree,
6.137 + but remember the envisaged changes for fun autoCalculate;
6.138 + compare force NextTactic .*)
6.139 +(* val (cI, tac) = (1, Add_Given "equality (x ^^^ 2 + 4 * x + 3 = 0)");
6.140 + val (cI, tac) = (1, Specify_Theory "PolyEq.thy");
6.141 + val (cI, tac) = (1, Specify_Problem ["normalize","polynomial",
6.142 + "univariate","equation"]);
6.143 + val (cI, tac) = (1, Subproblem ("Poly.thy",
6.144 + ["polynomial","univariate","equation"]));
6.145 + val (cI, tac) = (1, Model_Problem["linear","univariate","equation","test"]);
6.146 + val (cI, tac) = (1, Detail_Set "Test_simplify");
6.147 + val (cI, tac) = (1, Apply_Method ["Test", "solve_linear"]);
6.148 + val (cI, tac) = (1, Rewrite_Set "Test_simplify");
6.149 + *)
6.150 +fun setNextTactic (cI:calcID) tac =
6.151 + let val ((pt, _), _) = get_calc cI
6.152 + val ip = get_pos cI 1
6.153 + in case locatetac tac (pt, ip) of
6.154 +(* val ("ok", (tacis, c, (_,p'))) = locatetac tac (pt, ip);
6.155 + *)
6.156 + ("ok", (tacis, _, _)) =>
6.157 + (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "ok")
6.158 + | ("unsafe-ok", (tacis, _, _)) =>
6.159 + (upd_calc cI ((pt, ip), tacis); setnexttactic2xml cI "unsafe-ok")
6.160 + | ("not-applicable",_) => setnexttactic2xml cI "not-applicable"
6.161 + | ("end-of-calculation",_) =>
6.162 + setnexttactic2xml cI "end-of-calculation"
6.163 + | ("failure",_) => sysERROR2xml cI "failure"
6.164 + end;
6.165 +
6.166 +(*. apply a tactic at a position and update the calc-tree if applicable .*)
6.167 +(*WN080226 java-code is missing, errors smltest/Knowledge/polyminus.sml*)
6.168 +(* val (cI, ip, tac) = (1, p, hd appltacs);
6.169 + val (cI, ip, tac) = (1, p, (hd (sel_appl_atomic_tacs pt p)));
6.170 + *)
6.171 +fun applyTactic (cI:calcID) ip tac =
6.172 + let val ((pt, _), _) = get_calc cI
6.173 + val p = get_pos cI 1
6.174 + in case locatetac tac (pt, ip) of
6.175 +(* val ("ok", (tacis, c, (pt',p'))) = locatetac tac (pt, ip);
6.176 + *)
6.177 + ("ok", (_, c, ptp as (_,p'))) =>
6.178 + (upd_calc cI (ptp, []); upd_ipos cI 1 p';
6.179 + autocalculateOK2xml cI p (if null c then p'
6.180 + else last_elem c) p')
6.181 + | ("unsafe-ok", (_, c, ptp as (_,p'))) =>
6.182 + (upd_calc cI (ptp, []); upd_ipos cI 1 p';
6.183 + autocalculateOK2xml cI p (if null c then p'
6.184 + else last_elem c) p')
6.185 + | ("end-of-calculation", (_, c, ptp as (_,p'))) =>
6.186 + (upd_calc cI (ptp, []); upd_ipos cI 1 p';
6.187 + autocalculateOK2xml cI p (if null c then p'
6.188 + else last_elem c) p')
6.189 +
6.190 +
6.191 + | (str,_) => autocalculateERROR2xml cI "failure"
6.192 + end;
6.193 +
6.194 +
6.195 +
6.196 +(* val cI = 1;
6.197 + *)
6.198 +fun fetchProposedTactic (cI:calcID) =
6.199 + (case step (get_pos cI 1) (get_calc cI) of
6.200 + ("ok", (tacis, _, _)) =>
6.201 + let val _= upd_tacis cI tacis
6.202 + val (tac,_,_) = last_elem tacis
6.203 + in fetchproposedtacticOK2xml cI tac end
6.204 + | ("helpless",_) => fetchproposedtacticERROR2xml cI "helpless"
6.205 + | ("no-fmz-spec",_) => fetchproposedtacticERROR2xml cI "no-fmz-spec"
6.206 + | ("end-of-calculation",_) =>
6.207 + fetchproposedtacticERROR2xml cI "end-of-calculation")
6.208 + handle _ => sysERROR2xml cI "error in kernel";
6.209 +
6.210 +(*datatype auto = FIXXXME040624: does NOT match interfaces/ITOCalc.java
6.211 + Step of int (*1 do #int steps (may stop in model/specify)
6.212 + IS VERY INEFFICIENT IN MODEL/SPECIY*)
6.213 +| CompleteModel (*2 complete modeling
6.214 + if model complete, finish specifying*)
6.215 +| CompleteCalcHead (*3 complete model/specify in one go*)
6.216 +| CompleteToSubpbl (*4 stop at the next begin of a subproblem,
6.217 + if none, complete the actual (sub)problem*)
6.218 +| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*)
6.219 +| CompleteCalc; (*6 complete the calculation as a whole*)*)
6.220 +fun autoCalculate (cI:calcID) auto =
6.221 +(* val (cI, auto) = (1,CompleteCalc);
6.222 + val (cI, auto) = (1,CompleteModel);
6.223 + val (cI, auto) = (1,CompleteCalcHead);
6.224 + val (cI, auto) = (1,Step 1);
6.225 + *)
6.226 + (let val pold = get_pos cI 1
6.227 + val x = autocalc [] pold (get_calc cI) auto
6.228 + in
6.229 + case x of
6.230 +(* val (str, c, ptp as (_,p)) = x;
6.231 + *)
6.232 + ("ok", c, ptp as (_,p)) =>
6.233 + (upd_calc cI (ptp, []); upd_ipos cI 1 p;
6.234 + autocalculateOK2xml cI pold (if null c then pold
6.235 + else last_elem c) p)
6.236 + | ("end-of-calculation", c, ptp as (_,p)) =>
6.237 + (upd_calc cI (ptp, []); upd_ipos cI 1 p;
6.238 + autocalculateOK2xml cI pold (if null c then pold
6.239 + else last_elem c) p)
6.240 + | (str, _, _) => autocalculateERROR2xml cI str
6.241 + end)
6.242 + handle _ => sysERROR2xml cI "error in kernel";
6.243 +
6.244 +
6.245 +(* val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) =
6.246 + (1, (([],Pbl), "not used here",
6.247 + [Given ["fixedValues [r=Arbfix]"],
6.248 + Find ["maximum A", "valuesFor [a,b]"(*new input*)],
6.249 + Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl,
6.250 + ("DiffApp.thy", ["maximum_of","function"],
6.251 + ["DiffApp","max_by_calculus"])));
6.252 + val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) =
6.253 + (1, (([],Pbl),"solve (x+1=2, x)",
6.254 + [Given ["equality (x+1=2)", "solveFor x"],
6.255 + Find ["solutions L"]],
6.256 + Pbl,
6.257 + ("Test.thy", ["linear","univariate","equation","test"],
6.258 + ["Test","solve_linear"])));
6.259 + val (cI:calcID, ichd as ((p,_),_,_,_,_):icalhd) =
6.260 + (1, (([],Pbl),"solveTest (1+-1*2+x=0,x)", [], Pbl, ("", [], [])));
6.261 + val (cI, p:pos')=(1, ([1],Frm));
6.262 + val (cI, p:pos')=(1, ([1,2,1,3],Res));
6.263 + *)
6.264 +fun getTactic cI (p:pos') =
6.265 + (let val ((pt,_),_) = get_calc cI
6.266 + val (form, tac, asms) = pt_extract (pt, p)
6.267 + in case tac of
6.268 +(* val SOME ta = tac;
6.269 + *)
6.270 + SOME ta => gettacticOK2xml cI ta
6.271 + | NONE => gettacticERROR2xml cI ("no tactic at position "^pos'2str p)
6.272 + end)
6.273 + handle _ => sysERROR2xml cI "syserror in getTactic";
6.274 +
6.275 +(*. see ICalcIterator#fetchApplicableTactics
6.276 + @see #TACTICS_ALL
6.277 + @see #TACTICS_CURRENT_THEORY
6.278 + @see #TACTICS_CURRENT_METHOD ..the only impl.WN040307.*)
6.279 +(*. fetch tactics to be applied to a particular step.*)
6.280 +(* WN071231 kept this version for later parametrisation*)
6.281 +(*.version 1: fetch _all_ tactics from script .*)
6.282 +fun fetchApplicableTactics cI (scope:int) (p:pos') =
6.283 + (let val ((pt, _), _) = get_calc cI
6.284 + in (applicabletacticsOK cI (sel_rules pt p))
6.285 + handle PTREE str => sysERROR2xml cI str
6.286 + end)
6.287 + handle _ => sysERROR2xml cI "error in kernel";
6.288 +(*.version 2: fetch _applicable_ _elementary_ (ie. recursively
6.289 + decompose rule-sets) Rewrite*, Calculate .*)
6.290 +fun fetchApplicableTactics cI (scope:int) (p:pos') =
6.291 + (let val ((pt, _), _) = get_calc cI
6.292 + in (applicabletacticsOK cI (sel_appl_atomic_tacs pt p))
6.293 + handle PTREE str => sysERROR2xml cI str
6.294 + end)
6.295 + handle _ => sysERROR2xml cI "error in kernel";
6.296 +
6.297 +fun getAssumptions cI (p:pos') =
6.298 + (let val ((pt,_),_) = get_calc cI
6.299 + val (_, _, asms) = pt_extract (pt, p)
6.300 + in getasmsOK2xml cI asms end)
6.301 + handle _ => sysERROR2xml cI "syserror in getAssumptions";
6.302 +
6.303 +(*WN0502 @see ME/ctree: type asms: illdesigned, thus no positions returned*)
6.304 +fun getAccumulatedAsms cI (p:pos') =
6.305 + (let val ((pt, _), _) = get_calc cI
6.306 + val ass = map fst (get_assumptions_ pt p)
6.307 + in (*getaccuasmsOK2xml cI (get_assumptions_ pt p)*)
6.308 + getasmsOK2xml cI ass end)
6.309 + handle _ => sysERROR2xml cI "syserror in getAccumulatedAsms";
6.310 +
6.311 +
6.312 +(*since moveActive* does NOT transfer pos java --> sml (only sml --> java)
6.313 + refFormula might become involved in far-off errors !!!*)
6.314 +fun refFormula cI (p:pos') = (*WN0501 rename to 'fun getElement' !*)
6.315 +(* val (cI, uI) = (1,1);
6.316 + *)
6.317 + (let val ((pt,_),_) = get_calc cI
6.318 + val (form, tac, asms) = pt_extract (pt, p)
6.319 + in refformulaOK2xml cI p form end)
6.320 + handle _ => sysERROR2xml cI "error in kernel";
6.321 +
6.322 +(*.get formulae 'from' 'to' w.r.t. ordering in Position#compareTo(Position p);
6.323 + in case of CalcHeads only the headline is taken
6.324 + (the pos' allows distinction between PrfObj and PblObj anyway);
6.325 + 'level' is adjusted such that an 'interval' of formulae is returned;
6.326 + 'from' 'to' are designed for use by iterators of calcChangedEvent;
6.327 + thus 'from' is the last unchanged position.*)
6.328 +fun getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Pbl):pos')_ false =
6.329 +(*special case because 'from' is _before_ the first elements to be returned*)
6.330 +(* val (cI, from, to, level) = (1, ([],Pbl), ([],Pbl), 1);
6.331 + *)
6.332 + ((let val ((pt,_),_) = get_calc cI
6.333 + val (ModSpec (_,_,headline,_,_,_),_,_) = pt_extract (pt, to)
6.334 + in getintervalOK cI [(to, headline)] end)
6.335 + handle _ => sysERROR2xml cI "error in kernel")
6.336 +
6.337 + | getFormulaeFromTo cI (from as ([],Pbl):pos') (to as ([],Met):pos')_ false =
6.338 + getFormulaeFromTo cI ([],Pbl) ([],Pbl) (~00000) false
6.339 +
6.340 + | getFormulaeFromTo cI (from:pos') (to:pos') level false =
6.341 +(* val (cI, from, to, level) = (1, unc, gen, 0);
6.342 + val (cI, from, to, level) = (1, unc, gen, 1);
6.343 + val (cI, from, to, level) = (1, ([],Pbl), ([],Met), 1);
6.344 + *)
6.345 + (if from = to then sysERROR2xml cI "getFormulaeFromTo: From = To"
6.346 + else
6.347 + (case from of
6.348 + ([],Res) => sysERROR2xml cI "getFormulaeFromTo does: moveDown \
6.349 + \from=([],Res) .. goes beyond result"
6.350 + | _ => let val ((pt,_),_) = get_calc cI
6.351 + val f = move_dn [] pt from
6.352 + fun max (a,b) = if a < b then b else a
6.353 + (*must reach margins ...*)
6.354 + val lev = max (level, max (lev_of from, lev_of to))
6.355 + in getintervalOK cI (get_interval f to lev pt) end)
6.356 + handle _ => sysERROR2xml cI "error in getFormulaeFromTo")
6.357 +
6.358 + | getFormulaeFromTo cI from to level true =
6.359 + sysERROR2xml cI "getFormulaeFromTo impl.for formulae only,\
6.360 + \i.e. last arg only impl. for false, _NOT_ true";
6.361 +
6.362 +
6.363 +(* val (cI, ip) = (1, ([1,9], Res));
6.364 + val (cI, ip) = (1, ([], Res));
6.365 + val (cI, ip) = (1, ([2], Res));
6.366 + val (cI, ip) = (1, ([3,1], Res));
6.367 + val (cI, ip) = (1, ([1,2,1], Res));
6.368 + *)
6.369 +fun interSteps cI ip =
6.370 + (let val ((pt,p), tacis) = get_calc cI
6.371 + in if (not o is_interpos) ip
6.372 + then interStepsERROR cI "only formulae with position (_,Res) \
6.373 + \may have intermediate steps above them"
6.374 + else let val ip' = lev_pred' pt ip
6.375 +(* val (str, pt', lastpos) = detailstep pt ip;
6.376 + *)
6.377 + in case detailstep pt ip of
6.378 + ("detailrls", pt(*, pos'forms*), lastpos) =>
6.379 + (upd_calc cI ((pt, p), tacis);
6.380 + interStepsOK cI (*pos'forms*) ip' ip' lastpos)
6.381 + | ("no-Rewrite_Set...", _, _) =>
6.382 + sysERROR2xml cI "no Rewrite_Set..."
6.383 + | (_, _(*, pos'formshds*), lastpos) =>
6.384 + interStepsOK cI (*pos'formshds*) ip' ip' lastpos
6.385 + end
6.386 + end)
6.387 + handle _ => sysERROR2xml cI "error in kernel";
6.388 +
6.389 +fun modifyCalcHead (cI:calcID) (ichd as ((p,_),_,_,_,_):icalhd) =
6.390 + (let val ((pt,_),_) = get_calc cI
6.391 + val (pt, chd as (_,p_,_,_,_,_)) = input_icalhd pt ichd
6.392 + in (upd_calc cI ((pt, (p,p_)), []);
6.393 + modifycalcheadOK2xml cI chd) end)
6.394 + handle _ => sysERROR2xml cI "error in kernel";
6.395 +
6.396 +(*.at the activeFormula set the Model, the Guard and the Specification
6.397 + to empty and return a CalcHead;
6.398 + the 'origin' remains (for reconstructing all that).*)
6.399 +fun resetCalcHead (cI:calcID) =
6.400 + (let val (ptp,_) = get_calc cI
6.401 + val ptp = reset_calchead ptp
6.402 + in (upd_calc cI (ptp, []);
6.403 + modifycalcheadOK2xml cI (get_ocalhd ptp)) end)
6.404 + handle _ => sysERROR2xml cI "error in kernel";
6.405 +
6.406 +(*.at the activeFormula insert all the Descriptions in the Model
6.407 + (_not_ in the Guard) and return a CalcHead;
6.408 + the Descriptions are for user-guidance; the rest of the items
6.409 + are left empty for user-input;
6.410 + includes a resetCalcHead for the Model and the Guard.*)
6.411 +fun modelProblem (cI:calcID) =
6.412 + (let val (ptp, _) = get_calc cI
6.413 + val ptp = reset_calchead ptp
6.414 + val (_, _, ptp) = nxt_specif Model_Problem ptp
6.415 + in (upd_calc cI (ptp, []);
6.416 + modifycalcheadOK2xml cI (get_ocalhd ptp)) end)
6.417 + handle _ => sysERROR2xml cI "error in kernel";
6.418 +
6.419 +
6.420 +(*.set the context determined on a knowledgebrowser to the current calc.*)
6.421 +fun setContext (cI:calcID) (ip as (_,p_):pos') (guh:guh) =
6.422 + (case (implode o (take_fromto 1 4) o explode) guh of
6.423 + "thy_" =>
6.424 +(* val (cI, ip as (_,p_), guh) = (1, p, "thy_isac_Test-rls-Test_simplify");
6.425 + *)
6.426 + if member op = [Pbl,Met] p_
6.427 + then message2xml cI "thy-context not to calchead"
6.428 + else if ip = ([],Res) then message2xml cI "no thy-context at result"
6.429 + else if no_thycontext guh then message2xml cI ("no thy-context for '"^
6.430 + guh ^ "'")
6.431 + else let val (ptp as (pt,pold),_) = get_calc cI
6.432 + val is = get_istate pt ip
6.433 + val subs = subs_from is "dummy" guh
6.434 + val tac = guh2rewtac guh subs
6.435 + in case locatetac tac (pt, ip) of (*='fun setNextTactic'+step*)
6.436 + ("ok", (tacis, c, ptp as (_,p))) =>
6.437 +(* val (str, (tacis, c, ptp as (_,p))) = locatetac tac (pt, ip);
6.438 + *)
6.439 + (upd_calc cI ((pt,p), []);
6.440 + autocalculateOK2xml cI pold (if null c then pold
6.441 + else last_elem c) p)
6.442 + | ("unsafe-ok", (tacis, c, ptp as (_,p))) =>
6.443 + (upd_calc cI ((pt,p), []);
6.444 + autocalculateOK2xml cI pold (if null c then pold
6.445 + else last_elem c) p)
6.446 + | ("end-of-calculation",_) =>
6.447 + message2xml cI "end-of-calculation"
6.448 + | ("failure",_) => sysERROR2xml cI "failure"
6.449 + | ("not-applicable",_) => (*the rule comes from anywhere..*)
6.450 + (case applicable_in ip pt tac of
6.451 +
6.452 + Notappl e => message2xml cI ("'" ^ tac2str tac ^
6.453 + "' not-applicable")
6.454 + | Appl m =>
6.455 + let val (p,c,_,pt) = generate1 (assoc_thy"Isac.thy")
6.456 + m Uistate ip pt
6.457 + in upd_calc cI ((pt,p),[]);
6.458 + autocalculateOK2xml cI pold (if null c then pold
6.459 + else last_elem c) p
6.460 + end)
6.461 + end
6.462 +(* val (cI, ip as (_,p_), guh) = (1, pos, guh);
6.463 + *)
6.464 + | "pbl_" =>
6.465 + let val pI = guh2kestoreID guh
6.466 + val ((pt, _), _) = get_calc cI
6.467 + (*val ip as (_, p_) = get_pos cI 1*)
6.468 + in if member op = [Pbl, Met] p_
6.469 + then let val (pt, chd) = set_problem pI (pt, ip)
6.470 + in (upd_calc cI ((pt, ip), []);
6.471 + modifycalcheadOK2xml cI chd) end
6.472 + else sysERROR2xml cI "setContext for pbl requires ActiveFormula \
6.473 + \on CalcHead"
6.474 + end
6.475 +(* val (cI, ip as (_,p_), guh) = (1, pos, "met_eq_lin");
6.476 + *)
6.477 + | "met_" =>
6.478 + let val mI = guh2kestoreID guh
6.479 + val ((pt, _), _) = get_calc cI
6.480 + in if member op = [Pbl, Met] p_
6.481 + then let val (pt, chd) = set_method mI (pt, ip)
6.482 + in (upd_calc cI ((pt, ip), []);
6.483 + modifycalcheadOK2xml cI chd) end
6.484 + else sysERROR2xml cI "setContext for met requires ActiveFormula \
6.485 + \on CalcHead"
6.486 + end)
6.487 + handle _ => sysERROR2xml cI "error in kernel";
6.488 +
6.489 +
6.490 +(*.specify the Method at the activeFormula and return a CalcHead
6.491 + containing the Guard.
6.492 + WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*)
6.493 +fun setMethod (cI:calcID) (mI:metID) =
6.494 +(* val (cI, mI) = (1, ["Test","solve_linear"]);
6.495 + *)
6.496 + (let val ((pt, _), _) = get_calc cI
6.497 + val ip as (_, p_) = get_pos cI 1
6.498 + in if member op = [Pbl,Met] p_
6.499 + then let val (pt, chd) = set_method mI (pt, ip)
6.500 + in (upd_calc cI ((pt, ip), []);
6.501 + modifycalcheadOK2xml cI chd) end
6.502 + else sysERROR2xml cI "setMethod requires ActiveFormula on CalcHead"
6.503 + end)
6.504 + handle _ => sysERROR2xml cI "error in kernel";
6.505 +
6.506 +(*.specify the Problem at the activeFormula and return a CalcHead
6.507 + containing the Model; special case of checkContext;
6.508 + WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem '.*)
6.509 +fun setProblem (cI:calcID) (pI:pblID) =
6.510 + (let val ((pt, _), _) = get_calc cI
6.511 + val ip as (_, p_) = get_pos cI 1
6.512 + in if member op = [Pbl,Met] p_
6.513 + then let val (pt, chd) = set_problem pI (pt, ip)
6.514 + in (upd_calc cI ((pt, ip), []);
6.515 + modifycalcheadOK2xml cI chd) end
6.516 + else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead"
6.517 + end)
6.518 + handle _ => sysERROR2xml cI "error in kernel";
6.519 +
6.520 +(*.specify the Theory at the activeFormula and return a CalcHead;
6.521 + special case of checkContext;
6.522 + WN0512 impl.incomplete, see 'nxt_specif (Specify_Method '.*)
6.523 +fun setTheory (cI:calcID) (tI:thyID) =
6.524 + (let val ((pt, _), _) = get_calc cI
6.525 + val ip as (_, p_) = get_pos cI 1
6.526 + in if member op = [Pbl,Met] p_
6.527 + then let val (pt, chd) = set_theory tI (pt, ip)
6.528 + in (upd_calc cI ((pt, ip), []);
6.529 + modifycalcheadOK2xml cI chd) end
6.530 + else sysERROR2xml cI "setProblem requires ActiveFormula on CalcHead"
6.531 + end)
6.532 + handle _ => sysERROR2xml cI "error in kernel";
6.533 +
6.534 +
6.535 +(**. without update of CalcTree .**)
6.536 +
6.537 +(*.match the model of a problem at pos p
6.538 + with the model-pattern of the problem with pblID*)
6.539 +(*fun tryMatchProblem cI pblID =
6.540 + (let val ((pt,_),_) = get_calc cI
6.541 + val p = get_pos cI 1
6.542 + val chd = trymatch pblID pt p
6.543 + in trymatchOK2xml cI chd end)
6.544 + handle _ => sysERROR2xml cI "error in kernel";*)
6.545 +
6.546 +(*.refinement for the parent-problem of the position.*)
6.547 +(* val (cI, (p,p_), guh) = (1, ([1],Res), "pbl_equ_univ");
6.548 + *)
6.549 +fun refineProblem cI ((p,p_) : pos') (guh : guh) =
6.550 + (let val pblID = guh2kestoreID guh
6.551 + val ((pt,_),_) = get_calc cI
6.552 + val pp = par_pblobj pt p
6.553 + val chd = tryrefine pblID pt (pp, p_)
6.554 + in matchpbl2xml cI chd end)
6.555 + handle _ => sysERROR2xml cI "error in kernel";
6.556 +
6.557 +(* val (cI, ifo) = (1, "-2 * 1 + (1 + x) = 0");
6.558 + val (cI, ifo) = (1, "x = 2");
6.559 + val (cI, ifo) = (1, "[x = 3 + -2*1]");
6.560 + val (cI, ifo) = (1, "-1 + x = 0");
6.561 + val (cI, ifo) = (1, "x - 4711 = 0");
6.562 + val (cI, ifo) = (1, "2+ -1 + x = 2");
6.563 + val (cI, ifo) = (1, " x - ");
6.564 + val (cI, ifo) = (1, "(-3 * x + 4 * y + -1 * x * y) / (x * y)");
6.565 + val (cI, ifo) = (1, "(4 * y + -3 * x) / (x * y) + -1");
6.566 + *)
6.567 +fun appendFormula cI (ifo:cterm') =
6.568 + (let val cs = get_calc cI
6.569 + val pos as (_,p_) = get_pos cI 1
6.570 + in case step pos cs of
6.571 +(* val (str, cs') = step pos cs;
6.572 + *)
6.573 + ("ok", cs') =>
6.574 + (case inform cs' (encode ifo) of
6.575 +(* val (str, (_, c, ptp as (_,p))) = inform cs' (encode ifo);
6.576 + *)
6.577 + ("ok", (_(*use in DG !!!*), c, ptp as (_,p))) =>
6.578 + (upd_calc cI (ptp, []); upd_ipos cI 1 p;
6.579 + appendformulaOK2xml cI pos (if null c then pos
6.580 + else last_elem c) p)
6.581 + | ("same-formula", (_, c, ptp as (_,p))) =>
6.582 + (upd_calc cI (ptp, []); upd_ipos cI 1 p;
6.583 + appendformulaOK2xml cI pos (if null c then pos
6.584 + else last_elem c) p)
6.585 + | (msg, _) => appendformulaERROR2xml cI msg)
6.586 + | (msg, cs') => appendformulaERROR2xml cI msg
6.587 + end)
6.588 + handle _ => sysERROR2xml cI "error in kernel";
6.589 +
6.590 +
6.591 +
6.592 +(*.replace a formula with_in_ a calculation;
6.593 + this situation applies for initial CAS-commands, too.*)
6.594 +(* val (cI, ifo) = (2, "-1 + x = 0");
6.595 + val (cI, ifo) = (1, "-1 + x = 0");
6.596 + val (cI, ifo) = (1, "x - 1 = 0");
6.597 + val (cI, ifo) = (1, "x = 1");
6.598 + val (cI, ifo) = (1, "solve(x+1=2,x)");
6.599 + val (cI, ifo) = (1, "Simplify (2*a + 3*a)");
6.600 + val (cI, ifo) = (1, "Diff (x^2 + x + 1, x)");
6.601 + *)
6.602 +fun replaceFormula cI (ifo:cterm') =
6.603 + (let val ((pt, _), _) = get_calc cI
6.604 + val p = get_pos cI 1
6.605 + in case inform (([], [], (pt, p)): calcstate') (encode ifo) of
6.606 + ("ok", (_(*tacs used for DG ?*), c, ptp' as (pt',p'))) =>
6.607 +(* val (str, (_,c, ptp' as (pt',p')))= inform ([], [], (pt, p)) (encode ifo);
6.608 + *)
6.609 + let val unc = if null (fst p) then p else move_up [] pt p
6.610 + val _ = upd_calc cI (ptp', [])
6.611 + val _ = upd_ipos cI 1 p'
6.612 + in replaceformulaOK2xml cI unc
6.613 + (if null c then unc
6.614 + else last_elem c) p'(*' NEW*) end
6.615 + | ("same-formula", _) =>
6.616 + (*TODO.WN0501 MESSAGE !*)
6.617 + replaceformulaERROR2xml cI "formula not changed"
6.618 + | (msg, _) => replaceformulaERROR2xml cI msg
6.619 + end)
6.620 + handle _ => sysERROR2xml cI "error in kernel";
6.621 +
6.622 +
6.623 +
6.624 +(***. CalcIterator
6.625 + moveActive*: set the pos' of the active formula stored with the calctree
6.626 + could take pos' as argument for consistency checks
6.627 + move*: compute the new iterator from the old one on the fly
6.628 +
6.629 +.***)
6.630 +
6.631 +fun moveActiveRoot cI =
6.632 + (let val _ = upd_ipos cI 1 ([],Pbl)
6.633 + in iteratorOK2xml cI ([],Pbl) end)
6.634 + handle e => sysERROR2xml cI "error in kernel";
6.635 +fun moveRoot cI =
6.636 + (iteratorOK2xml cI ([],Pbl))
6.637 + handle e => sysERROR2xml cI "";
6.638 +fun moveActiveRootTEST cI =
6.639 + (let val _ = upd_ipos cI 1 ([],Pbl)
6.640 + in (*iteratorOK2xml cI ([],Pbl)*)() end)
6.641 + handle e => sysERROR2xml cI "error in kernel";
6.642 +
6.643 +(* val (cI, uI) = (1,1);
6.644 + val (cI, uI) = (1,2);
6.645 + *)
6.646 +fun moveActiveDown cI =
6.647 + ((let val ((pt,_),_) = get_calc cI
6.648 +(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI);
6.649 + val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI);
6.650 +
6.651 + print_depth 7;pt
6.652 + *)
6.653 + val ip' = move_dn [] pt (get_pos cI 1)
6.654 + val _ = upd_ipos cI 1 ip'
6.655 + in iteratorOK2xml cI ip' end)
6.656 + handle (PTREE e) => iteratorERROR2xml cI)
6.657 + handle _ => sysERROR2xml cI "error in kernel";
6.658 +fun moveDown cI (p:pos') =
6.659 + ((let val ((pt,_),_) = get_calc cI
6.660 +(* val (P, (Nd (_, ns)), (p::(ps as (_::_)), p_)) =([]:pos, pt, get_pos cI uI);
6.661 + val (P, (Nd (c, ns)), ([p], p_)) =([]:pos, pt, get_pos cI uI);
6.662 +
6.663 + print_depth 7;pt
6.664 + *)
6.665 + val ip' = move_dn [] pt p
6.666 + in iteratorOK2xml cI ip' end)
6.667 + handle (PTREE e) => iteratorERROR2xml cI)
6.668 + handle _ => sysERROR2xml cI "error in kernel";
6.669 +fun moveActiveDownTEST cI =
6.670 + let val ((pt,_),_) = get_calc cI
6.671 + val ip = get_pos cI 1
6.672 + val ip' = (move_dn [] pt ip)
6.673 + handle _ => ip
6.674 + val _ = upd_ipos cI 1 ip'
6.675 + in (*iteratorOK2xml cI uI*)() end;
6.676 +
6.677 +fun moveActiveLevelDown cI =
6.678 + ((let val ((pt,_),_) = get_calc cI
6.679 + val ip' = movelevel_dn [] pt (get_pos cI 1)
6.680 + val _ = upd_ipos cI 1 ip'
6.681 + in iteratorOK2xml cI ip' end)
6.682 + handle (PTREE e) => iteratorERROR2xml cI)
6.683 + handle _ => sysERROR2xml cI "error in kernel";
6.684 +fun moveLevelDown cI (p:pos') =
6.685 + ((let val ((pt,_),_) = get_calc cI
6.686 + val ip' = movelevel_dn [] pt p
6.687 + in iteratorOK2xml cI ip' end)
6.688 + handle (PTREE e) => iteratorERROR2xml cI)
6.689 + handle _ => sysERROR2xml cI "error in kernel";
6.690 +
6.691 +fun moveActiveUp cI =
6.692 + ((let val ((pt,_),_) = get_calc cI
6.693 + val ip' = move_up [] pt (get_pos cI 1)
6.694 + val _ = upd_ipos cI 1 ip'
6.695 + in iteratorOK2xml cI ip' end)
6.696 + handle PTREE e => iteratorERROR2xml cI)
6.697 + handle _ => sysERROR2xml cI "error in kernel";
6.698 +fun moveUp cI (p:pos') =
6.699 + ((let val ((pt,_),_) = get_calc cI
6.700 + val ip' = move_up [] pt p
6.701 + in iteratorOK2xml cI ip' end)
6.702 + handle PTREE e => iteratorERROR2xml cI)
6.703 + handle _ => sysERROR2xml cI "error in kernel";
6.704 +
6.705 +fun moveActiveLevelUp cI =
6.706 + ((let val ((pt,_),_) = get_calc cI
6.707 + val ip' = movelevel_up [] pt (get_pos cI 1)
6.708 + val _ = upd_ipos cI 1 ip'
6.709 + in iteratorOK2xml cI ip' end)
6.710 + handle PTREE e => iteratorERROR2xml cI)
6.711 + handle _ => sysERROR2xml cI "error in kernel";
6.712 +fun moveLevelUp cI (p:pos') =
6.713 + ((let val ((pt,_),_) = get_calc cI
6.714 + val ip' = movelevel_up [] pt p
6.715 + in iteratorOK2xml cI ip' end)
6.716 + handle PTREE e => iteratorERROR2xml cI)
6.717 + handle _ => sysERROR2xml cI "error in kernel";
6.718 +
6.719 +fun moveActiveCalcHead cI =
6.720 + ((let val ((pt,_),_) = get_calc cI
6.721 + val ip' = movecalchd_up pt (get_pos cI 1)
6.722 + val _ = upd_ipos cI 1 ip'
6.723 + in iteratorOK2xml cI ip' end)
6.724 + handle PTREE e => iteratorERROR2xml cI)
6.725 + handle _ => sysERROR2xml cI "error in kernel";
6.726 +fun moveCalcHead cI (p:pos') =
6.727 + ((let val ((pt,_),_) = get_calc cI
6.728 + val ip' = movecalchd_up pt p
6.729 + in iteratorOK2xml cI ip' end)
6.730 + handle PTREE e => iteratorERROR2xml cI)
6.731 + handle _ => sysERROR2xml cI "error in kernel";
6.732 +
6.733 +
6.734 +(*.initContext Thy_ is conceptually impossible at [Pbl,Met]
6.735 + and at positions with Check_Postcond and End_Trans;
6.736 + at possible pos's there can be NO rewrite (returned as a context, too).*)
6.737 +(* val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1], Frm));
6.738 + val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([], Res));
6.739 + val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([2], Res));
6.740 + val (cI, Thy_, (pos as (p,p_):pos')) = (1, Thy_, ([1,1], Frm));
6.741 + *)
6.742 +fun initContext (cI:calcID) Thy_ (pos as (p,p_):pos') =
6.743 + ((if member op = [Pbl,Met] p_
6.744 + then message2xml cI "thy-context not to calchead"
6.745 + else if pos = ([],Res) then message2xml cI "no thy-context at result"
6.746 + else let val cs as (ptp as (pt,_),_) = get_calc cI
6.747 + in if exist_lev_on' pt pos
6.748 + then let val pos' = lev_on' pt pos
6.749 + val tac = get_tac_checked pt pos'
6.750 + in if is_rewtac tac
6.751 + then contextthyOK2xml cI (context_thy (pt,pos) tac)
6.752 + else message2xml cI ("no thy-context at tac '" ^
6.753 + tac2str tac ^ "'")
6.754 + end
6.755 + else if is_curr_endof_calc pt pos
6.756 + then case step pos cs of
6.757 +(* val (str, (tacis, _, (pt,_))) = step pos cs;
6.758 + val ("ok", (tacis, _, (pt,_))) = step pos cs;
6.759 + *)
6.760 + ("ok", (tacis, _, (pt,_))) =>
6.761 + let val tac = fst3 (last_elem tacis)
6.762 + in if is_rewtac tac
6.763 + then contextthyOK2xml
6.764 + cI (context_thy ptp tac)
6.765 + else message2xml cI ("no thy-context at tac '" ^
6.766 + tac2str tac ^ "'")
6.767 + end
6.768 + | (msg, _) => message2xml cI msg
6.769 + else message2xml cI "no thy-context at this position"
6.770 + end)
6.771 + handle _ => sysERROR2xml cI "error in kernel")
6.772 +
6.773 +(* val (cI, Pbl_, pos as (p,p_)) = (1, Pbl_, ([],Pbl));
6.774 + *)
6.775 + | initContext cI Pbl_ (pos as (p,p_):pos') =
6.776 + ((let val ((pt,_),_) = get_calc cI
6.777 + val pp = par_pblobj pt p
6.778 + val chd = initcontext_pbl pt (pp,p_)
6.779 + in matchpbl2xml cI chd end)
6.780 + handle _ => sysERROR2xml cI "error in kernel")
6.781 +
6.782 + | initContext cI Met_ (pos as (p,p_):pos') =
6.783 + ((let val ((pt,_),_) = get_calc cI
6.784 + val pp = par_pblobj pt p
6.785 + val chd = initcontext_met pt (pp,p_)
6.786 + in matchmet2xml cI chd end)
6.787 + handle _ => sysERROR2xml cI "error in kernel");
6.788 +
6.789 +
6.790 +
6.791 +(*.match a theorem, a ruleset (etc., selected in the knowledge-browser)
6.792 +with the formula in the focus on the worksheet;
6.793 +string contains the thy, thus it is unique as thmID, rlsID for this thy;
6.794 +take the substitution from the istate of the formula.*)
6.795 +(* use"../smltest/Knowledge/poly.sml";
6.796 + val (cI, pos as (p,p_), guh) = (1, ([1,1,1], Frm),
6.797 + "thy_Poly-thm-real_diff_minus");
6.798 + val (cI, pos as (p,p_), guh) = (1, ([1,1], Frm), "norm_Poly");
6.799 + val (cI, pos as (p,p_), guh) =
6.800 + (1, ([1], Res), "thy_isac_Test-rls-Test_simplify");
6.801 + *)
6.802 +fun checkContext (cI:calcID) (pos:pos' as (p,p_)) (guh:guh) =
6.803 + (case (implode o (take_fromto 1 4) o explode) guh of
6.804 + "thy_" =>
6.805 + if member op = [Pbl,Met] p_
6.806 + then message2xml cI "thy-context not to calchead"
6.807 + else if pos = ([],Res) then message2xml cI "no thy-context at result"
6.808 + else if no_thycontext guh then message2xml cI ("no thy-context for '"^
6.809 + guh ^ "'")
6.810 + else let val (ptp as (pt,_),_) = get_calc cI
6.811 + val is = get_istate pt pos
6.812 + val subs = subs_from is "dummy" guh
6.813 + val tac = guh2rewtac guh subs
6.814 + in contextthyOK2xml cI (context_thy (pt, pos) tac) end
6.815 +
6.816 + (*.match the model of a problem at pos p
6.817 + with the model-pattern of the problem with pblID.*)
6.818 +(* val (cI, pos:pos' as (p,p_), guh) =
6.819 + (1, p, kestoreID2guh Pbl_ ["univariate","equation"]);
6.820 + val (cI, pos:pos' as (p,p_), guh) =
6.821 + (1, ([],Pbl), kestoreID2guh Pbl_ ["univariate","equation"]);
6.822 + val (cI, pos:pos' as (p,p_), guh) =
6.823 + (1, ([],Pbl), "pbl_equ_univ");
6.824 + *)
6.825 + | "pbl_" =>
6.826 + let val ((pt,_),_) = get_calc cI
6.827 + val pp = par_pblobj pt p
6.828 + val keID = guh2kestoreID guh
6.829 + val chd = context_pbl keID pt pp
6.830 + in matchpbl2xml cI chd end
6.831 +(* val (cI, pos:pos' as (p,p_), guh) =
6.832 + (1, ([],Pbl), kestoreID2guh Met_ ["LinEq", "solve_lineq_equation"]);
6.833 + *)
6.834 + | "met_" =>
6.835 + let val ((pt,_),_) = get_calc cI
6.836 + val pp = par_pblobj pt p
6.837 + val keID = guh2kestoreID guh
6.838 + val chd = context_met keID pt pp
6.839 + in matchmet2xml cI chd end)
6.840 + handle _ => sysERROR2xml cI "error in kernel";
6.841 +
6.842 +
6.843 +(*------------------------------------------------------------------*)
6.844 +end
6.845 +open interface;
6.846 +(*------------------------------------------------------------------*)
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/src/Tools/isac/Frontend/messages.sml Wed Aug 25 16:20:07 2010 +0200
7.3 @@ -0,0 +1,43 @@
7.4 +(* all messages are encoded to integers for the multi-language system
7.5 + use"Frontend/messages.sml";
7.6 + use"messages.sml";
7.7 + *)
7.8 +
7.9 +datatype language = English | German | Japanese;
7.10 +fun language2str English = "English"
7.11 + | language2str German = "German"
7.12 + | language2str Japanese = "Japanese";
7.13 +
7.14 +val language = English;
7.15 +
7.16 +(*1000 system*)
7.17 +fun msg2str 1000 English =
7.18 + "msg 1000 English"
7.19 + | msg2str 1000 German =
7.20 + "msg 1000 German"
7.21 +
7.22 +(*2000 user in model- and specify-phase*)
7.23 + | msg2str 2020 English =
7.24 + "Kernel cannot propose a tactic (helpless!)"
7.25 +
7.26 +
7.27 +(*3000 user in solve-phase*)
7.28 +
7.29 +(*4000 general*)
7.30 +
7.31 +(*5000 general*)
7.32 +
7.33 +(*6000 general*)
7.34 +
7.35 +(*7000 general*)
7.36 +
7.37 +(*1000 general*)
7.38 +
7.39 +(*1000 general*)
7.40 +
7.41 +(*1000 general*)
7.42 +
7.43 +(*1000 general*)
7.44 +
7.45 + | msg2str i l = raise error ("no message for No. "^
7.46 + string_of_int i^" "^language2str l);
8.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2 +++ b/src/Tools/isac/Frontend/states.sml Wed Aug 25 16:20:07 2010 +0200
8.3 @@ -0,0 +1,487 @@
8.4 +(* states for calculation in global refs
8.5 + use"../states.sml";
8.6 + use"states.sml";
8.7 + *)
8.8 +
8.9 +(*
8.10 +type hide = (pblID *
8.11 + string list * (*hide: tacs +
8.12 + "ALL", .. result immediately
8.13 + "MODELPBL", .. modeling hidden
8.14 + "SPEC", .. specifying hidden
8.15 + "MODELMET", .. (additional itms !)
8.16 + "APPLY", .. solving hidden
8.17 + detail: rls
8.18 + "Rewrite_*" (as strings) must _not_ be ..
8.19 + .. contained in this list, rls _only_ !*)
8.20 + bool) (*inherit to children in pbl-herarchy*)
8.21 + list;
8.22 +
8.23 +(*. points a pbl/metID to a sub-hierarchy of key ?.*)
8.24 +fun is_child_of child key =
8.25 + let fun is_ch [] [] = true (*is child of itself*)
8.26 + | is_ch (c::_) [] = true
8.27 + | is_ch [] (k::_) = false
8.28 + | is_ch (c::cs) (k::ks) =
8.29 + if c = k then is_ch cs ks else false
8.30 + in is_ch (rev child) (rev key) end;
8.31 +(*
8.32 +is_child_of ["root","univar","equation"] ["univar","equation"];
8.33 +val it = true : bool
8.34 +is_child_of ["root","univar","equation"] ["system","equation"];
8.35 +val it = false : bool
8.36 +is_child_of ["equation"] ["system","equation"];
8.37 +val it = false : bool
8.38 +is_child_of ["root","univar","equation"] ["linear","univar","equation"];
8.39 +val it = false : bool
8.40 +*)
8.41 +
8.42 +(*.what tactics have to be hidden (in model/specify these may be several).*)
8.43 +datatype hid =
8.44 + Show (**)
8.45 + | Hundef (**)
8.46 + | Htac (*a tactic has to be hidden*)
8.47 + | Hmodel (*the model of the (sub)problem has to be hidden*)
8.48 + | Hspecify (*the specification of the (sub)problem has to be hidden*)
8.49 + | Happly; (*solving the (sub)problem has to be hidden*)
8.50 +
8.51 +(*. search all pbls if there is some tactic or model/spec/calc to hide .*)
8.52 +fun is_hid pblID arg [] = Show
8.53 + | is_hid pblID arg ((pblID', strs, inherit)::pts) =
8.54 + let fun is_mem arg =
8.55 + if arg mem strs then Htac
8.56 + else if arg mem ["Add_Given","Add_Find","Add_Relation"]
8.57 + andalso "MODEL" mem strs then Hmodel
8.58 + else if arg mem ["Specify_Theory","Specify_Problem",
8.59 + "Specify_Method"]
8.60 + andalso "SPEC" mem strs then Hspecify
8.61 + else if "APPLY" mem strs then Htac
8.62 + else Hundef
8.63 + in if inherit then
8.64 + if is_child_of (pblID:pblID) pblID'
8.65 + then case is_mem arg of Hundef => is_hid pblID arg (pts:hide)
8.66 + | hid => hid
8.67 + else is_hid pblID arg pts
8.68 + else if pblID = pblID'
8.69 + then case is_mem arg of Hundef => is_hid pblID arg (pts:hide)
8.70 + | hid => hid
8.71 + else is_hid pblID arg pts
8.72 + end;
8.73 +(*val hide = [([],["Refine_Tacitly"],true),
8.74 + (["univar","equation"],["Apply_Method","Model_Problem","SPEC"],
8.75 + false)]
8.76 + :hide;
8.77 +is_hid [] "Rewrite" hide;
8.78 +val it = Show
8.79 +is_hid ["any","problem"] "Refine_Tacitly" hide;
8.80 +val it = Htac
8.81 +is_hid ["root","univar","equation"] "Apply_Method" hide;
8.82 +val it = Show
8.83 +is_hid ["univar","equation"] "Apply_Method" hide;
8.84 +val it = Htac
8.85 +is_hid ["univar","equation"] "Specify_Problem" hide;
8.86 +val it = Hspecify
8.87 +*)
8.88 +
8.89 +fun is_hide pblID (tac as (Subproblem (_,pI))) (det:detail) =
8.90 + is_hid pblID "SELF" det
8.91 + | is_hide pblID (tac as (Rewrite (thmID,_))) det =
8.92 + is_hid pblID thmID det
8.93 + | is_hide pblID (tac as (Rewrite_Inst (_,(thmID,_)))) det =
8.94 + is_hid pblID thmID det
8.95 + | is_hide pblID (tac as (Rewrite_Set rls)) det =
8.96 + is_hid pblID rls det
8.97 + | is_hide pblID (tac as (Rewrite_Set_Inst (_,rls))) det =
8.98 + is_hid pblID rls det
8.99 + | is_hide pblID tac det = is_hid pblID (tac2IDstr tac) det;
8.100 +(*val hide = [([],["Refine_Tacitly"],true),
8.101 + (["univar","equation"],["Apply_Method","Model_Problem",
8.102 + "SPEC","SELF"],
8.103 + false)]
8.104 + :hide;
8.105 +is_hide [] (Rewrite ("","")) hide;
8.106 +val it = Show
8.107 +is_hide ["any","problem"] (Refine_Tacitly []) hide;
8.108 +val it = Htac
8.109 +is_hide ["root","univar","equation"] (Apply_Method []) hide;
8.110 +val it = Show
8.111 +is_hide ["univar","equation"] (Apply_Method []) hide;
8.112 +val it = Htac
8.113 +is_hide ["univar","equation"] (Specify_Problem []) hide;
8.114 +val it = Hspecify
8.115 +is_hide ["univar","equation"] (Subproblem (e_domID,["univar","equation"]))hide;
8.116 +val it = Htac
8.117 +is_hide ["equation"] (Subproblem (e_domID,["univar","equation"]))hide;
8.118 +val it = Show
8.119 +*)
8.120 +
8.121 +
8.122 +(*. search all pbls in detail if there is some rls' to be detailed .*)
8.123 +fun is_det pblID arg [] = false
8.124 + | is_det pblID arg ((pblID', rlss, inherit)::pts) =
8.125 + if inherit then
8.126 + if is_child_of (pblID:pblID) pblID'
8.127 + then if arg mem rlss then true
8.128 + else is_det pblID arg (pts:detail)
8.129 + else is_det pblID arg pts
8.130 + else if pblID = pblID'
8.131 + then if arg mem rlss then true
8.132 + else is_det pblID arg (pts:detail)
8.133 + else is_det pblID arg pts;
8.134 +
8.135 +(*fun is_detail pblID (tac as (Subproblem (_,pI))) (det:detail) =
8.136 + is_det pblID "SELF" det*)
8.137 +fun is_detail pblID (tac as (Rewrite_Set rls)) det =
8.138 + is_det pblID rls det
8.139 + | is_detail pblID (tac as (Rewrite_Set_Inst (_,rls))) det =
8.140 + is_det pblID rls det
8.141 + | is_detail _ _ _ = false;
8.142 +----------------------------------------*)
8.143 +
8.144 +type iterID = int;
8.145 +type calcID = int;
8.146 +
8.147 +(*FIXME.WN.9.03: ev. resdesign calcstate + pos for CalcIterator
8.148 +type state =
8.149 + (*pos' * set by the CalcIterator ---> for each user*)
8.150 + calcstate; (*to which ev.included 'preview' tac_s could be applied*)
8.151 +val e_state = (e_pos', e_calcstate):state;
8.152 +val states = ref ([]:(iterID * (calcID * state) list) list);
8.153 +*)
8.154 +
8.155 +val states =
8.156 + ref ([]:(calcID *
8.157 + (calcstate *
8.158 + (iterID * (*1 sets the 'active formula'*)
8.159 + pos' (*for iterator of a user *)
8.160 + ) list)) list);
8.161 +(*
8.162 +states:= [(3,(e_calcstate, [(1,e_pos'),
8.163 + (3,e_pos')])),
8.164 + (4,(e_calcstate, [(1,e_pos'),
8.165 + (2,e_pos')]))];
8.166 +*)
8.167 +
8.168 +(** create new instances of users and ptrees
8.169 + new keys are the lowest possible in the association list **)
8.170 +
8.171 +(* add users *)
8.172 +fun new_key u n = case assoc (u, n) of
8.173 + NONE => n
8.174 +| SOME _ => new_key u (n+1);
8.175 +(*///10.10
8.176 +fun get_calcID (u:(calcID * (calcstate * (iterID * pos') list)) list) =
8.177 + (new_key u 1):calcID;*)
8.178 +(*
8.179 +val new_iterID = get_calcID (!states);
8.180 +val it = 1 : int
8.181 +states:= (!states) @ [(new_iterID, [])];
8.182 +!states;
8.183 +val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[])]
8.184 +*)
8.185 +
8.186 +(*///7.10.03/// add states to a users active states
8.187 +fun get_calcID (uI:iterID) (p:(iterID * (calcID * state) list) list) =
8.188 + case assoc (p, uI) of
8.189 + NONE => raise error ("get_calcID: no iterID " ^
8.190 + (string_of_int uI))
8.191 + | SOME ps => (new_key ps 1):calcID;
8.192 +> get_calcID 1 (!states);
8.193 +val it = 1 : calcID
8.194 +*)
8.195 +(* add users to a calcstate *)
8.196 +fun get_iterID (cI:calcID)
8.197 + (p:(calcID * (calcstate * (iterID * pos') list)) list) =
8.198 + case assoc (p, cI) of
8.199 + NONE => raise error ("get_iterID: no iterID " ^ (string_of_int cI))
8.200 + | SOME (_, us) => (new_key us 1):iterID;
8.201 +(* get_iterID 3 (!states);
8.202 +val it = 2 : iterID*)
8.203 +
8.204 +
8.205 +(** retrieve, update, delete a state by iterID, calcID **)
8.206 +
8.207 +(*//////7.10.
8.208 +fun get_cal (uI:iterID) (pI:calcID) (p:(iterID * (calcID * state) list) list) =
8.209 + (the (assoc2 (p,(uI, pI))))
8.210 + handle _ => raise error ("get_state " ^ (string_of_int uI) ^
8.211 + " " ^ (string_of_int pI) ^ " not existent");
8.212 +> get_cal 3 1 (!states);
8.213 +val it = (((EmptyPtree,(#,#)),[]),([],[])) : state
8.214 +*)
8.215 +
8.216 +(*///7.10.
8.217 +fun get_state (uI:iterID) (pI:calcID) = get_cal uI pI (!states);
8.218 +fun get_calc (uI:iterID) (pI:calcID) = (snd o (get_cal uI pI)) (!states);
8.219 +*)
8.220 +fun get_calc (cI:calcID) =
8.221 + case assoc (!states, cI) of
8.222 + NONE => raise error ("get_calc "^(string_of_int cI)^" not existent")
8.223 + | SOME (c, _) => c;
8.224 +fun get_pos (cI:calcID) (uI:iterID) =
8.225 + case assoc (!states, cI) of
8.226 + NONE => raise error ("get_pos: calc " ^ (string_of_int cI)
8.227 + ^ " not existent")
8.228 + | SOME (_, us) =>
8.229 + (case assoc (us, uI) of
8.230 + NONE => raise error ("get_pos: user " ^ (string_of_int uI)
8.231 + ^ " not existent")
8.232 + | SOME p => p);
8.233 +
8.234 +
8.235 +fun del_assoc ([],_) = []
8.236 + | del_assoc a =
8.237 + let fun del ([], key) ps = ps
8.238 + | del ((keyi, xi) :: pairs, key) ps =
8.239 + if key = keyi then ps @ pairs
8.240 + else del (pairs, key) (ps @ [(keyi, xi)])
8.241 + in del a [] end;
8.242 +(*
8.243 +> val ps = [(1,"1"),(2,"2"),(3,"3"),(4,"4")];
8.244 +> del_assoc (ps,3);
8.245 +val it = [(1,"1"),(2,"2"),(4,"4")] : (int * string) list
8.246 +*)
8.247 +
8.248 +(* delete doesn't report non existing elements *)
8.249 +(*/////7.10.
8.250 +fun del_assoc2 (uI:iterID) (pI:calcID) ps =
8.251 + let val new_ps = del_assoc (the (assoc (ps, uI)), pI)
8.252 + in overwrite (ps, (uI, new_ps)) end;*)
8.253 +(*
8.254 +> states:= del_assoc2 4 41 (!states);
8.255 +> !states;
8.256 +val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#)]),(1,[(#,#)])] : states
8.257 +
8.258 +> del_user 3;
8.259 +> !states;
8.260 +val it = [(4,[(#,#)]),(1,[(#,#)])] : states
8.261 +*)
8.262 +fun del_assoc2 (cI:calcID) (uI:iterID) ps =
8.263 + case assoc (ps, cI) of
8.264 + NONE => ps
8.265 + | SOME (cs, us) =>
8.266 + overwrite (ps, (cI, (cs, del_assoc (us, uI))));
8.267 +(*
8.268 +> del_assoc2 4 1 (!states);
8.269 +val it =
8.270 + [(3, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (3, ([], Und))])),
8.271 + (4, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]*)
8.272 +
8.273 +(*///7.10.
8.274 +fun overwrite2 (ps, (((uI:iterID), (pI:calcID)), p)) =
8.275 + let val new_ps = overwrite (the (assoc (ps, uI)), (pI, p))
8.276 + in (overwrite (ps, (uI, new_ps)))
8.277 + handle _ => raise error ("overwrite2 " ^ (string_of_int uI) ^
8.278 + " " ^ (string_of_int pI) ^ " not existent")
8.279 + end;*)
8.280 +fun overwrite2 (ps, (((cI:calcID), (uI:iterID)), p)) =
8.281 + case assoc (ps, cI) of
8.282 + NONE =>
8.283 + raise error ("overwrite2: calc " ^ (string_of_int uI) ^" not existent")
8.284 + | SOME (cs, us) =>
8.285 + overwrite (ps, (cI ,(cs, overwrite (us, (uI, p)))));
8.286 +
8.287 +fun upd_calc (cI:calcID) cs =
8.288 + case assoc (!states, cI) of
8.289 + NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent")
8.290 + | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us)));
8.291 +(*WN051210 testing before initac: only 1 taci in calcstate so far:
8.292 +fun upd_calc (cI:calcID) (cs as (_, tacis):calcstate) =
8.293 + (if length tacis > 1
8.294 + then raise error ("upd_calc, |tacis|>1: "^tacis2str tacis)
8.295 + else ();
8.296 + case assoc (!states, cI) of
8.297 + NONE => raise error ("upd_calc "^(string_of_int cI)^" not existent")
8.298 + | SOME (_, us) => states:= overwrite (!states, (cI, (cs, us)))
8.299 + );*)
8.300 +
8.301 +
8.302 +(*///7.10.
8.303 +fun upd_tacis (uI:iterID) (pI:calcID) tacis =
8.304 + let val (p, (ptp,_)) = get_state uI pI
8.305 + in states:=
8.306 + overwrite2 ((!states), ((uI, pI), (p, (ptp, tacis)))) end;*)
8.307 +fun upd_tacis (cI:calcID) tacis =
8.308 + case assoc (!states, cI) of
8.309 + NONE =>
8.310 + raise error ("upd_tacis: calctree "^(string_of_int cI)^" not existent")
8.311 + | SOME ((ptp,_), us) =>
8.312 + states:= overwrite (!states, (cI, ((ptp, tacis), us)));
8.313 +(*///7.10.
8.314 +fun upd_ipos (uI:iterID) (pI:calcID) (ip:pos') =
8.315 + let val (_, calc) = get_state uI pI
8.316 + in states:= overwrite2 ((!states), ((uI, pI), (ip, calc))) end;*)
8.317 +fun upd_ipos (cI:calcID) (uI:iterID) (ip:pos') =
8.318 + case assoc (!states, cI) of
8.319 + NONE =>
8.320 + raise error ("upd_ipos: calctree "^(string_of_int cI)^" not existent")
8.321 + | SOME (cs, us) =>
8.322 + states:= overwrite2 (!states, ((cI, uI), ip));
8.323 +
8.324 +
8.325 +(** add and delete calcs **)
8.326 +
8.327 +(*///7.10
8.328 +fun add_pID (uI:iterID) (s:state) (p:(iterID * (calcID * state) list) list) =
8.329 + let val new_ID = get_calcID uI p;
8.330 + val new_states = (the (assoc (p, uI))) @ [(new_ID, s)];
8.331 + in (new_ID, (overwrite (p, (uI, new_states)))) end;*)
8.332 +(*
8.333 +> val (new_calcID, new_states) = add_pID 1 (!states);
8.334 +> states:= new_states;
8.335 +> !states;
8.336 +val it = [(3,[(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states
8.337 +> val (new_calcID, new_states) = add_pID 3 (!states);
8.338 +> states:= new_states;
8.339 +> !states;
8.340 +val it = [(3,[(#,#),(#,#),(#,#)]),(4,[(#,#),(#,#)]),(1,[(#,#)])] : states
8.341 +> assoc2 (!states, (3, 1));
8.342 +val it = SOME EmptyPtree : ptree option
8.343 +> assoc2 (!states, (3, 2));
8.344 +val it = NONE : ptree option
8.345 +*)
8.346 +(*///7.10
8.347 +fun add_calc (uI:iterID) (s:state) =
8.348 + let val (new_calcID, new_calcs) = add_pID uI s (!states)
8.349 + in states:= new_calcs;
8.350 + new_calcID end; *)
8.351 +fun add_user (cI:calcID) =
8.352 + case assoc (!states, cI) of
8.353 + NONE =>
8.354 + raise error ("add_user: calctree "^(string_of_int cI)^" not existent")
8.355 + | SOME (cs, us) =>
8.356 + let val new_uI = new_key us 1
8.357 + in states:= overwrite2 (!states, ((cI, new_uI), e_pos'));
8.358 + new_uI:iterID end;
8.359 +
8.360 +(*///10.10.
8.361 +fun del_calc (uI:iterID) (pI:calcID) =
8.362 + (states:= del_assoc2 uI pI (!states); pI);*)
8.363 +fun del_user (cI:calcID) (uI:iterID) =
8.364 + (states:= del_assoc2 cI uI (!states); uI);
8.365 +
8.366 +
8.367 +(** add and delete calculations **)
8.368 +(**///7.10 add and delete users **)
8.369 +(*///7.10
8.370 +fun add_user () =
8.371 + let val new_uI = get_calcID (!states)
8.372 + in states:= (!states) @ [(new_uI, [])];
8.373 + new_uI end;*)
8.374 +fun add_calc (cs:calcstate) =
8.375 + let val new_cI = new_key (!states) 1
8.376 + in states:= (!states) @ [(new_cI, (cs, []))];
8.377 + new_cI:calcID end;
8.378 +
8.379 +(* delete doesn't report non existing elements *)
8.380 +(*///7.10
8.381 +fun del_user (uI:userID) =
8.382 + (states:= del_assoc (!states, uI); uI);*)
8.383 +fun del_calc (cI:calcID) =
8.384 + (states:= del_assoc (!states, cI); cI:calcID);
8.385 +
8.386 +(* -------------- test all exported funs --------------
8.387 +///7.10
8.388 +Compiler.Control.Print.printDepth:=8;
8.389 +states:=[];
8.390 +add_user (); add_user (); !states;
8.391 +ML> val it = 1 : userID
8.392 +ML> val it = 2 : userID
8.393 +ML> val it = [(1,[]),(2,[])]
8.394 +
8.395 +val (hide,detail) = ([(["pI"],["tac"],true)]:hide,
8.396 + [(["pI"],["tac"],true)]:detail);
8.397 +add_calc 1 e_state;
8.398 +add_calc 1 (e_calcstate,(hide,detail)); !states;
8.399 +ML> val it = 1 : calcID
8.400 +ML> val it = 2 : calcID
8.401 +ML> val it =
8.402 + [(1,
8.403 + [(1,(((EmptyPtree,(#,#)),[]),([],[]))),
8.404 + (2,(((EmptyPtree,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])]
8.405 +
8.406 +val (pt,(p,p_)) = (EmptyPtree,e_pos');
8.407 +val (pt,_) = cappend_problem pt p Uistate ([],e_spec);
8.408 +upd_calc 1 2 ((pt,(p,p_)),[]); !states;
8.409 +ML> val it =
8.410 + [(1,
8.411 + [(1,(((EmptyPtree,(#,#)),[]),([],[]))),
8.412 + (2,(((Nd #,(#,#)),[]),([(#,#,#)],[(#,#,#)])))]),(2,[])]
8.413 +(* ~~~~~~~~~~~~~~~~~~~~ unchanged !!!*)
8.414 +
8.415 +get_state 1 1; get_state 1 2;
8.416 +ML> val it = (((EmptyPtree,([],Und)),[]),([],[])) : state
8.417 +ML> val it =
8.418 + (((Nd
8.419 + (PblObj
8.420 + {branch=NoBranch,cell=[],env=(#,#,#,#),loc=(#,#),meth=[],
8.421 + model={Find=#,Given=#,Relate=#,Where=#,With=#},origin=(#,#),
8.422 + ostate=Incomplete,probl=[],result=(#,#),spec=(#,#,#)},[]),([],Und)),
8.423 + []),([(["pI"],["tac"],true)],[(["pI"],["tac"],true)])) : state
8.424 +
8.425 +del_calc 2 1 (*non existent - NO msg!*); del_calc 1 2; !states;
8.426 +ML> val it = [(1,[(1,(((EmptyPtree,(#,#)),[]),([],[])))]),(2,[])]
8.427 +
8.428 +del_user 1; !states;
8.429 +ML> val it = [(2,[])]
8.430 +
8.431 +add_user (); add_user (); !states;
8.432 +ML> val it = 1 : userID
8.433 +ML> val it = 3 : userID
8.434 +ML> val it = [(2,[]),(1,[]),(3,[])]
8.435 +*)
8.436 +
8.437 +
8.438 +(* -------------- test all exported funs --------------
8.439 +print_depth 9;
8.440 +states:=[];
8.441 +add_calc e_calcstate; add_calc e_calcstate; !states;
8.442 +|val it = 1 : calcID
8.443 +|val it = 2 : calcID
8.444 +|val it =
8.445 +| [(1, (((EmptyPtree, ([], Und)), []), [])),
8.446 +| (2, (((EmptyPtree, ([], Und)), []), []))]
8.447 +
8.448 +add_user 2; add_user 2; !states;
8.449 +|val it = 1 : userID
8.450 +|val it = 2 : userID
8.451 +|val it =
8.452 +| [(1, (((EmptyPtree, ([], Und)), []), [])),
8.453 +| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))]
8.454 +
8.455 +
8.456 +val cs = ((EmptyPtree, ([111], Und)), []) : calcstate;
8.457 +upd_calc 1 cs; !states;
8.458 +|val it =
8.459 +| [(1, (((EmptyPtree, ([111], Und)), []), [])),
8.460 +| (2, (((EmptyPtree, ([], Und)), []), [(1, ([], Und)), (2, ([], Und))]))]
8.461 +
8.462 +get_calc 1; get_calc 2;
8.463 +|val it = ((EmptyPtree, ([111], Und)), []) : calcstate
8.464 +|val it = ((EmptyPtree, ([], Und)), []) : calcstate
8.465 +
8.466 +del_user 2 3 (*non existent - NO msg!*); del_user 2 1; !states;
8.467 +|val it = 3 : userID
8.468 +|val it = 1 : userID
8.469 +|val it =
8.470 +| [(1, (((EmptyPtree, ([111], Und)), []), [])),
8.471 +| (2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]
8.472 +
8.473 +del_calc 1; !states;
8.474 +|val it = 1 : calcID
8.475 +|val it = [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))]))]
8.476 +
8.477 +add_calc e_calcstate; add_calc e_calcstate; !states;
8.478 +|val it = 1 : calcID
8.479 +|val it = 3 : calcID
8.480 +|val it =
8.481 +| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und))])),
8.482 +| (1, (((EmptyPtree, ([], Und)), []), [])),
8.483 +| (3, (((EmptyPtree, ([], Und)), []), []))]
8.484 +
8.485 +add_user 2; !states;
8.486 +|val it =
8.487 +| [(2, (((EmptyPtree, ([], Und)), []), [(2, ([], Und)), (1, ([], Und))])),
8.488 +| (1, (((EmptyPtree, ([], Und)), []), [])),
8.489 +| (3, (((EmptyPtree, ([], Und)), []), []))]
8.490 +*)
8.491 \ No newline at end of file
9.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2 +++ b/src/Tools/isac/Interpret/appl.sml Wed Aug 25 16:20:07 2010 +0200
9.3 @@ -0,0 +1,782 @@
9.4 +(* use"ME/appl.sml";
9.5 + use"appl.sml";
9.6 +
9.7 +12345678901234567890123456789012345678901234567890123456789012345678901234567890
9.8 + 10 20 30 40 50 60 70 80
9.9 +*)
9.10 +val e_cterm' = empty_cterm';
9.11 +
9.12 +
9.13 +fun rew_info (Rls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
9.14 + (rew_ord':rew_ord',erls,ca)
9.15 + | rew_info (Seq {erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
9.16 + (rew_ord',erls,ca)
9.17 + | rew_info (Rrls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
9.18 + (rew_ord',erls, ca)
9.19 + | rew_info rls = raise error ("rew_info called with '"^rls2str rls^"'");
9.20 +
9.21 +(*FIXME.3.4.03:re-organize from_pblobj_or_detail_thm after rls' --> rls*)
9.22 +fun from_pblobj_or_detail_thm thm' p pt =
9.23 + let val (pbl,p',rls') = par_pbl_det pt p
9.24 + in if pbl
9.25 + then let (*val _= writeln("### from_pblobj_or_detail_thm: pbl=true")*)
9.26 + val thy' = get_obj g_domID pt p'
9.27 + val {rew_ord',erls,(*asm_thm,*)...} =
9.28 + get_met (get_obj g_metID pt p')
9.29 + (*val _= writeln("### from_pblobj_or_detail_thm: metID= "^
9.30 + (metID2str(get_obj g_metID pt p')))
9.31 + val _= writeln("### from_pblobj_or_detail_thm: erls= "^erls)*)
9.32 + in ("OK",thy',rew_ord',erls,(*put_asm*)false)
9.33 + end
9.34 + else ((*writeln("### from_pblobj_or_detail_thm: pbl=false");*)
9.35 + (*case assoc(!ruleset', rls') of !!!FIXME.3.4.03:re-organize !!!
9.36 + NONE => ("unknown ruleset '"^rls'^"'","","",Erls,false)
9.37 + | SOME rls =>*)
9.38 + let val thy' = get_obj g_domID pt (par_pblobj pt p)
9.39 + val (rew_ord',erls,(*asm_thm,*)_) = rew_info rls'
9.40 + in ("OK",thy',rew_ord',erls,false) end)
9.41 + end;
9.42 +(*FIXME.3.4.03:re-organize from_pblobj_or_detail_calc after rls' --> rls*)
9.43 +fun from_pblobj_or_detail_calc scrop p pt =
9.44 +(* val (scrop, p, pt) = (op_, p, pt);
9.45 + *)
9.46 + let val (pbl,p',rls') = par_pbl_det pt p
9.47 + in if pbl
9.48 + then let val thy' = get_obj g_domID pt p'
9.49 + val {calc = scr_isa_fns,...} =
9.50 + get_met (get_obj g_metID pt p')
9.51 + val opt = assoc (scr_isa_fns, scrop)
9.52 + in case opt of
9.53 + SOME isa_fn => ("OK",thy',isa_fn)
9.54 + | NONE => ("applicable_in Calculate: unknown '"^scrop^"'",
9.55 + "",("",e_evalfn)) end
9.56 + else (*case assoc(!ruleset', rls') of
9.57 + NONE => ("unknown ruleset '"^rls'^"'","",("",e_evalfn))
9.58 + | SOME rls => !!!FIXME.3.4.03:re-organize from_pblobj_or_detai*)
9.59 + (* val SOME rls = assoc(!ruleset', rls');
9.60 + *)
9.61 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
9.62 + val (_,_,(*_,*)scr_isa_fns) = rew_info rls'(*rls*)
9.63 + in case assoc (scr_isa_fns, scrop) of
9.64 + SOME isa_fn => ("OK",thy',isa_fn)
9.65 + | NONE => ("applicable_in Calculate: unknown '"^scrop^"'",
9.66 + "",("",e_evalfn)) end
9.67 + end;
9.68 +(*------------------------------------------------------------------*)
9.69 +
9.70 +val op_and = Const ("op &", [bool, bool] ---> bool);
9.71 +(*> (cterm_of thy) (op_and $ Free("a",bool) $ Free("b",bool));
9.72 +val it = "a & b" : cterm
9.73 +*)
9.74 +fun mk_and a b = op_and $ a $ b;
9.75 +(*> (cterm_of thy)
9.76 + (mk_and (Free("a",bool)) (Free("b",bool)));
9.77 +val it = "a & b" : cterm*)
9.78 +
9.79 +fun mk_and [] = HOLogic.true_const
9.80 + | mk_and (t::[]) = t
9.81 + | mk_and (t::ts) =
9.82 + let fun mk t' (t::[]) = op_and $ t' $ t
9.83 + | mk t' (t::ts) = mk (op_and $ t' $ t) ts
9.84 + in mk t ts end;
9.85 +(*> val pred = map (term_of o the o (parse thy))
9.86 + ["#0 <= #9 + #4 * x","#0 <= sqrt x + sqrt (#-3 + x)"];
9.87 +> (cterm_of thy) (mk_and pred);
9.88 +val it = "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)" : cterm*)
9.89 +
9.90 +
9.91 +
9.92 +
9.93 +(*for Check_elementwise in applicable_in: [x=1,..] Assumptions -> (x,0<=x&..)*)
9.94 +fun mk_set thy pt p (Const ("List.list.Nil",_)) pred = (e_term, [])
9.95 +
9.96 + | mk_set thy pt p (Const ("Tools.UniversalList",_)) pred =
9.97 + (e_term, if pred <> Const ("Script.Assumptions",bool)
9.98 + then [pred]
9.99 + else (map fst) (get_assumptions_ pt (p,Res)))
9.100 +
9.101 +(* val pred = (term_of o the o (parse thy)) pred;
9.102 + val consts as Const ("List.list.Cons",_) $ eq $ _ = ft;
9.103 + mk_set thy pt p consts pred;
9.104 + *)
9.105 + | mk_set thy pt p (consts as Const ("List.list.Cons",_) $ eq $ _) pred =
9.106 + let val (bdv,_) = HOLogic.dest_eq eq;
9.107 + val pred = if pred <> Const ("Script.Assumptions",bool)
9.108 + then [pred]
9.109 + else (map fst) (get_assumptions_ pt (p,Res))
9.110 + in (bdv, pred) end
9.111 +
9.112 + | mk_set thy _ _ l _ =
9.113 + raise error ("check_elementwise: no set "^
9.114 + (Syntax.string_of_term (thy2ctxt thy) l));
9.115 +(*> val consts = str2term "[x=#4]";
9.116 +> val pred = str2term "Assumptions";
9.117 +> val pt = union_asm pt p
9.118 + [("#0 <= sqrt x + sqrt (#5 + x)",[11]),("#0 <= #9 + #4 * x",[22]),
9.119 + ("#0 <= x ^^^ #2 + #5 * x",[33]),("#0 <= #2 + x",[44])];
9.120 +> val p = [];
9.121 +> val (sss,ttt) = mk_set thy pt p consts pred;
9.122 +> (Syntax.string_of_term (thy2ctxt thy) sss,Syntax.string_of_term(thy2ctxt thy) ttt);
9.123 +val it = ("x","((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & ...
9.124 +
9.125 + val consts = str2term "UniversalList";
9.126 + val pred = str2term "Assumptions";
9.127 +
9.128 +*)
9.129 +
9.130 +
9.131 +
9.132 +(*check a list (/set) of constants [c_1,..,c_n] for c_i:set (: in)*)
9.133 +(* val (erls,consts,(bdv,pred)) = (erl,ft,vp);
9.134 + val (consts,(bdv,pred)) = (ft,vp);
9.135 + *)
9.136 +fun check_elementwise thy erls all_results (bdv, asm) =
9.137 + let (*bdv extracted from ~~~~~~~~~~~ in mk_set already*)
9.138 + fun check sub =
9.139 + let val inst_ = map (subst_atomic [sub]) asm
9.140 + in case eval__true thy 1 inst_ [] erls of
9.141 + (asm', true) => ([HOLogic.mk_eq sub], asm')
9.142 + | (_, false) => ([],[])
9.143 + end;
9.144 + (*val _= writeln("### check_elementwise: res= "^(term2str all_results)^
9.145 + ", bdv= "^(term2str bdv)^", asm= "^(terms2str asm));*)
9.146 + val c' = isalist2list all_results
9.147 + val c'' = map (snd o HOLogic.dest_eq) c' (*assumes [x=1,x=2,..]*)
9.148 + val subs = map (pair bdv) c''
9.149 + in if asm = [] then (all_results, [])
9.150 + else ((apfst ((list2isalist bool) o flat)) o
9.151 + (apsnd flat) o split_list o (map check)) subs end;
9.152 +(* 20.5.03
9.153 +> val all_results = str2term "[x=a+b,x=b,x=3]";
9.154 +> val bdv = str2term "x";
9.155 +> val asm = str2term "(x ~= a) & (x ~= b)";
9.156 +> val erls = e_rls;
9.157 +> val (t, ts) = check_elementwise thy erls all_results (bdv, asm);
9.158 +> term2str t; writeln(terms2str ts);
9.159 +val it = "[x = a + b, x = b, x = c]" : string
9.160 +["a + b ~= a & a + b ~= b","b ~= a & b ~= b","c ~= a & c ~= b"]
9.161 +... with appropriate erls this should be:
9.162 +val it = "[x = a + b, x = c]" : string
9.163 +["b ~= 0 & a ~= 0", "3 ~= a & 3 ~= b"]
9.164 + ////// because b ~= b False*)
9.165 +
9.166 +
9.167 +
9.168 +(*before 5.03-----
9.169 +> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #3) + sqrt (#5 - #3)) &\
9.170 + \ #0 <= #25 + #-1 * #3 ^^^ #2) & #0 <= #4";
9.171 +> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct;
9.172 +val ct' = "True" : cterm'
9.173 +
9.174 +> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #-3) + sqrt (#5 - #-3)) &\
9.175 + \ #0 <= #25 + #-1 * #-3 ^^^ #2) & #0 <= #4";
9.176 +> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct;
9.177 +val ct' = "True" : cterm'
9.178 +
9.179 +
9.180 +> val const = (term_of o the o (parse thy)) "(#3::real)";
9.181 +> val pred' = subst_atomic [(bdv,const)] pred;
9.182 +
9.183 +
9.184 +> val consts = (term_of o the o (parse thy)) "[x = #-3, x = #3]";
9.185 +> val bdv = (term_of o the o (parse thy)) "(x::real)";
9.186 +> val pred = (term_of o the o (parse thy))
9.187 + "((#0 <= #18 & #0 <= sqrt (#5 + x) + sqrt (#5 - x)) & #0 <= #25 + #-1 * x ^^^ #2) & #0 <= #4";
9.188 +> val ttt = check_elementwise thy consts (bdv, pred);
9.189 +> (cterm_of thy) ttt;
9.190 +val it = "[x = #-3, x = #3]" : cterm
9.191 +
9.192 +> val consts = (term_of o the o (parse thy)) "[x = #4]";
9.193 +> val bdv = (term_of o the o (parse thy)) "(x::real)";
9.194 +> val pred = (term_of o the o (parse thy))
9.195 + "#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #5 * x & #0 <= #2 + x";
9.196 +> val ttt = check_elementwise thy consts (bdv,pred);
9.197 +> (cterm_of thy) ttt;
9.198 +val it = "[x = #4]" : cterm
9.199 +
9.200 +> val consts = (term_of o the o (parse thy)) "[x = #-12 // #5]";
9.201 +> val bdv = (term_of o the o (parse thy)) "(x::real)";
9.202 +> val pred = (term_of o the o (parse thy))
9.203 + " #0 <= sqrt x + sqrt (#-3 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #-3 * x & #0 <= #6 + x";
9.204 +> val ttt = check_elementwise thy consts (bdv,pred);
9.205 +> (cterm_of thy) ttt;
9.206 +val it = "[]" : cterm*)
9.207 +
9.208 +
9.209 +(* 14.1.01: for Tac-dummies in root-equ only: skip str until "("*)
9.210 +fun split_dummy str =
9.211 +let fun scan s' [] = (implode s', "")
9.212 + | scan s' (s::ss) = if s=" " then (implode s', implode ss)
9.213 + else scan (s'@[s]) ss;
9.214 +in ((scan []) o explode) str end;
9.215 +(* split_dummy "subproblem_equation_dummy (x=-#5//#12)";
9.216 +val it = ("subproblem_equation_dummy","(x=-#5//#12)") : string * string
9.217 +> split_dummy "x=-#5//#12";
9.218 +val it = ("x=-#5//#12","") : string * string*)
9.219 +
9.220 +
9.221 +
9.222 +
9.223 +(*.applicability of a tacic wrt. a calc-state (ptree,pos').
9.224 + additionally used by next_tac in the script-interpreter for sequence-tacs.
9.225 + tests for applicability are so expensive, that results (rewrites!)
9.226 + are kept in the return-value of 'type tac_'.
9.227 +.*)
9.228 +fun applicable_in (_:pos') _ (Init_Proof (ct', spec)) =
9.229 + Appl (Init_Proof' (ct', spec))
9.230 +
9.231 + | applicable_in (p,p_) pt Model_Problem =
9.232 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.233 + then Notappl ((tac2str Model_Problem)^
9.234 + " not for pos "^(pos'2str (p,p_)))
9.235 + else let val (PblObj{origin=(_,(_,pI',_),_),...}) = get_obj I pt p
9.236 + val {ppc,...} = get_pbt pI'
9.237 + val pbl = init_pbl ppc
9.238 + in Appl (Model_Problem' (pI', pbl, [])) end
9.239 +(* val Refine_Tacitly pI = m;
9.240 + *)
9.241 + | applicable_in (p,p_) pt (Refine_Tacitly pI) =
9.242 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.243 + then Notappl ((tac2str (Refine_Tacitly pI))^
9.244 + " not for pos "^(pos'2str (p,p_)))
9.245 + else (* val Refine_Tacitly pI = m;
9.246 + *)
9.247 + let val (PblObj {origin = (oris, (dI',_,_),_), ...}) = get_obj I pt p;
9.248 + val opt = refine_ori oris pI;
9.249 + in case opt of
9.250 + SOME pblID =>
9.251 + Appl (Refine_Tacitly' (pI, pblID,
9.252 + e_domID, e_metID, [](*filled in specify*)))
9.253 + | NONE => Notappl ((tac2str (Refine_Tacitly pI))^
9.254 + " not applicable") end
9.255 +(* val (p,p_) = ip;
9.256 + val Refine_Problem pI = m;
9.257 + *)
9.258 + | applicable_in (p,p_) pt (Refine_Problem pI) =
9.259 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.260 + then Notappl ((tac2str (Refine_Problem pI))^
9.261 + " not for pos "^(pos'2str (p,p_)))
9.262 + else
9.263 + let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_),
9.264 + probl=itms, ...}) = get_obj I pt p;
9.265 + val thy = if dI' = e_domID then dI else dI';
9.266 + val rfopt = refine_pbl (assoc_thy thy) pI itms;
9.267 + in case rfopt of
9.268 + NONE => Notappl ((tac2str (Refine_Problem pI))^" not applicable")
9.269 + | SOME (rf as (pI',_)) =>
9.270 +(* val SOME (rf as (pI',_)) = rfopt;
9.271 + *)
9.272 + if pI' = pI
9.273 + then Notappl ((tac2str (Refine_Problem pI))^" not applicable")
9.274 + else Appl (Refine_Problem' rf)
9.275 + end
9.276 +
9.277 + (*the specify-tacs have cterm' instead term:
9.278 + parse+error here!!!: see appl_add*)
9.279 + | applicable_in (p,p_) pt (Add_Given ct') =
9.280 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.281 + then Notappl ((tac2str (Add_Given ct'))^
9.282 + " not for pos "^(pos'2str (p,p_)))
9.283 + else Appl (Add_Given' (ct', [(*filled in specify_additem*)]))
9.284 + (*Add_.. should reject (dsc //) (see fmz=[] in sqrt*)
9.285 +
9.286 + | applicable_in (p,p_) pt (Del_Given ct') =
9.287 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.288 + then Notappl ((tac2str (Del_Given ct'))^
9.289 + " not for pos "^(pos'2str (p,p_)))
9.290 + else Appl (Del_Given' ct')
9.291 +
9.292 + | applicable_in (p,p_) pt (Add_Find ct') =
9.293 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.294 + then Notappl ((tac2str (Add_Find ct'))^
9.295 + " not for pos "^(pos'2str (p,p_)))
9.296 + else Appl (Add_Find' (ct', [(*filled in specify_additem*)]))
9.297 +
9.298 + | applicable_in (p,p_) pt (Del_Find ct') =
9.299 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.300 + then Notappl ((tac2str (Del_Find ct'))^
9.301 + " not for pos "^(pos'2str (p,p_)))
9.302 + else Appl (Del_Find' ct')
9.303 +
9.304 + | applicable_in (p,p_) pt (Add_Relation ct') =
9.305 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.306 + then Notappl ((tac2str (Add_Relation ct'))^
9.307 + " not for pos "^(pos'2str (p,p_)))
9.308 + else Appl (Add_Relation' (ct', [(*filled in specify_additem*)]))
9.309 +
9.310 + | applicable_in (p,p_) pt (Del_Relation ct') =
9.311 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.312 + then Notappl ((tac2str (Del_Relation ct'))^
9.313 + " not for pos "^(pos'2str (p,p_)))
9.314 + else Appl (Del_Relation' ct')
9.315 +
9.316 + | applicable_in (p,p_) pt (Specify_Theory dI) =
9.317 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.318 + then Notappl ((tac2str (Specify_Theory dI))^
9.319 + " not for pos "^(pos'2str (p,p_)))
9.320 + else Appl (Specify_Theory' dI)
9.321 +(* val (p,p_) = p; val Specify_Problem pID = m;
9.322 + val Specify_Problem pID = m;
9.323 + *)
9.324 + | applicable_in (p,p_) pt (Specify_Problem pID) =
9.325 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.326 + then Notappl ((tac2str (Specify_Problem pID))^
9.327 + " not for pos "^(pos'2str (p,p_)))
9.328 + else
9.329 + let val (PblObj {origin=(oris,(dI,pI,_),_),spec=(dI',pI',_),
9.330 + probl=itms, ...}) = get_obj I pt p;
9.331 + val thy = assoc_thy (if dI' = e_domID then dI else dI');
9.332 + val {ppc,where_,prls,...} = get_pbt pID;
9.333 + val pbl = if pI'=e_pblID andalso pI=e_pblID
9.334 + then (false, (init_pbl ppc, []))
9.335 + else match_itms_oris thy itms (ppc,where_,prls) oris;
9.336 + in Appl (Specify_Problem' (pID, pbl)) end
9.337 +(* val Specify_Method mID = nxt; val (p,p_) = p;
9.338 + *)
9.339 + | applicable_in (p,p_) pt (Specify_Method mID) =
9.340 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.341 + then Notappl ((tac2str (Specify_Method mID))^
9.342 + " not for pos "^(pos'2str (p,p_)))
9.343 + else Appl (Specify_Method' (mID,[(*filled in specify*)],
9.344 + [(*filled in specify*)]))
9.345 +
9.346 + | applicable_in (p,p_) pt (Apply_Method mI) =
9.347 + if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
9.348 + then Notappl ((tac2str (Apply_Method mI))^
9.349 + " not for pos "^(pos'2str (p,p_)))
9.350 + else Appl (Apply_Method' (mI, NONE, e_istate (*filled in solve*)))
9.351 +
9.352 + | applicable_in (p,p_) pt (Check_Postcond pI) =
9.353 + if member op = [Pbl,Met] p_
9.354 + then Notappl ((tac2str (Check_Postcond pI))^
9.355 + " not for pos "^(pos'2str (p,p_)))
9.356 + else Appl (Check_Postcond'
9.357 + (pI,(e_term,[(*asm in solve*)])))
9.358 + (* in solve -"- ^^^^^^ gets returnvalue of scr*)
9.359 +
9.360 + (*these are always applicable*)
9.361 + | applicable_in (p,p_) _ (Take str) = Appl (Take' (str2term str))
9.362 + | applicable_in (p,p_) _ (Free_Solve) = Appl (Free_Solve')
9.363 +
9.364 +(* val m as Rewrite_Inst (subs, thm') = m;
9.365 + *)
9.366 + | applicable_in (p,p_) pt (m as Rewrite_Inst (subs, thm')) =
9.367 + if member op = [Pbl,Met] p_
9.368 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.369 + else
9.370 + let
9.371 + val pp = par_pblobj pt p;
9.372 + val thy' = (get_obj g_domID pt pp):theory';
9.373 + val thy = assoc_thy thy';
9.374 + val {rew_ord'=ro',erls=erls,...} =
9.375 + get_met (get_obj g_metID pt pp);
9.376 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
9.377 + Frm => (get_obj g_form pt p, p)
9.378 + | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
9.379 + | _ => raise error ("applicable_in: call by "^
9.380 + (pos'2str (p,p_)));
9.381 + in
9.382 + let val subst = subs2subst thy subs;
9.383 + val subs' = subst2subs' subst;
9.384 + in case rewrite_inst_ thy (assoc_rew_ord ro') erls
9.385 + (*put_asm*)false subst (assoc_thm' thy thm') f of
9.386 + SOME (f',asm) => Appl (
9.387 + Rewrite_Inst' (thy',ro',erls,(*put_asm*)false,subst,thm',
9.388 + (*term_of o the o (parse (assoc_thy thy'))*) f,
9.389 + (*(term_of o the o (parse (assoc_thy thy'))*) (f',
9.390 + (*map (term_of o the o (parse (assoc_thy thy')))*) asm)))
9.391 + | NONE => Notappl ((fst thm')^" not applicable") end
9.392 + handle _ => Notappl ("syntax error in "^(subs2str subs)) end
9.393 +
9.394 +(* val ((p,p_), pt, m as Rewrite thm') = (p, pt, m);
9.395 + val ((p,p_), pt, m as Rewrite thm') = (pos, pt, tac);
9.396 + *)
9.397 +| applicable_in (p,p_) pt (m as Rewrite thm') =
9.398 + if member op = [Pbl,Met] p_
9.399 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.400 + else
9.401 + let val (msg,thy',ro,rls',(*put_asm*)_)= from_pblobj_or_detail_thm thm' p pt;
9.402 + val thy = assoc_thy thy';
9.403 + val f = case p_ of
9.404 + Frm => get_obj g_form pt p
9.405 + | Res => (fst o (get_obj g_result pt)) p
9.406 + | _ => raise error ("applicable_in Rewrite: call by "^
9.407 + (pos'2str (p,p_)));
9.408 + in if msg = "OK"
9.409 + then
9.410 + ((*writeln("### applicable_in rls'= "^rls');*)
9.411 + (* val SOME (f',asm)=rewrite thy' ro (id_rls rls') put_asm thm' f;
9.412 + *)
9.413 + case rewrite_ thy (assoc_rew_ord ro)
9.414 + rls' false (assoc_thm' thy thm') f of
9.415 + SOME (f',asm) => Appl (
9.416 + Rewrite' (thy',ro,rls',(*put_asm*)false,thm', f, (f', asm)))
9.417 + | NONE => Notappl ("'"^(fst thm')^"' not applicable") )
9.418 + else Notappl msg
9.419 + end
9.420 +
9.421 +| applicable_in (p,p_) pt (m as Rewrite_Asm thm') =
9.422 + if member op = [Pbl,Met] p_
9.423 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.424 + else
9.425 + let
9.426 + val pp = par_pblobj pt p;
9.427 + val thy' = (get_obj g_domID pt pp):theory';
9.428 + val thy = assoc_thy thy';
9.429 + val {rew_ord'=ro',erls=erls,...} =
9.430 + get_met (get_obj g_metID pt pp);
9.431 + (*val put_asm = true;*)
9.432 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
9.433 + Frm => (get_obj g_form pt p, p)
9.434 + | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
9.435 + | _ => raise error ("applicable_in: call by "^
9.436 + (pos'2str (p,p_)));
9.437 + in case rewrite_ thy (assoc_rew_ord ro') erls
9.438 + (*put_asm*)false (assoc_thm' thy thm') f of
9.439 + SOME (f',asm) => Appl (
9.440 + Rewrite' (thy',ro',erls,(*put_asm*)false,thm', f, (f', asm)))
9.441 + | NONE => Notappl ("'"^(fst thm')^"' not applicable") end
9.442 +
9.443 + | applicable_in (p,p_) pt (m as Detail_Set_Inst (subs, rls)) =
9.444 + if member op = [Pbl,Met] p_
9.445 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.446 + else
9.447 + let
9.448 + val pp = par_pblobj pt p;
9.449 + val thy' = (get_obj g_domID pt pp):theory';
9.450 + val thy = assoc_thy thy';
9.451 + val {rew_ord'=ro',...} = get_met (get_obj g_metID pt pp);
9.452 + val f = case p_ of Frm => get_obj g_form pt p
9.453 + | Res => (fst o (get_obj g_result pt)) p
9.454 + | _ => raise error ("applicable_in: call by "^
9.455 + (pos'2str (p,p_)));
9.456 + in
9.457 + let val subst = subs2subst thy subs
9.458 + val subs' = subst2subs' subst
9.459 + in case rewrite_set_inst_ thy false subst (assoc_rls rls) f of
9.460 + SOME (f',asm) => Appl (
9.461 + Detail_Set_Inst' (thy',false,subst,assoc_rls rls, f, (f', asm)))
9.462 + | NONE => Notappl (rls^" not applicable") end
9.463 + handle _ => Notappl ("syntax error in "^(subs2str subs)) end
9.464 +
9.465 + | applicable_in (p,p_) pt (m as Rewrite_Set_Inst (subs, rls)) =
9.466 + if member op = [Pbl,Met] p_
9.467 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.468 + else
9.469 + let
9.470 + val pp = par_pblobj pt p;
9.471 + val thy' = (get_obj g_domID pt pp):theory';
9.472 + val thy = assoc_thy thy';
9.473 + val {rew_ord'=ro',(*asm_rls=asm_rls,*)...} =
9.474 + get_met (get_obj g_metID pt pp);
9.475 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
9.476 + Frm => (get_obj g_form pt p, p)
9.477 + | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
9.478 + | _ => raise error ("applicable_in: call by "^
9.479 + (pos'2str (p,p_)));
9.480 + in
9.481 + let val subst = subs2subst thy subs;
9.482 + val subs' = subst2subs' subst;
9.483 + in case rewrite_set_inst_ thy (*put_asm*)false subst (assoc_rls rls) f of
9.484 + SOME (f',asm) => Appl (
9.485 + Rewrite_Set_Inst' (thy',(*put_asm*)false,subst,assoc_rls rls, f, (f', asm)))
9.486 + | NONE => Notappl (rls^" not applicable") end
9.487 + handle _ => Notappl ("syntax error in "^(subs2str subs)) end
9.488 +
9.489 + | applicable_in (p,p_) pt (m as Rewrite_Set rls) =
9.490 + if member op = [Pbl,Met] p_
9.491 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.492 + else
9.493 + let
9.494 + val pp = par_pblobj pt p;
9.495 + val thy' = (get_obj g_domID pt pp):theory';
9.496 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
9.497 + Frm => (get_obj g_form pt p, p)
9.498 + | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
9.499 + | _ => raise error ("applicable_in: call by "^
9.500 + (pos'2str (p,p_)));
9.501 + in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of
9.502 + SOME (f',asm) =>
9.503 + ((*writeln("#.# applicable_in Rewrite_Set,2f'= "^f');*)
9.504 + Appl (Rewrite_Set' (thy',(*put_asm*)false,assoc_rls rls, f, (f', asm)))
9.505 + )
9.506 + | NONE => Notappl (rls^" not applicable") end
9.507 +
9.508 + | applicable_in (p,p_) pt (m as Detail_Set rls) =
9.509 + if member op = [Pbl,Met] p_
9.510 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.511 + else
9.512 + let val pp = par_pblobj pt p
9.513 + val thy' = (get_obj g_domID pt pp):theory'
9.514 + val f = case p_ of
9.515 + Frm => get_obj g_form pt p
9.516 + | Res => (fst o (get_obj g_result pt)) p
9.517 + | _ => raise error ("applicable_in: call by "^
9.518 + (pos'2str (p,p_)));
9.519 + in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of
9.520 + SOME (f',asm) =>
9.521 + Appl (Detail_Set' (thy',false,assoc_rls rls, f, (f',asm)))
9.522 + | NONE => Notappl (rls^" not applicable") end
9.523 +
9.524 +
9.525 + | applicable_in p pt (End_Ruleset) =
9.526 + raise error ("applicable_in: not impl. for "^
9.527 + (tac2str End_Ruleset))
9.528 +
9.529 +(* val ((p,p_), pt, (m as Calculate op_)) = (p, pt, m);
9.530 + *)
9.531 +| applicable_in (p,p_) pt (m as Calculate op_) =
9.532 + if member op = [Pbl,Met] p_
9.533 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.534 + else
9.535 + let
9.536 + val (msg,thy',isa_fn) = from_pblobj_or_detail_calc op_ p pt;
9.537 + val f = case p_ of
9.538 + Frm => get_obj g_form pt p
9.539 + | Res => (fst o (get_obj g_result pt)) p
9.540 + in if msg = "OK" then
9.541 + case calculate_ (assoc_thy thy') isa_fn f of
9.542 + SOME (f', (id, thm)) =>
9.543 + Appl (Calculate' (thy',op_, f, (f', (id, string_of_thmI thm))))
9.544 + | NONE => Notappl ("'calculate "^op_^"' not applicable")
9.545 + else Notappl msg
9.546 + end
9.547 +
9.548 +(*Substitute combines two different kind of "substitution":
9.549 + (1) subst_atomic: for ?a..?z
9.550 + (2) Pattern.match: for solving equational systems
9.551 + (which raises exn for ?a..?z)*)
9.552 + | applicable_in (p,p_) pt (m as Substitute sube) =
9.553 + if member op = [Pbl,Met] p_
9.554 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.555 + else let val pp = par_pblobj pt p
9.556 + val thy = assoc_thy (get_obj g_domID pt pp)
9.557 + val f = case p_ of
9.558 + Frm => get_obj g_form pt p
9.559 + | Res => (fst o (get_obj g_result pt)) p
9.560 + val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp)
9.561 + val subte = sube2subte sube
9.562 + val subst = sube2subst thy sube
9.563 + in if foldl and_ (true, map contains_Var subte)
9.564 + (*1*)
9.565 + then let val f' = subst_atomic subst f
9.566 + in if f = f' then Notappl (sube2str sube^" not applicable")
9.567 + else Appl (Substitute' (subte, f, f'))
9.568 + end
9.569 + (*2*)
9.570 + else case rewrite_terms_ thy (assoc_rew_ord rew_ord')
9.571 + erls subte f of
9.572 + SOME (f', _) => Appl (Substitute' (subte, f, f'))
9.573 + | NONE => Notappl (sube2str sube^" not applicable")
9.574 + end
9.575 +(*-------WN08114 interrupted with error in polyminus.sml "11 = 11"
9.576 + | applicable_in (p,p_) pt (m as Substitute sube) =
9.577 + if member op = [Pbl,Met] p_
9.578 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.579 + else let val pp = par_pblobj pt p
9.580 + val thy = assoc_thy (get_obj g_domID pt pp)
9.581 + val f = case p_ of
9.582 + Frm => get_obj g_form pt p
9.583 + | Res => (fst o (get_obj g_result pt)) p
9.584 + val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp)
9.585 + val subte = sube2subte sube
9.586 + in case rewrite_terms_ thy (assoc_rew_ord rew_ord') erls subte f of
9.587 + SOME (f', _) => Appl (Substitute' (subte, f, f'))
9.588 + | NONE => Notappl (sube2str sube^" not applicable")
9.589 + end
9.590 +------------------*)
9.591 +
9.592 + | applicable_in p pt (Apply_Assumption cts') =
9.593 + (raise error ("applicable_in: not impl. for "^
9.594 + (tac2str (Apply_Assumption cts'))))
9.595 +
9.596 + (*'logical' applicability wrt. script in locate: Inconsistent?*)
9.597 + | applicable_in (p,p_) pt (m as Take ct') =
9.598 + if member op = [Pbl,Met] p_
9.599 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.600 + else
9.601 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
9.602 + in (case parse (assoc_thy thy') ct' of
9.603 + SOME ct => Appl (Take' (term_of ct))
9.604 + | NONE => Notappl ("syntax error in "^ct'))
9.605 + end
9.606 +
9.607 + | applicable_in p pt (Take_Inst ct') =
9.608 + raise error ("applicable_in: not impl. for "^
9.609 + (tac2str (Take_Inst ct')))
9.610 +
9.611 + | applicable_in p pt (Group (con, ints)) =
9.612 + raise error ("applicable_in: not impl. for "^
9.613 + (tac2str (Group (con, ints))))
9.614 +
9.615 + | applicable_in (p,p_) pt (m as Subproblem (domID, pblID)) =
9.616 + if member op = [Pbl,Met] p_
9.617 + then (*maybe Apply_Method has already been done*)
9.618 + case get_obj g_env pt p of
9.619 + SOME is => Appl (Subproblem' ((domID, pblID, e_metID), [],
9.620 + e_term, [], subpbl domID pblID))
9.621 + | NONE => Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.622 + else (*somewhere later in the script*)
9.623 + Appl (Subproblem' ((domID, pblID, e_metID), [],
9.624 + e_term, [], subpbl domID pblID))
9.625 +
9.626 + | applicable_in p pt (End_Subproblem) =
9.627 + raise error ("applicable_in: not impl. for "^
9.628 + (tac2str (End_Subproblem)))
9.629 +
9.630 + | applicable_in p pt (CAScmd ct') =
9.631 + raise error ("applicable_in: not impl. for "^
9.632 + (tac2str (CAScmd ct')))
9.633 +
9.634 + | applicable_in p pt (Split_And) =
9.635 + raise error ("applicable_in: not impl. for "^
9.636 + (tac2str (Split_And)))
9.637 + | applicable_in p pt (Conclude_And) =
9.638 + raise error ("applicable_in: not impl. for "^
9.639 + (tac2str (Conclude_And)))
9.640 + | applicable_in p pt (Split_Or) =
9.641 + raise error ("applicable_in: not impl. for "^
9.642 + (tac2str (Split_Or)))
9.643 + | applicable_in p pt (Conclude_Or) =
9.644 + raise error ("applicable_in: not impl. for "^
9.645 + (tac2str (Conclude_Or)))
9.646 +
9.647 + | applicable_in (p,p_) pt (Begin_Trans) =
9.648 + let
9.649 + val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
9.650 + (*_____ implizit Take in gen*)
9.651 + Frm => (get_obj g_form pt p, (lev_on o lev_dn) p)
9.652 + | Res => ((fst o (get_obj g_result pt)) p, (lev_on o lev_dn o lev_on) p)
9.653 + | _ => raise error ("applicable_in: call by "^
9.654 + (pos'2str (p,p_)));
9.655 + val thy' = get_obj g_domID pt (par_pblobj pt p);
9.656 + in (Appl (Begin_Trans' f))
9.657 + handle _ => raise error ("applicable_in: Begin_Trans finds \
9.658 + \syntaxerror in '"^(term2str f)^"'") end
9.659 +
9.660 + (*TODO: check parent branches*)
9.661 + | applicable_in (p,p_) pt (End_Trans) =
9.662 + let val thy' = get_obj g_domID pt (par_pblobj pt p);
9.663 + in if p_ = Res
9.664 + then Appl (End_Trans' (get_obj g_result pt p))
9.665 + else Notappl "'End_Trans' is not applicable at \
9.666 + \the beginning of a transitive sequence"
9.667 + (*TODO: check parent branches*)
9.668 + end
9.669 +
9.670 + | applicable_in p pt (Begin_Sequ) =
9.671 + raise error ("applicable_in: not impl. for "^
9.672 + (tac2str (Begin_Sequ)))
9.673 + | applicable_in p pt (End_Sequ) =
9.674 + raise error ("applicable_in: not impl. for "^
9.675 + (tac2str (End_Sequ)))
9.676 + | applicable_in p pt (Split_Intersect) =
9.677 + raise error ("applicable_in: not impl. for "^
9.678 + (tac2str (Split_Intersect)))
9.679 + | applicable_in p pt (End_Intersect) =
9.680 + raise error ("applicable_in: not impl. for "^
9.681 + (tac2str (End_Intersect)))
9.682 +(* val Appl (Check_elementwse'(t1,"Assumptions",t2)) = it;
9.683 + val (vvv,ppp) = vp;
9.684 +
9.685 + val Check_elementwise pred = m;
9.686 +
9.687 + val ((p,p_), Check_elementwise pred) = (p, m);
9.688 + *)
9.689 + | applicable_in (p,p_) pt (m as Check_elementwise pred) =
9.690 + if member op = [Pbl,Met] p_
9.691 + then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
9.692 + else
9.693 + let
9.694 + val pp = par_pblobj pt p;
9.695 + val thy' = (get_obj g_domID pt pp):theory';
9.696 + val thy = assoc_thy thy'
9.697 + val metID = (get_obj g_metID pt pp)
9.698 + val {crls,...} = get_met metID
9.699 + (*val _=writeln("### applicable_in Check_elementwise: crls= "^crls)
9.700 + val _=writeln("### applicable_in Check_elementwise: pred= "^pred)*)
9.701 + (*val erl = the (assoc'(!ruleset',crls))*)
9.702 + val (f,asm) = case p_ of
9.703 + Frm => (get_obj g_form pt p , [])
9.704 + | Res => get_obj g_result pt p;
9.705 + (*val _= writeln("### applicable_in Check_elementwise: f= "^f);*)
9.706 + val vp = mk_set thy pt p f ((term_of o the o (parse thy)) pred);
9.707 + (*val (v,p)=vp;val _=writeln("### applicable_in Check_elementwise: vp= "^
9.708 + pair2str(term2str v,term2str p))*)
9.709 + in case f of
9.710 + Const ("List.list.Cons",_) $ _ $ _ =>
9.711 + Appl (Check_elementwise'
9.712 + (f, pred,
9.713 + ((*writeln("### applicable_in Check_elementwise: --> "^
9.714 + (res2str (check_elementwise thy crls f vp)));*)
9.715 + check_elementwise thy crls f vp)))
9.716 + | Const ("Tools.UniversalList",_) =>
9.717 + Appl (Check_elementwise' (f, pred, (f,asm)))
9.718 + | Const ("List.list.Nil",_) =>
9.719 + (*Notappl "not applicable to empty list" 3.6.03*)
9.720 + Appl (Check_elementwise' (f, pred, (f,asm(*[] 11.6.03???*))))
9.721 + | _ => Notappl ("not applicable: "^(term2str f)^" should be constants")
9.722 + end
9.723 +
9.724 + | applicable_in (p,p_) pt Or_to_List =
9.725 + if member op = [Pbl,Met] p_
9.726 + then Notappl ((tac2str Or_to_List)^" not for pos "^(pos'2str (p,p_)))
9.727 + else
9.728 + let
9.729 + val pp = par_pblobj pt p;
9.730 + val thy' = (get_obj g_domID pt pp):theory';
9.731 + val thy = assoc_thy thy';
9.732 + val f = case p_ of
9.733 + Frm => get_obj g_form pt p
9.734 + | Res => (fst o (get_obj g_result pt)) p;
9.735 + in (let val ls = or2list f
9.736 + in Appl (Or_to_List' (f, ls)) end)
9.737 + handle _ => Notappl ("'Or_to_List' not applicable to "^(term2str f))
9.738 + end
9.739 +
9.740 + | applicable_in p pt (Collect_Trues) =
9.741 + raise error ("applicable_in: not impl. for "^
9.742 + (tac2str (Collect_Trues)))
9.743 +
9.744 + | applicable_in p pt (Empty_Tac) =
9.745 + Notappl "Empty_Tac is not applicable"
9.746 +
9.747 + | applicable_in (p,p_) pt (Tac id) =
9.748 + let
9.749 + val pp = par_pblobj pt p;
9.750 + val thy' = (get_obj g_domID pt pp):theory';
9.751 + val thy = assoc_thy thy';
9.752 + val f = case p_ of
9.753 + Frm => get_obj g_form pt p
9.754 + | Res => (fst o (get_obj g_result pt)) p;
9.755 + in case id of
9.756 + "subproblem_equation_dummy" =>
9.757 + if is_expliceq f
9.758 + then Appl (Tac_ (thy, term2str f, id,
9.759 + "subproblem_equation_dummy ("^(term2str f)^")"))
9.760 + else Notappl "applicable only to equations made explicit"
9.761 + | "solve_equation_dummy" =>
9.762 + let (*val _= writeln("### applicable_in: solve_equation_dummy: f= "
9.763 + ^f);*)
9.764 + val (id',f') = split_dummy (term2str f);
9.765 + (*val _= writeln("### applicable_in: f'= "^f');*)
9.766 + (*val _= (term_of o the o (parse thy)) f';*)
9.767 + (*val _= writeln"### applicable_in: solve_equation_dummy";*)
9.768 + in if id' <> "subproblem_equation_dummy" then Notappl "no subproblem"
9.769 + else if is_expliceq ((term_of o the o (parse thy)) f')
9.770 + then Appl (Tac_ (thy, term2str f, id, "[" ^ f' ^ "]"))
9.771 + else error ("applicable_in: f= " ^ f') end
9.772 + | _ => Appl (Tac_ (thy, term2str f, id, term2str f)) end
9.773 +
9.774 + | applicable_in p pt End_Proof' = Appl End_Proof''
9.775 +
9.776 + | applicable_in _ _ m =
9.777 + raise error ("applicable_in called for "^(tac2str m));
9.778 +
9.779 +(*WN060614 unused*)
9.780 +fun tac2tac_ pt p m =
9.781 + case applicable_in p pt m of
9.782 + Appl (m') => m'
9.783 + | Notappl _ => raise error ("tac2mstp': fails with"^
9.784 + (tac2str m));
9.785 +
10.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2 +++ b/src/Tools/isac/Interpret/calchead.sml Wed Aug 25 16:20:07 2010 +0200
10.3 @@ -0,0 +1,2257 @@
10.4 +(* Specify-phase: specifying and modeling a problem or a subproblem. The
10.5 + most important types are declared in mstools.sml.
10.6 + author: Walther Neuper
10.7 + 991122
10.8 + (c) due to copyright terms
10.9 +
10.10 +use"ME/calchead.sml";
10.11 +use"calchead.sml";
10.12 +12345678901234567890123456789012345678901234567890123456789012345678901234567890
10.13 + 10 20 30 40 50 60 70 80
10.14 +*)
10.15 +
10.16 +(* TODO interne Funktionen aus sig entfernen *)
10.17 +signature CALC_HEAD =
10.18 + sig
10.19 + datatype additm = Add of SpecifyTools.itm | Err of string
10.20 + val all_dsc_in : SpecifyTools.itm_ list -> Term.term list
10.21 + val all_modspec : ptree * pos' -> ptree * pos'
10.22 + datatype appl = Appl of tac_ | Notappl of string
10.23 + val appl_add :
10.24 + theory ->
10.25 + string ->
10.26 + SpecifyTools.ori list ->
10.27 + SpecifyTools.itm list ->
10.28 + (string * (Term.term * Term.term)) list -> cterm' -> additm
10.29 + type calcstate
10.30 + type calcstate'
10.31 + val chk_vars : term ppc -> string * Term.term list
10.32 + val chktyp :
10.33 + theory -> int * term list * term list -> term
10.34 + val chktyps :
10.35 + theory -> term list * term list -> term list
10.36 + val complete_metitms :
10.37 + SpecifyTools.ori list ->
10.38 + SpecifyTools.itm list ->
10.39 + SpecifyTools.itm list -> pat list -> SpecifyTools.itm list
10.40 + val complete_mod_ : ori list * pat list * pat list * itm list ->
10.41 + itm list * itm list
10.42 + val complete_mod : ptree * pos' -> ptree * (pos * pos_)
10.43 + val complete_spec : ptree * pos' -> ptree * pos'
10.44 + val cpy_nam :
10.45 + pat list -> preori list -> pat -> preori
10.46 + val e_calcstate : calcstate
10.47 + val e_calcstate' : calcstate'
10.48 + val eq1 : ''a -> 'b * (''a * 'c) -> bool
10.49 + val eq3 :
10.50 + ''a -> Term.term -> 'b * 'c * 'd * ''a * SpecifyTools.itm_ -> bool
10.51 + val eq4 : ''a -> 'b * ''a list * 'c * 'd * 'e -> bool
10.52 + val eq5 :
10.53 + 'a * 'b * 'c * 'd * SpecifyTools.itm_ ->
10.54 + 'e * 'f * 'g * Term.term * 'h -> bool
10.55 + val eq_dsc : SpecifyTools.itm * SpecifyTools.itm -> bool
10.56 + val eq_pos' : ''a * pos_ -> ''a * pos_ -> bool
10.57 + val f_mout : theory -> mout -> Term.term
10.58 + val filter_outs :
10.59 + SpecifyTools.ori list ->
10.60 + SpecifyTools.itm list -> SpecifyTools.ori list
10.61 + val filter_pbt :
10.62 + SpecifyTools.ori list ->
10.63 + ('a * (Term.term * 'b)) list -> SpecifyTools.ori list
10.64 + val foldl1 : ('a * 'a -> 'a) -> 'a list -> 'a
10.65 + val foldr1 : ('a * 'a -> 'a) -> 'a list -> 'a
10.66 + val form : 'a -> ptree -> (string * ('a * pos_) * Term.term) list
10.67 + val formres : 'a -> ptree -> (string * ('a * pos_) * Term.term) list
10.68 + val gen_ins' : ('a * 'a -> bool) -> 'a * 'a list -> 'a list
10.69 + val get_formress :
10.70 + (string * (pos * pos_) * Term.term) list list ->
10.71 + pos -> ptree list -> (string * (pos * pos_) * Term.term) list
10.72 + val get_forms :
10.73 + (string * (pos * pos_) * Term.term) list list ->
10.74 + posel list -> ptree list -> (string * (pos * pos_) * Term.term) list
10.75 + val get_interval : pos' -> pos' -> int -> ptree -> (pos' * term) list
10.76 + val get_ocalhd : ptree * pos' -> ocalhd
10.77 + val get_spec_form : tac_ -> pos' -> ptree -> mout
10.78 + val geti_ct :
10.79 + theory ->
10.80 + SpecifyTools.ori -> SpecifyTools.itm -> string * cterm'
10.81 + val getr_ct : theory -> SpecifyTools.ori -> string * cterm'
10.82 + val has_list_type : Term.term -> bool
10.83 + val header : pos_ -> pblID -> metID -> pblmet
10.84 + val insert_ppc :
10.85 + theory ->
10.86 + int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ ->
10.87 + SpecifyTools.itm list -> SpecifyTools.itm list
10.88 + val insert_ppc' :
10.89 + SpecifyTools.itm -> SpecifyTools.itm list -> SpecifyTools.itm list
10.90 + val is_complete_mod : ptree * pos' -> bool
10.91 + val is_complete_mod_ : SpecifyTools.itm list -> bool
10.92 + val is_complete_modspec : ptree * pos' -> bool
10.93 + val is_complete_spec : ptree * pos' -> bool
10.94 + val is_copy_named : 'a * ('b * Term.term) -> bool
10.95 + val is_copy_named_idstr : string -> bool
10.96 + val is_error : SpecifyTools.itm_ -> bool
10.97 + val is_field_correct : ''a -> ''b -> (''a * ''b list) list -> bool
10.98 + val is_known :
10.99 + theory ->
10.100 + string ->
10.101 + SpecifyTools.ori list ->
10.102 + Term.term -> string * SpecifyTools.ori * Term.term list
10.103 + val is_list_type : Term.typ -> bool
10.104 + val is_notyet_input :
10.105 + theory ->
10.106 + SpecifyTools.itm list ->
10.107 + Term.term list ->
10.108 + SpecifyTools.ori ->
10.109 + ('a * (Term.term * Term.term)) list -> string * SpecifyTools.itm
10.110 + val is_parsed : SpecifyTools.itm_ -> bool
10.111 + val is_untouched : SpecifyTools.itm -> bool
10.112 + val matc :
10.113 + theory ->
10.114 + pat list ->
10.115 + Term.term list ->
10.116 + (int list * string * Term.term * Term.term list) list ->
10.117 + (int list * string * Term.term * Term.term list) list
10.118 + val match_ags :
10.119 + theory -> pat list -> Term.term list -> SpecifyTools.ori list
10.120 + val maxl : int list -> int
10.121 + val match_ags_msg : string list -> Term.term -> Term.term list -> unit
10.122 + val memI : ''a list -> ''a -> bool
10.123 + val mk_additem : string -> cterm' -> tac
10.124 + val mk_delete : theory -> string -> SpecifyTools.itm_ -> tac
10.125 + val mtc :
10.126 + theory -> pat -> Term.term -> SpecifyTools.preori option
10.127 + val nxt_add :
10.128 + theory ->
10.129 + SpecifyTools.ori list ->
10.130 + (string * (Term.term * 'a)) list ->
10.131 + SpecifyTools.itm list -> (string * cterm') option
10.132 + val nxt_model_pbl : tac_ -> ptree * (int list * pos_) -> tac_
10.133 + val nxt_spec :
10.134 + pos_ ->
10.135 + bool ->
10.136 + SpecifyTools.ori list ->
10.137 + spec ->
10.138 + SpecifyTools.itm list * SpecifyTools.itm list ->
10.139 + (string * (Term.term * 'a)) list * (string * (Term.term * 'b)) list ->
10.140 + spec -> pos_ * tac
10.141 + val nxt_specif : tac -> ptree * (int list * pos_) -> calcstate'
10.142 + val nxt_specif_additem :
10.143 + string -> cterm' -> ptree * (int list * pos_) -> calcstate'
10.144 + val nxt_specify_init_calc : fmz -> calcstate
10.145 + val ocalhd_complete :
10.146 + SpecifyTools.itm list ->
10.147 + (bool * Term.term) list -> domID * pblID * metID -> bool
10.148 + val ori2Coritm :
10.149 + pat list -> ori -> itm
10.150 + val ori_2itm :
10.151 + 'a ->
10.152 + SpecifyTools.itm_ ->
10.153 + Term.term -> Term.term list -> SpecifyTools.ori -> SpecifyTools.itm
10.154 + val overwrite_ppc :
10.155 + theory ->
10.156 + int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ ->
10.157 + SpecifyTools.itm list ->
10.158 + (int * SpecifyTools.vats * bool * string * SpecifyTools.itm_) list
10.159 + val parse_ok : SpecifyTools.itm_ list -> bool
10.160 + val posform2str : pos' * ptform -> string
10.161 + val posforms2str : (pos' * ptform) list -> string
10.162 + val posterms2str : (pos' * term) list -> string (*tests only*)
10.163 + val ppc135list : 'a SpecifyTools.ppc -> 'a list
10.164 + val ppc2list : 'a SpecifyTools.ppc -> 'a list
10.165 + val pt_extract :
10.166 + ptree * (int list * pos_) ->
10.167 + ptform * tac option * Term.term list
10.168 + val pt_form : ppobj -> ptform
10.169 + val pt_model : ppobj -> pos_ -> ptform
10.170 + val reset_calchead : ptree * pos' -> ptree * pos'
10.171 + val seek_oridts :
10.172 + theory ->
10.173 + string ->
10.174 + Term.term * Term.term list ->
10.175 + (int * SpecifyTools.vats * string * Term.term * Term.term list) list
10.176 + -> string * SpecifyTools.ori * Term.term list
10.177 + val seek_orits :
10.178 + theory ->
10.179 + string ->
10.180 + Term.term list ->
10.181 + (int * SpecifyTools.vats * string * Term.term * Term.term list) list
10.182 + -> string * SpecifyTools.ori * Term.term list
10.183 + val seek_ppc :
10.184 + int -> SpecifyTools.itm list -> SpecifyTools.itm option
10.185 + val show_pt : ptree -> unit
10.186 + val some_spec : spec -> spec -> spec
10.187 + val specify :
10.188 + tac_ ->
10.189 + pos' ->
10.190 + cid ->
10.191 + ptree ->
10.192 + (posel list * pos_) * ((posel list * pos_) * istate) * mout * tac *
10.193 + safe * ptree
10.194 + val specify_additem :
10.195 + string ->
10.196 + cterm' * 'a ->
10.197 + int list * pos_ ->
10.198 + 'b ->
10.199 + ptree ->
10.200 + (pos * pos_) * ((pos * pos_) * istate) * mout * tac * safe * ptree
10.201 + val tag_form : theory -> term * term -> term
10.202 + val test_types : theory -> Term.term * Term.term list -> string
10.203 + val typeless : Term.term -> Term.term
10.204 + val unbound_ppc : term SpecifyTools.ppc -> Term.term list
10.205 + val vals_of_oris : SpecifyTools.ori list -> Term.term list
10.206 + val variants_in : Term.term list -> int
10.207 + val vars_of_pbl_ : ('a * ('b * Term.term)) list -> Term.term list
10.208 + val vars_of_pbl_' : ('a * ('b * Term.term)) list -> Term.term list
10.209 + end
10.210 +
10.211 +
10.212 +
10.213 +
10.214 +
10.215 +(*---------------------------------------------------------------------*)
10.216 +structure CalcHead (**): CALC_HEAD(**) =
10.217 +
10.218 +struct
10.219 +(*---------------------------------------------------------------------*)
10.220 +
10.221 +(* datatypes *)
10.222 +
10.223 +(*.the state wich is stored after each step of calculation; it contains
10.224 + the calc-state and a list of [tac,istate](="tacis") to be applied.
10.225 + the last_elem tacis is the first to apply to the calc-state and
10.226 + the (only) one shown to the front-end as the 'proposed tac'.
10.227 + the calc-state resulting from the application of tacis is not stored,
10.228 + because the tacis hold enought information for efficiently rebuilding
10.229 + this state just by "fun generate ".*)
10.230 +type calcstate =
10.231 + (ptree * pos') * (*the calc-state to which the tacis could be applied*)
10.232 + (taci list); (*ev. several (hidden) steps;
10.233 + in REVERSE order: first tac_ to apply is last_elem*)
10.234 +val e_calcstate = ((EmptyPtree, e_pos'), [e_taci]):calcstate;
10.235 +
10.236 +(*the state used during one calculation within the mathengine; it contains
10.237 + a list of [tac,istate](="tacis") which generated the the calc-state;
10.238 + while this state's tacis are extended by each (internal) step,
10.239 + the calc-state is used for creating new nodes in the calc-tree
10.240 + (eg. applicable_in requires several particular nodes of the calc-tree)
10.241 + and then replaced by the the newly created;
10.242 + on leave of the mathengine the resuing calc-state is dropped anyway,
10.243 + because the tacis hold enought information for efficiently rebuilding
10.244 + this state just by "fun generate ".*)
10.245 +type calcstate' =
10.246 + taci list * (*cas. several (hidden) steps;
10.247 + in REVERSE order: first tac_ to apply is last_elem*)
10.248 + pos' list * (*a "continuous" sequence of pos',
10.249 + deleted by application of taci list*)
10.250 + (ptree * pos'); (*the calc-state resulting from the application of tacis*)
10.251 +val e_calcstate' = ([e_taci], [e_pos'], (EmptyPtree, e_pos')):calcstate';
10.252 +
10.253 +(*FIXXXME.WN020430 intermediate hack for fun ass_up*)
10.254 +fun f_mout thy (Form' (FormKF (_,_,_,_,f))) = (term_of o the o (parse thy)) f
10.255 + | f_mout thy _ = raise error "f_mout: not called with formula";
10.256 +
10.257 +
10.258 +(*.is the calchead complete ?.*)
10.259 +fun ocalhd_complete (its: itm list) (pre: (bool * term) list) (dI,pI,mI) =
10.260 + foldl and_ (true, map #3 its) andalso
10.261 + foldl and_ (true, map #1 pre) andalso
10.262 + dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID;
10.263 +
10.264 +
10.265 +(* make a term 'typeless' for comparing with another 'typeless' term;
10.266 + 'type-less' usually is illtyped *)
10.267 +fun typeless (Const(s,_)) = (Const(s,e_type))
10.268 + | typeless (Free(s,_)) = (Free(s,e_type))
10.269 + | typeless (Var(n,_)) = (Var(n,e_type))
10.270 + | typeless (Bound i) = (Bound i)
10.271 + | typeless (Abs(s,_,t)) = Abs(s,e_type, typeless t)
10.272 + | typeless (t1 $ t2) = (typeless t1) $ (typeless t2);
10.273 +(*
10.274 +> val (SOME ct) = parse thy "max_relation (A=#2*a*b - a^^^#2)";
10.275 +> val (_,t1) = split_dsc_t hs (term_of ct);
10.276 +> val (SOME ct) = parse thy "A=#2*a*b - a^^^#2";
10.277 +> val (_,t2) = split_dsc_t hs (term_of ct);
10.278 +> typeless t1 = typeless t2;
10.279 +val it = true : bool
10.280 +*)
10.281 +
10.282 +
10.283 +
10.284 +(*.to an input (d,ts) find the according ori and insert the ts.*)
10.285 +(*WN.11.03: + dont take first inter<>[]*)
10.286 +fun seek_oridts thy sel (d,ts) [] =
10.287 + ("'"^(Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts)))^
10.288 + "' not found (typed)", (0,[],sel,d,ts):ori, [])
10.289 + (* val (id,vat,sel',d',ts')::oris = ori;
10.290 + val (id,vat,sel',d',ts') = ori;
10.291 + *)
10.292 + | seek_oridts thy sel (d,ts) ((id,vat,sel',d',ts')::(oris:ori list)) =
10.293 + if sel = sel' andalso d=d' andalso (inter op = ts ts') <> []
10.294 + then if sel = sel'
10.295 + then ("",
10.296 + (id,vat,sel,d, inter op = ts ts'):ori,
10.297 + ts')
10.298 + else ((Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts)))
10.299 + ^ " not for " ^ sel,
10.300 + e_ori_,
10.301 + [])
10.302 + else seek_oridts thy sel (d,ts) oris;
10.303 +
10.304 +(*.to an input (_,ts) find the according ori and insert the ts.*)
10.305 +fun seek_orits thy sel ts [] =
10.306 + ("'"^
10.307 + (strs2str (map (Syntax.string_of_term (thy2ctxt thy)) ts))^
10.308 + "' not found (typed)", e_ori_, [])
10.309 + | seek_orits thy sel ts ((id,vat,sel',d,ts')::(oris:ori list)) =
10.310 + if sel = sel' andalso (inter op = ts ts') <> []
10.311 + then if sel = sel'
10.312 + then ("",
10.313 + (id,vat,sel,d, inter op = ts ts'):ori,
10.314 + ts')
10.315 + else (((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts)
10.316 + ^ " not for "^sel,
10.317 + e_ori_,
10.318 + [])
10.319 + else seek_orits thy sel ts oris;
10.320 +(* false
10.321 +> val ((id,vat,sel',d,ts')::(ori':ori)) = ori;
10.322 +> seek_orits thy sel ts [(id,vat,sel',d,ts')];
10.323 +uncaught exception TYPE
10.324 +> seek_orits thy sel ts [];
10.325 +uncaught exception TYPE
10.326 +*)
10.327 +
10.328 +(*find_first item with #1 equal to id*)
10.329 +fun seek_ppc id [] = NONE
10.330 + | seek_ppc id (p::(ppc:itm list)) =
10.331 + if id = #1 p then SOME p else seek_ppc id ppc;
10.332 +
10.333 +
10.334 +
10.335 +(*---------------------------------------------(3) nach ptyps.sml 23.3.02*)
10.336 +
10.337 +
10.338 +datatype appl = Appl of tac_ | Notappl of string;
10.339 +
10.340 +fun ppc2list ({Given=gis,Where=whs,Find=fis,
10.341 + With=wis,Relate=res}: 'a ppc) =
10.342 + gis @ whs @ fis @ wis @ res;
10.343 +fun ppc135list ({Given=gis,Find=fis,Relate=res,...}: 'a ppc) =
10.344 + gis @ fis @ res;
10.345 +
10.346 +
10.347 +
10.348 +
10.349 +(* get the number of variants in a problem in 'original',
10.350 + assumes equal descriptions in immediate sequence *)
10.351 +fun variants_in ts =
10.352 + let fun eq(x,y) = head_of x = head_of y;
10.353 + fun cnt eq [] y n = ([n],[])
10.354 + | cnt eq (x::xs) y n = if eq(x,y) then cnt eq xs y (n+1)
10.355 + else ([n], x::xs);
10.356 + fun coll eq xs [] = xs
10.357 + | coll eq xs (y::ys) =
10.358 + let val (n,ys') = cnt eq (y::ys) y 0;
10.359 + in if ys' = [] then xs @ n else coll eq (xs @ n) ys' end;
10.360 + val vts = subtract op = [1] (distinct (coll eq [] ts));
10.361 + in case vts of [] => 1 | [n] => n
10.362 + | _ => error "different variants in formalization" end;
10.363 +(*
10.364 +> cnt (op=) [2,2,2,4,5,5,5,5,5] 2 0;
10.365 +val it = ([3],[4,5,5,5,5,5]) : int list * int list
10.366 +> coll (op=) [] [1,2,2,2,4,5,5,5,5,5];
10.367 +val it = [1,3,1,5] : int list
10.368 +*)
10.369 +
10.370 +fun is_list_type (Type("List.list",_)) = true
10.371 + | is_list_type _ = false;
10.372 +(* fun destr (Type(str,sort)) = (str,sort);
10.373 +> val (SOME ct) = parse thy "lll::real list";
10.374 +> val ty = (#T o rep_cterm) ct;
10.375 +> is_list_type ty;
10.376 +val it = true : bool
10.377 +> destr ty;
10.378 +val it = ("List.list",["RealDef.real"]) : string * typ list
10.379 +> atomty ((#t o rep_cterm) ct);
10.380 +*** -------------
10.381 +*** Free ( lll, real list)
10.382 +val it = () : unit
10.383 +
10.384 +> val (SOME ct) = parse thy "[lll::real]";
10.385 +> val ty = (#T o rep_cterm) ct;
10.386 +> is_list_type ty;
10.387 +val it = true : bool
10.388 +> destr ty;
10.389 +val it = ("List.list",["'a"]) : string * typ list
10.390 +> atomty ((#t o rep_cterm) ct);
10.391 +*** -------------
10.392 +*** Const ( List.list.Cons, [real, real list] => real list)
10.393 +*** Free ( lll, real)
10.394 +*** Const ( List.list.Nil, real list)
10.395 +
10.396 +> val (SOME ct) = parse thy "lll";
10.397 +> val ty = (#T o rep_cterm) ct;
10.398 +> is_list_type ty;
10.399 +val it = false : bool *)
10.400 +
10.401 +
10.402 +fun has_list_type (Free(_,T)) = is_list_type T
10.403 + | has_list_type _ = false;
10.404 +(*
10.405 +> val (SOME ct) = parse thy "lll::real list";
10.406 +> has_list_type (term_of ct);
10.407 +val it = true : bool
10.408 +> val (SOME ct) = parse thy "[lll::real]";
10.409 +> has_list_type (term_of ct);
10.410 +val it = false : bool *)
10.411 +
10.412 +fun is_parsed (Syn _) = false
10.413 + | is_parsed _ = true;
10.414 +fun parse_ok its = foldl and_ (true, map is_parsed its);
10.415 +
10.416 +fun all_dsc_in itm_s =
10.417 + let
10.418 + fun d_in (Cor ((d,_),_)) = [d]
10.419 + | d_in (Syn c) = []
10.420 + | d_in (Typ c) = []
10.421 + | d_in (Inc ((d,_),_)) = [d]
10.422 + | d_in (Sup (d,_)) = [d]
10.423 + | d_in (Mis (d,_)) = [d];
10.424 + in (flat o (map d_in)) itm_s end;
10.425 +
10.426 +(* 30.1.00 ---
10.427 +fun is_Syn (Syn _) = true
10.428 + | is_Syn (Typ _) = true
10.429 + | is_Syn _ = false;
10.430 + --- *)
10.431 +fun is_error (Cor (_,ts)) = false
10.432 + | is_error (Sup (_,ts)) = false
10.433 + | is_error (Inc (_,ts)) = false
10.434 + | is_error (Mis (_,ts)) = false
10.435 + | is_error _ = true;
10.436 +
10.437 +(* 30.1.00 ---
10.438 +fun ct_in (Syn (c)) = c
10.439 + | ct_in (Typ (c)) = c
10.440 + | ct_in _ = raise error "ct_in called for Cor .. Sup";
10.441 + --- *)
10.442 +
10.443 +(*#############################################################*)
10.444 +(*#############################################################*)
10.445 +(* vvv--- aus nnewcode.sml am 30.1.00 ---vvv *)
10.446 +
10.447 +
10.448 +(* testdaten besorgen:
10.449 + use"test-coil-kernel.sml";
10.450 + val (PblObj{origin=(oris,_,_),meth={ppc=itms,...},...}) =
10.451 + get_obj I pt p;
10.452 + *)
10.453 +
10.454 +(* given oris, ppc,
10.455 + variant V: oris union ppc => int, id ID: oris union ppc => int
10.456 +
10.457 + ppc is_complete ==
10.458 + EX vt:V. ALL r:oris --> EX i:ppc. ID r = ID i & complete i
10.459 +
10.460 + and
10.461 + @vt = max sum(i : ppc) V i
10.462 +*)
10.463 +
10.464 +
10.465 +
10.466 +(*
10.467 +> ((vts_cnt (vts_in itms))) itms;
10.468 +
10.469 +
10.470 +
10.471 +---^^--test 10.3.
10.472 +> val vts = vts_in itms;
10.473 +val vts = [1,2,3] : int list
10.474 +> val nvts = vts_cnt vts itms;
10.475 +val nvts = [(1,6),(2,5),(3,7)] : (int * int) list
10.476 +> val mx = max2 nvts;
10.477 +val mx = (3,7) : int * int
10.478 +> val v = max_vt itms;
10.479 +val v = 3 : int
10.480 +--------------------------
10.481 +>
10.482 +*)
10.483 +
10.484 +(*.get the first term in ts from ori.*)
10.485 +(* val (_,_,fd,d,ts) = hd miss;
10.486 + *)
10.487 +fun getr_ct thy ((_,_,fd,d,ts):ori) =
10.488 + (fd, ((Syntax.string_of_term (thy2ctxt thy)) o
10.489 + (comp_dts thy)) (d,[hd ts]):cterm');
10.490 +(* val t = comp_dts thy (d,[hd ts]);
10.491 + *)
10.492 +
10.493 +(* get a term from ori, notyet input in itm *)
10.494 +fun geti_ct thy ((_,_,_,d,ts):ori) ((_,_,_,fd,itm_):itm) =
10.495 + (fd, ((Syntax.string_of_term (thy2ctxt thy)) o (comp_dts thy))
10.496 + (d, subtract op = (ts_in itm_) ts):cterm');
10.497 +(* test-maximum.sml fmy <> [], Init_Proof ...
10.498 + val (_,_,_,d,ts) = ori; val (_,_,_,fd,itm_) = hd icl;
10.499 + val d' $ ts' = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
10.500 + atomty d;
10.501 + atomty d';
10.502 + atomty (hd ts);
10.503 + atomty ts';
10.504 + cterm_of thy (d $ (hd ts));
10.505 + cterm_of thy (d' $ ts');
10.506 +
10.507 + comp_dts thy (d,ts);
10.508 + *)
10.509 +
10.510 +
10.511 +(* in FE dsc, not dat: this is in itms ...*)
10.512 +fun is_untouched ((_,_,false,_,Inc((_,[]),_)):itm) = true
10.513 + | is_untouched _ = false;
10.514 +
10.515 +
10.516 +(* select an item in oris, notyet input in itms
10.517 + (precondition: in itms are only Cor, Sup, Inc) *)
10.518 +local infix mem;
10.519 +fun x mem [] = false
10.520 + | x mem (y :: ys) = x = y orelse x mem ys;
10.521 +in
10.522 +fun nxt_add thy ([]:ori list) pbt itms = (*root (only) ori...fmz=[]*)
10.523 + let
10.524 + fun test_d d ((i,_,_,_,itm_):itm) = (d = (d_in itm_)) andalso i<>0;
10.525 + fun is_elem itms (f,(d,t)) =
10.526 + case find_first (test_d d) itms of
10.527 + SOME _ => true | NONE => false;
10.528 + in case filter_out (is_elem itms) pbt of
10.529 +(* val ((f,(d,_))::itms) = filter_out (is_elem itms) pbt;
10.530 + *)
10.531 + (f,(d,_))::itms =>
10.532 + SOME (f:string, ((Syntax.string_of_term (thy2ctxt thy)) o comp_dts thy) (d,[]):cterm')
10.533 + | _ => NONE end
10.534 +
10.535 +(* val (thy,itms) = (assoc_thy (if dI=e_domID then dI' else dI),pbl);
10.536 + *)
10.537 + | nxt_add thy oris pbt itms =
10.538 + let
10.539 + fun testr_vt v ori = (curry (op mem) v) (#2 (ori:ori))
10.540 + andalso (#3 ori) <>"#undef";
10.541 + fun testi_vt v itm = (curry (op mem) v) (#2 (itm:itm));
10.542 + fun test_id ids r = curry (op mem) (#1 (r:ori)) ids;
10.543 +(* val itm = hd icl; val (_,_,_,d,ts) = v6;
10.544 + *)
10.545 + fun test_subset (itm:itm) ((_,_,_,d,ts):ori) =
10.546 + (d_in (#5 itm)) = d andalso subset op = (ts_in (#5 itm), ts);
10.547 + fun false_and_not_Sup((i,v,false,f,Sup _):itm) = false
10.548 + | false_and_not_Sup (i,v,false,f, _) = true
10.549 + | false_and_not_Sup _ = false;
10.550 +
10.551 + val v = if itms = [] then 1 else max_vt itms;
10.552 + val vors = if v = 0 then oris else filter (testr_vt v) oris;(*oris..vat*)
10.553 + val vits = if v = 0 then itms (*because of dsc without dat*)
10.554 + else filter (testi_vt v) itms; (*itms..vat*)
10.555 + val icl = filter false_and_not_Sup vits; (* incomplete *)
10.556 + in if icl = []
10.557 + then case filter_out (test_id (map #1 vits)) vors of
10.558 + [] => NONE
10.559 + (* val miss = filter_out (test_id (map #1 vits)) vors;
10.560 + *)
10.561 + | miss => SOME (getr_ct thy (hd miss))
10.562 + else
10.563 + case find_first (test_subset (hd icl)) vors of
10.564 + (* val SOME ori = find_first (test_subset (hd icl)) vors;
10.565 + *)
10.566 + NONE => raise error "nxt_add: EX itm. not(dat(itm)<=dat(ori))"
10.567 + | SOME ori => SOME (geti_ct thy ori (hd icl))
10.568 + end
10.569 +end;
10.570 +
10.571 +
10.572 +
10.573 +fun mk_delete thy "#Given" itm_ = Del_Given (itm_out thy itm_)
10.574 + | mk_delete thy "#Find" itm_ = Del_Find (itm_out thy itm_)
10.575 + | mk_delete thy "#Relate" itm_ = Del_Relation(itm_out thy itm_)
10.576 + | mk_delete thy str _ =
10.577 + raise error ("mk_delete: called with field '"^str^"'");
10.578 +fun mk_additem "#Given" ct = Add_Given ct
10.579 + | mk_additem "#Find" ct = Add_Find ct
10.580 + | mk_additem "#Relate"ct = Add_Relation ct
10.581 + | mk_additem str _ =
10.582 + raise error ("mk_additem: called with field '"^str^"'");
10.583 +
10.584 +
10.585 +
10.586 +
10.587 +
10.588 +(* find the next tac in specify (except nxt_model_pbl)
10.589 + 4.00.: TODO: do not return a pos !!!
10.590 + (sind from DG comes the _OLD_ writepos)*)
10.591 +(*
10.592 +> val (pbl,pbt,mpc) =(pbl',get_pbt cpI,(#ppc o get_met) cmI);
10.593 +> val (dI,pI,mI) = empty_spec;
10.594 +> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*))
10.595 + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec);
10.596 +
10.597 +at Init_Proof:
10.598 +> val met = [];val (pbt,mpc) = (get_pbt pI',(#ppc o get_met) mI');
10.599 +> val (dI,pI,mI) = empty_spec;
10.600 +> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*))
10.601 + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec);
10.602 + *)
10.603 +
10.604 +(*. determine the next step of specification;
10.605 + not done here: Refine_Tacitly (otherwise *** unknown method: (..., no_met))
10.606 +eg. in rootpbl 'no_met':
10.607 +args:
10.608 + preok predicates are _all_ ok, or problem matches completely
10.609 + oris immediately from formalization
10.610 + (dI',pI',mI') specification coming from author/parent-problem
10.611 + (pbl, item lists specified by user
10.612 + met) -"-, tacitly completed by copy_probl
10.613 + (dI,pI,mI) specification explicitly done by the user
10.614 + (pbt, mpc) problem type, guard of method
10.615 +.*)
10.616 +(* val (preok,pbl,pbt,mpc)=(pb,pbl',(#ppc o get_pbt) cpI,(#ppc o get_met) cmI);
10.617 + val (preok,pbl,pbt,mpc)=(pb,pbl',ppc,(#ppc o get_met) cmI);
10.618 + val (Pbl, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) =
10.619 + (p_, pb, oris, (dI',pI',mI'), (probl,meth),
10.620 + (ppc, (#ppc o get_met) cmI), (dI,pI,mI));
10.621 + *)
10.622 +fun nxt_spec Pbl preok (oris:ori list) ((dI',pI',mI'):spec)
10.623 + ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec) =
10.624 + ((*writeln"### nxt_spec Pbl";*)
10.625 + if dI'=e_domID andalso dI=e_domID then (Pbl, Specify_Theory dI')
10.626 + else if pI'=e_pblID andalso pI=e_pblID then (Pbl, Specify_Problem pI')
10.627 + else case find_first (is_error o #5) (pbl:itm list) of
10.628 + SOME (_,_,_,fd,itm_) =>
10.629 + (Pbl, mk_delete
10.630 + (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_)
10.631 + | NONE =>
10.632 + ((*writeln"### nxt_spec is_error NONE";*)
10.633 + case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))
10.634 + oris pbt pbl of
10.635 +(* val SOME (fd,ct') = nxt_add (assoc_thy (if dI=e_domID then dI' else dI))
10.636 + oris pbt pbl;
10.637 + *)
10.638 + SOME (fd,ct') => ((*writeln"### nxt_spec nxt_add SOME";*)
10.639 + (Pbl, mk_additem fd ct'))
10.640 + | NONE => (*pbl-items complete*)
10.641 + if not preok then (Pbl, Refine_Problem pI')
10.642 + else
10.643 + if dI = e_domID then (Pbl, Specify_Theory dI')
10.644 + else if pI = e_pblID then (Pbl, Specify_Problem pI')
10.645 + else if mI = e_metID then (Pbl, Specify_Method mI')
10.646 + else
10.647 + case find_first (is_error o #5) met of
10.648 + SOME (_,_,_,fd,itm_) =>
10.649 + (Met, mk_delete (assoc_thy dI) fd itm_)
10.650 + | NONE =>
10.651 + (case nxt_add (assoc_thy dI) oris mpc met of
10.652 + SOME (fd,ct') => (*30.8.01: pre?!?*)
10.653 + (Met, mk_additem fd ct')
10.654 + | NONE =>
10.655 + ((*Solv 3.4.00*)Met, Apply_Method mI))))
10.656 +(* val preok=pb; val (pbl, met) = (pbl,met');
10.657 + val (pbt,mpc)=((#ppc o get_pbt) cpI,(#ppc o get_met) cmI);
10.658 + val (Met, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) =
10.659 + (p_, pb, oris, (dI',pI',mI'), (probl,meth),
10.660 + (ppc, (#ppc o get_met) cmI), (dI,pI,mI));
10.661 + *)
10.662 + | nxt_spec Met preok oris (dI',pI',mI') (pbl, met) (pbt,mpc) (dI,pI,mI) =
10.663 + ((*writeln"### nxt_spec Met"; *)
10.664 + case find_first (is_error o #5) met of
10.665 + SOME (_,_,_,fd,itm_) =>
10.666 + (Met, mk_delete (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_)
10.667 + | NONE =>
10.668 + case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))oris mpc met of
10.669 + SOME (fd,ct') => (Met, mk_additem fd ct')
10.670 + | NONE =>
10.671 + ((*writeln"### nxt_spec Met: nxt_add NONE";*)
10.672 + if dI = e_domID then (Met, Specify_Theory dI')
10.673 + else if pI = e_pblID then (Met, Specify_Problem pI')
10.674 + else if not preok then (Met, Specify_Method mI)
10.675 + else (Met, Apply_Method mI)));
10.676 +
10.677 +(* di_ pI_ mI_ pos_
10.678 +val itms = [(1,[1],true,"#Find",Cor(e_term,[e_term])):itm,
10.679 + (2,[2],true,"#Find",Syn("empty"))];
10.680 +*)
10.681 +
10.682 +
10.683 +(* ^^^--- aus nnewcode.sml am 30.1.00 ---^^^ *)
10.684 +(*#############################################################*)
10.685 +(*#############################################################*)
10.686 +(* vvv--- aus nnewcode.sml vor 29.1.00 ---vvv *)
10.687 +
10.688 +(*3.3.--
10.689 +fun update_itm (cl,d,ts) ((id,vt,_,sl,Cor (_,_)):itm) =
10.690 + (id,vt,cl,sl,Cor (d,ts)):itm
10.691 + | update_itm (cl,d,ts) (id,vt,_,sl,Syn (_)) =
10.692 + raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^
10.693 + " not not for Syn (s:cterm')")
10.694 + | update_itm (cl,d,ts) (id,vt,_,sl,Typ (_)) =
10.695 + raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^
10.696 + " not not for Typ (s:cterm')")
10.697 + | update_itm (cl,d,ts) (id,vt,_,sl,Fal (_,_)) =
10.698 + (id,vt,cl,sl,Fal (d,ts))
10.699 + | update_itm (cl,d,ts) (id,vt,_,sl,Inc (_,_)) =
10.700 + (id,vt,cl,sl,Inc (d,ts))
10.701 + | update_itm (cl,d,ts) (id,vt,_,sl,Sup (_,_)) =
10.702 + (id,vt,cl,sl,Sup (d,ts));
10.703 +*)
10.704 +
10.705 +
10.706 +
10.707 +
10.708 +fun is_field_correct sel d dscpbt =
10.709 + case assoc (dscpbt, sel) of
10.710 + NONE => false
10.711 + | SOME ds => member op = ds d;
10.712 +
10.713 +(*. update the itm_ already input, all..from ori .*)
10.714 +(* val (id,vt,fd,d,ts) = (i,v,f,d,ts\\ts');
10.715 + *)
10.716 +fun ori_2itm thy itm_ pid all ((id,vt,fd,d,ts):ori) =
10.717 + let
10.718 + val ts' = union op = (ts_in itm_) ts;
10.719 + val pval = pbl_ids' thy d ts'
10.720 + (*WN.9.5.03: FIXXXME [#0, epsilon]
10.721 + here would upd_penv be called for [#0, epsilon] etc. *)
10.722 + val complete = if eq_set op = (ts', all) then true else false;
10.723 + in case itm_ of
10.724 + (Cor _) =>
10.725 + (if fd = "#undef" then (id,vt,complete,fd,Sup(d,ts'))
10.726 + else (id,vt,complete,fd,Cor((d,ts'),(pid, pval)))):itm
10.727 + | (Syn c) => raise error ("ori_2itm wants to overwrite "^c)
10.728 + | (Typ c) => raise error ("ori_2itm wants to overwrite "^c)
10.729 + | (Inc _) => if complete
10.730 + then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval)))
10.731 + else (id,vt,false,fd, Inc ((d,ts'),(pid, pval)))
10.732 + | (Sup ((*_,_*)d,ts')) => (*4.9.01 lost env*)
10.733 + (*if fd = "#undef" then*) (id,vt,complete,fd,Sup(d,ts'))
10.734 + (*else (id,vt,complete,fd,Cor((d,ts'),e))*)
10.735 +(* 28.1.00: not completely clear ---^^^ etc.*)
10.736 +(* 4.9.01: Mis just copied---vvv *)
10.737 + | (Mis _) => if complete
10.738 + then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval)))
10.739 + else (id,vt,false,fd, Inc ((d,ts'),(pid, pval)))
10.740 + end;
10.741 +
10.742 +
10.743 +fun eq1 d (_,(d',_)) = (d = d');
10.744 +fun eq3 f d (_,_,_,f',itm_) = f = f' andalso d = (d_in itm_);
10.745 +
10.746 +
10.747 +(* 'all' ts from ori; ts is the input; (ori carries rest of info)
10.748 + 9.01: this + ori_2itm is _VERY UNCLEAR_ ? overhead ?
10.749 + pval: value for problem-environment _NOT_ checked for 'inter' --
10.750 + -- FIXXME.WN.11.03 the generation of penv has to go to insert_ppc
10.751 + (as it has been done for input_icalhd+insert_ppc' in 11.03)*)
10.752 +(*. is_input ori itms <=>
10.753 + EX itm. (1) ori(field,dsc) = itm(field,dsc) & (2..4)
10.754 + (2) ori(ts) subset itm(ts) --- Err "already input"
10.755 + (3) ori(ts) inter itm(ts) = empty --- new: ori(ts)
10.756 + (4) -"- <> empty --- new: ori(ts) \\ inter .*)
10.757 +(* val(itms,(i,v,f,d,ts)) = (ppc,ori');
10.758 + *)
10.759 +fun is_notyet_input thy (itms:itm list) all ((i,v,f,d,ts):ori) pbt =
10.760 + case find_first (eq1 d) pbt of
10.761 + SOME (_,(_,pid)) =>(* val SOME (_,(_,pid)) = find_first (eq1 d) pbt;
10.762 + val SOME (_,_,_,_,itm_)=find_first (eq3 f d) itms;
10.763 + *)
10.764 + (case find_first (eq3 f d) itms of
10.765 + SOME (_,_,_,_,itm_) =>
10.766 + let
10.767 + val ts' = inter op = (ts_in itm_) ts;
10.768 + in if subset op = (ts, ts')
10.769 + then (((strs2str' o
10.770 + map (Syntax.string_of_term (thy2ctxt thy))) ts')^
10.771 + " already input", e_itm) (*2*)
10.772 + else ("",
10.773 + ori_2itm thy itm_ pid all (i,v,f,d,
10.774 + subtract op = ts' ts)) (*3,4*)
10.775 + end
10.776 + | NONE => ("", ori_2itm thy (Inc ((e_term,[]),(pid,[])))
10.777 + pid all (i,v,f,d,ts)) (*1*)
10.778 + )
10.779 + | NONE => ("", ori_2itm thy (Sup (d,ts))
10.780 + e_term all (i,v,f,d,ts));
10.781 +
10.782 +fun test_types thy (d,ts) =
10.783 + let
10.784 + val s = !show_types; val _ = show_types:= true;
10.785 + val opt = (try (comp_dts thy)) (d,ts);
10.786 + val msg = case opt of
10.787 + SOME _ => ""
10.788 + | NONE => ((Syntax.string_of_term (thy2ctxt thy) d)^" "^
10.789 + ((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts)
10.790 + ^ " is illtyped");
10.791 + val _ = show_types:= s
10.792 + in msg end;
10.793 +
10.794 +
10.795 +
10.796 +fun maxl [] = raise error "maxl of []"
10.797 + | maxl (y::ys) =
10.798 + let fun mx x [] = x
10.799 + | mx x (y::ys) = if x < (y:int) then mx y ys else mx x ys
10.800 + in mx y ys end;
10.801 +
10.802 +
10.803 +(*. is the input term t known in oris ?
10.804 + give feedback on all(?) strange input;
10.805 + return _all_ terms already input to this item (e.g. valuesFor a,b) .*)
10.806 +(*WN.11.03: from lists*)
10.807 +fun is_known thy sel ori t =
10.808 +(* val (ori,t)=(oris,term_of ct);
10.809 + *)
10.810 + let
10.811 + val ots = (distinct o flat o (map #5)) (ori:ori list);
10.812 + val oids = ((map (fst o dest_Free)) o distinct o
10.813 + flat o (map vars)) ots;
10.814 + val (d,ts(*,pval*)) = split_dts thy t;
10.815 + val ids = map (fst o dest_Free)
10.816 + ((distinct o (flat o (map vars))) ts);
10.817 + in if (subtract op = oids ids) <> []
10.818 + then (("identifiers "^(strs2str' (subtract op = oids ids))^
10.819 + " not in example"), e_ori_, [])
10.820 + else
10.821 + if d = e_term
10.822 + then
10.823 + if not (subset op = (map typeless ts, map typeless ots))
10.824 + then (("terms '"^
10.825 + ((strs2str' o (map (Syntax.string_of_term
10.826 + (thy2ctxt thy)))) ts)^
10.827 + "' not in example (typeless)"), e_ori_, [])
10.828 + else (case seek_orits thy sel ts ori of
10.829 + ("", ori_ as (_,_,_,d,ts), all) =>
10.830 + (case test_types thy (d,ts) of
10.831 + "" => ("", ori_, all)
10.832 + | msg => (msg, e_ori_, []))
10.833 + | (msg,_,_) => (msg, e_ori_, []))
10.834 + else
10.835 + if member op = (map #4 ori) d
10.836 + then seek_oridts thy sel (d,ts) ori
10.837 + else ((Syntax.string_of_term (thy2ctxt thy) d)^
10.838 + (*" not in example", e_ori_, []) ///11.11.03*)
10.839 + " not in example", (0,[],sel,d,ts), [])
10.840 + end;
10.841 +
10.842 +
10.843 +(*. for return-value of appl_add .*)
10.844 +datatype additm =
10.845 + Add of itm
10.846 + | Err of string; (*error-message*)
10.847 +
10.848 +
10.849 +(*. add an item; check wrt. oris and pbt .*)
10.850 +
10.851 +(* in contrary to oris<>[] below, this part handles user-input
10.852 + extremely acceptive, i.e. accept input instead error-msg *)
10.853 +fun appl_add thy sel ([]:ori list) ppc pbt ct' =
10.854 +(* val (ppc,pbt,ct',env) = (pbl, (#ppc o get_pbt) cpI, ct, []:envv);
10.855 + !!!! 28.8.01: env tested _minimally_ !!!
10.856 + *)
10.857 + let
10.858 + val i = 1 + (if ppc=[] then 0 else maxl (map #1 ppc));
10.859 + in case parse thy ct' of (*should be done in applicable_in 4.00.FIXME*)
10.860 + NONE => Add (i,[],false,sel,Syn ct')
10.861 +(* val (SOME ct) = parse thy ct';
10.862 + *)
10.863 + | SOME ct =>
10.864 + let
10.865 + val (d,ts(*,pval*)) = split_dts thy (term_of ct);
10.866 + in if d = e_term
10.867 + then Add (i,[],false,sel,Mis (dsc_unknown,hd ts(*24.3.02*)))
10.868 +
10.869 + else
10.870 + (case find_first (eq1 d) pbt of
10.871 + NONE => Add (i,[],true,sel,Sup ((d,ts)))
10.872 + | SOME (f,(_,id)) =>
10.873 +(* val SOME (f,(_,id)) = find_first (eq1 d) pbt;
10.874 + *)
10.875 + let
10.876 + fun eq2 d ((i,_,_,_,itm_):itm) =
10.877 + (d = (d_in itm_)) andalso i<>0;
10.878 + in case find_first (eq2 d) ppc of
10.879 + NONE => Add (i,[],true,f, Cor ((d,ts), (id, (*pval*)
10.880 + pbl_ids' thy d ts)))
10.881 + | SOME (i',_,_,_,itm_) =>
10.882 +(* val SOME (i',_,_,_,itm_) = find_first (eq2 d) ppc;
10.883 + val NONE = find_first (eq2 d) ppc;
10.884 + *)
10.885 + if is_list_dsc d
10.886 + then let val ts = union op = ts (ts_in itm_)
10.887 + in Add (if ts_in itm_ = [] then i else i',
10.888 + [],true,f,Cor ((d, ts), (id, (*pval*)
10.889 + pbl_ids' thy d ts)))
10.890 + end
10.891 + else Add (i',[],true,f,Cor ((d,ts),(id, (*pval*)
10.892 + pbl_ids' thy d ts)))
10.893 + end
10.894 + )
10.895 + end
10.896 + end
10.897 +(*. add ct to ppc .*)
10.898 +(*FIXXME: accept items as Sup, Syn here, too (like appl_add..oris=[] above)*)
10.899 +(* val (ppc,pbt) = (pbl, ppc);
10.900 + val (ppc,pbt) = (met, (#ppc o get_met) cmI);
10.901 +
10.902 + val (ppc,pbt) = (pbl, (#ppc o get_pbt) cpI);
10.903 + *)
10.904 + | appl_add thy sel oris ppc pbt(*only for upd_envv*) ct =
10.905 + let
10.906 + val ctopt = parse thy ct;
10.907 + in case ctopt of
10.908 + NONE => Err ("syntax error in "^ct)
10.909 + | SOME ct =>(* val SOME ct = ctopt;
10.910 + val (msg,ori',all) = is_known thy sel oris (term_of ct);
10.911 + val (msg,itm) = is_notyet_input thy ppc all ori' pbt;
10.912 + *)
10.913 + (case is_known thy sel oris (term_of ct) of
10.914 + ("",ori'(*ts='ct'*), all) =>
10.915 + (case is_notyet_input thy ppc all ori' pbt of
10.916 + ("",itm) => Add itm
10.917 + | (msg,_) => Err msg)
10.918 + | (msg,_,_) => Err msg)
10.919 + end;
10.920 +(*
10.921 +> val (msg,itm) = is_notyet_input thy ppc all ori';
10.922 +val itm = (12,[3],false,"#Relate",Cor (Const #,[#,#])) : itm
10.923 +> val itm_ = #5 itm;
10.924 +> val ts = ts_in itm_;
10.925 +> map (atomty) ts;
10.926 +*)
10.927 +
10.928 +(*---------------------------------------------(4) nach ptyps.sml 23.3.02*)
10.929 +
10.930 +
10.931 +(** make oris from args of the stac SubProblem and from pbt **)
10.932 +
10.933 +(*.can this formal argument (of a model-pattern) be omitted in the arg-list
10.934 + of a SubProblem ? see ME/ptyps.sml 'type met '.*)
10.935 +fun is_copy_named_idstr str =
10.936 + case (rev o explode) str of
10.937 + "_"::_::"_"::_ => true
10.938 + | _ => false;
10.939 +(*> is_copy_named_idstr "v_i_";
10.940 +val it = true : bool
10.941 + > is_copy_named_idstr "e_";
10.942 +val it = false : bool
10.943 + > is_copy_named_idstr "L___";
10.944 +val it = true : bool
10.945 +*)
10.946 +(*.should this formal argument (of a model-pattern) create a new identifier?.*)
10.947 +fun is_copy_named_generating_idstr str =
10.948 + if is_copy_named_idstr str
10.949 + then case (rev o explode) str of
10.950 + "_"::"_"::"_"::_ => false
10.951 + | _ => true
10.952 + else false;
10.953 +(*> is_copy_named_generating_idstr "v_i_";
10.954 +val it = true : bool
10.955 + > is_copy_named_generating_idstr "L___";
10.956 +val it = false : bool
10.957 +*)
10.958 +
10.959 +(*.can this formal argument (of a model-pattern) be omitted in the arg-list
10.960 + of a SubProblem ? see ME/ptyps.sml 'type met '.*)
10.961 +fun is_copy_named (_,(_,t)) = (is_copy_named_idstr o free2str) t;
10.962 +(*.should this formal argument (of a model-pattern) create a new identifier?.*)
10.963 +fun is_copy_named_generating (_,(_,t)) =
10.964 + (is_copy_named_generating_idstr o free2str) t;
10.965 +
10.966 +
10.967 +(*.split type-wrapper from scr-arg and build part of an ori;
10.968 + an type-error is reported immediately, raises an exn,
10.969 + subsequent handling of exn provides 2nd part of error message.*)
10.970 +(*fun mtc thy ((str, (dsc, _)):pat) (ty $ var) = WN100820 made cterm to term
10.971 + (* val (thy, (str, (dsc, _)), (ty $ var)) =
10.972 + (thy, p, a);
10.973 + *)
10.974 + (cterm_of thy (dsc $ var);(*type check*)
10.975 + SOME ((([1], str, dsc, (*[var]*)
10.976 + split_dts' (dsc, var))): preori)(*:ori without leading #*))
10.977 + handle e as TYPE _ =>
10.978 + (writeln (dashs 70^"\n"
10.979 + ^"*** ERROR while creating the items for the model of the ->problem\n"
10.980 + ^"*** from the ->stac with ->typeconstructor in arglist:\n"
10.981 + ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n"
10.982 + ^"*** description: "^(term_detail2str dsc)
10.983 + ^"*** value: "^(term_detail2str var)
10.984 + ^"*** typeconstructor in script: "^(term_detail2str ty)
10.985 + ^"*** checked by theory: "^(theory2str thy)^"\n"
10.986 + ^"*** "^dots 66);
10.987 + print_exn e; (*raises exn again*)
10.988 + NONE);*)
10.989 +fun mtc thy ((str, (dsc, _)):pat) (ty $ var) =
10.990 + (* val (thy, (str, (dsc, _)), (ty $ var)) =
10.991 + (thy, p, a);
10.992 + *)
10.993 + (cterm_of thy (dsc $ var);(*type check*)
10.994 + SOME ((([1], str, dsc, (*[var]*)
10.995 + split_dts' (dsc, var))): preori)(*:ori without leading #*))
10.996 + handle e as TYPE _ =>
10.997 + (writeln (dashs 70^"\n"
10.998 + ^"*** ERROR while creating the items for the model of the ->problem\n"
10.999 + ^"*** from the ->stac with ->typeconstructor in arglist:\n"
10.1000 + ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n"
10.1001 + ^"*** description: "^(term_detail2str dsc)
10.1002 + ^"*** value: "^(term_detail2str var)
10.1003 + ^"*** typeconstructor in script: "^(term_detail2str ty)
10.1004 + ^"*** checked by theory: "^(theory2str thy)^"\n"
10.1005 + ^"*** "^dots 66);
10.1006 + (*WN100820 postponed: print_exn e; raises exn again*)
10.1007 + NONE);
10.1008 +(*> val pbt = (#ppc o get_pbt) ["univariate","equation"];
10.1009 +> val Const ("Script.SubProblem",_) $
10.1010 + (Const ("Pair",_) $ Free (thy', _) $
10.1011 + (Const ("Pair",_) $ pblID' $ metID')) $ ags =
10.1012 + str2term"(SubProblem (SqRoot_,[univariate,equation],\
10.1013 + \[SqRoot_,solve_linear]) [bool_ (x+1- 2=0), real_ x])::bool list";
10.1014 +> val ags = isalist2list ags;
10.1015 +> mtc thy (hd pbt) (hd ags);
10.1016 +val it = SOME ([1],"#Given",Const (#,#),[# $ #]) *)
10.1017 +
10.1018 +(*.match each pat of the model-pattern with an actual argument;
10.1019 + precondition: copy-named vars are filtered out.*)
10.1020 +fun matc thy ([]:pat list) _ (oris:preori list) = oris
10.1021 + | matc thy pbt [] _ =
10.1022 + (writeln (dashs 70);
10.1023 + raise error ("actual arg(s) missing for '"^pats2str pbt
10.1024 + ^"' i.e. should be 'copy-named' by '*_._'"))
10.1025 + | matc thy ((p as (s,(d,t)))::pbt) (a::ags) oris =
10.1026 + (* val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) =
10.1027 + (thy, pbt', ags, []);
10.1028 + (*recursion..*)
10.1029 + val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) =
10.1030 + (thy, pbt, ags, (oris @ [ori]));
10.1031 + *)
10.1032 + (*del?..*)if (is_copy_named_idstr o free2str) t then oris
10.1033 + else(*..del?*) let val opt = mtc thy p a;
10.1034 + in case opt of
10.1035 + (* val SOME ori = mtc thy p a;
10.1036 + *)
10.1037 + SOME ori => matc thy pbt ags (oris @ [ori])
10.1038 + | NONE => [](*WN050903 skipped by exn handled in match_ags*)
10.1039 + end;
10.1040 +(* run subp-rooteq.sml until Init_Proof before ...
10.1041 +> val Nd (PblObj {origin=(oris,_,_),...},_) = pt;(*from test/subp-rooteq.sml*)
10.1042 +> fun xxxfortest (_,a,b,c,d) = (a,b,c,d);val oris = map xxxfortest oris;
10.1043 +
10.1044 + other vars as in mtc ..
10.1045 +> matc thy (drop_last pbt) ags [];
10.1046 +val it = ([[1],"#Given",Const #,[#]),(0,[#],"#Given",Const #,[#])],2)*)
10.1047 +
10.1048 +
10.1049 +(*WN051014 outcommented with redesign copy-named (for omitting '#Find'
10.1050 + in SubProblem);
10.1051 + kept as initial idea for generating x_1, x_2, ... for equations*)
10.1052 +fun cpy_nam (pbt:pat list) (oris:preori list) (p as (field,(dsc,t)):pat) =
10.1053 +(* val ((pbt:pat list), (oris:preori list), ((field,(dsc,t)):pat)) =
10.1054 + (pbt', oris', hd (*!!!!!*) cy);
10.1055 + *)
10.1056 + (if is_copy_named_generating p
10.1057 + then (*WN051014 kept strange old code ...*)
10.1058 + let fun sel (_,_,d,ts) = comp_ts (d, ts)
10.1059 + val cy' = (implode o drop_last o drop_last o explode o free2str) t
10.1060 + val ext = (last_elem o drop_last o explode o free2str) t
10.1061 + val vars' = map (free2str o snd o snd) pbt(*cpy-nam filtered_out*)
10.1062 + val vals = map sel oris
10.1063 + val cy_ext = (free2str o the) (assoc (vars'~~vals, cy'))^"_"^ext
10.1064 + in ([1], field, dsc, [mk_free (type_of t) cy_ext]):preori end
10.1065 + else ([1], field, dsc, [t])
10.1066 + )
10.1067 + handle _ => raise error ("cpy_nam: for "^(term2str t));
10.1068 +
10.1069 +(*> val (field,(dsc,t)) = last_elem pbt;
10.1070 +> cpy_nam pbt (drop_last oris) (field,(dsc,t));
10.1071 +val it = ([1],"#Find",
10.1072 + Const ("Descript.solutions","bool List.list => Tools.toreall"),
10.1073 + [Free ("x_i","bool List.list")]) *)
10.1074 +
10.1075 +
10.1076 +(*.match the actual arguments of a SubProblem with a model-pattern
10.1077 + and create an ori list (in root-pbl created from formalization).
10.1078 + expects ags:pats = 1:1, while copy-named are filtered out of pats;
10.1079 + copy-named pats are appended in order to get them into the model-items.*)
10.1080 +fun match_ags thy (pbt:pat list) ags =
10.1081 +(* val (thy, pbt, ags) = (thy, (#ppc o get_pbt) pI, ags);
10.1082 + val (thy, pbt, ags) = (thy, pats, ags);
10.1083 + *)
10.1084 + let fun flattup (i,(var,bool,str,itm_)) = (i,var,bool,str,itm_);
10.1085 + val pbt' = filter_out is_copy_named pbt;
10.1086 + val cy = filter is_copy_named pbt;
10.1087 + val oris' = matc thy pbt' ags [];
10.1088 + val cy' = map (cpy_nam pbt' oris') cy;
10.1089 + val ors = add_id (oris' @ cy');
10.1090 + (*appended in order to get ^^^^^ them into the model-items*)
10.1091 + in (map flattup ors):ori list end;
10.1092 +(*vars as above ..
10.1093 +> match_ags thy pbt ags;
10.1094 +val it =
10.1095 + [(1,[1],"#Given",Const ("Descript.equality","bool => Tools.una"),
10.1096 + [Const # $ (# $ #) $ Free (#,#)]),
10.1097 + (2,[1],"#Given",Const ("Descript.solveFor","RealDef.real => Tools.una"),
10.1098 + [Free ("x","RealDef.real")]),
10.1099 + (3,[1],"#Find",
10.1100 + Const ("Descript.solutions","bool List.list => Tools.toreall"),
10.1101 + [Free ("x_i","bool List.list")])] : ori list*)
10.1102 +
10.1103 +(*.report part of the error-msg which is not available in match_args.*)
10.1104 +fun match_ags_msg pI stac ags =
10.1105 + let val s = !show_types
10.1106 + val _ = show_types:= true
10.1107 + val pats = (#ppc o get_pbt) pI
10.1108 + val msg = (dots 70^"\n"
10.1109 + ^"*** problem "^strs2str pI^" has the ...\n"
10.1110 + ^"*** model-pattern "^pats2str pats^"\n"
10.1111 + ^"*** stac '"^term2str stac^"' has the ...\n"
10.1112 + ^"*** arg-list "^terms2str ags^"\n"
10.1113 + ^dashs 70)
10.1114 + val _ = show_types:= s
10.1115 + in writeln msg end;
10.1116 +
10.1117 +
10.1118 +(*get the variables out of a pbl_; FIXME.WN.0311: is_copy_named ...obscure!!!*)
10.1119 +fun vars_of_pbl_ pbl_ =
10.1120 + let fun var_of_pbl_ (gfr,(dsc,t)) = t
10.1121 + in ((map var_of_pbl_) o (filter_out is_copy_named)) pbl_ end;
10.1122 +fun vars_of_pbl_' pbl_ =
10.1123 + let fun var_of_pbl_ (gfr,(dsc,t)) = t:term
10.1124 + in ((map var_of_pbl_)(* o (filter_out is_copy_named)*)) pbl_ end;
10.1125 +
10.1126 +fun overwrite_ppc thy itm ppc =
10.1127 + let
10.1128 + fun repl ppc' (_,_,_,_,itm_) [] =
10.1129 + raise error ("overwrite_ppc: " ^ (itm_2str_ (thy2ctxt thy) itm_) ^
10.1130 + " not found")
10.1131 + | repl ppc' itm (p::ppc) =
10.1132 + if (#1 itm) = (#1 (p:itm)) then ppc' @ [itm] @ ppc
10.1133 + else repl (ppc' @ [p]) itm ppc
10.1134 + in repl [] itm ppc end;
10.1135 +
10.1136 +(*10.3.00: insert the already compiled itm into model;
10.1137 + ev. filter_out untouched (in FE: (0,...)) item related to insert-item *)
10.1138 +(* val ppc=pbl;
10.1139 + *)
10.1140 +fun insert_ppc thy itm ppc =
10.1141 + let
10.1142 + fun eq_untouched d ((0,_,_,_,itm_):itm) = (d = d_in itm_)
10.1143 + | eq_untouched _ _ = false;
10.1144 + val ppc' =
10.1145 + (
10.1146 + (*writeln("### insert_ppc: itm= "^(itm2str_ itm));*)
10.1147 + case seek_ppc (#1 itm) ppc of
10.1148 + (* val SOME xxx = seek_ppc (#1 itm) ppc;
10.1149 + *)
10.1150 + SOME _ => (*itm updated in is_notyet_input WN.11.03*)
10.1151 + overwrite_ppc thy itm ppc
10.1152 + | NONE => (ppc @ [itm]));
10.1153 + in filter_out (eq_untouched ((d_in o #5) itm)) ppc' end;
10.1154 +
10.1155 +(*from Isabelle/src/Pure/library.ML, _appends_ a new element*)
10.1156 +fun gen_ins' eq (x, xs) = if gen_mem eq (x, xs) then xs else xs @ [x];
10.1157 +
10.1158 +fun eq_dsc ((_,_,_,_,itm_):itm, (_,_,_,_,iitm_):itm) =
10.1159 + (d_in itm_) = (d_in iitm_);
10.1160 +(*insert_ppc = insert_ppc' for appl_add', input_icalhd 11.03,
10.1161 + handles superfluous items carelessly*)
10.1162 +fun insert_ppc' itm itms = gen_ins' eq_dsc (itm, itms);
10.1163 +(* val eee = op=;
10.1164 + > gen_ins' eee (4,[1,3,5,7]);
10.1165 +val it = [1, 3, 5, 7, 4] : int list*)
10.1166 +
10.1167 +
10.1168 +(*. output the headline to a ppc .*)
10.1169 +fun header p_ pI mI =
10.1170 + case p_ of Pbl => Problem (if pI = e_pblID then [] else pI)
10.1171 + | Met => Method mI
10.1172 + | pos => raise error ("header called with "^ pos_2str pos);
10.1173 +
10.1174 +
10.1175 +
10.1176 +(* test-printouts ---
10.1177 +val _=writeln("### insert_ppc: (d,ts)="^((Syntax.string_of_term (thy2ctxt thy))(comp_dts thy(d,ts))));
10.1178 + val _=writeln("### insert_ppc: pts= "^
10.1179 +(strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) pts);
10.1180 +
10.1181 +
10.1182 + val sel = "#Given"; val Add_Given' ct = m;
10.1183 +
10.1184 + val sel = "#Find"; val Add_Find' (ct,_) = m;
10.1185 + val (p,_) = p;
10.1186 + val (_,_,f,nxt',_,pt')= specify_additem sel (ct,[]) (p,Pbl(*!!!!!!!*)) c pt;
10.1187 +--------------
10.1188 + val sel = "#Given"; val Add_Given' (ct,_) = nxt; val (p,_) = p;
10.1189 + *)
10.1190 +fun specify_additem sel (ct,_) (p,Met) c pt =
10.1191 + let
10.1192 + val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_),
10.1193 + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
10.1194 + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
10.1195 + (*val ppt = if pI = e_pblID then get_pbt pI' else get_pbt pI;*)
10.1196 + val cpI = if pI = e_pblID then pI' else pI;
10.1197 + val cmI = if mI = e_metID then mI' else mI;
10.1198 + val {ppc,pre,prls,...} = get_met cmI
10.1199 + in case appl_add thy sel oris met ppc ct of
10.1200 + Add itm (*..union old input *) =>
10.1201 + let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct;
10.1202 + *)
10.1203 + val met' = insert_ppc thy itm met;
10.1204 + (*val pt' = update_met pt p met';*)
10.1205 + val ((p,Met),_,_,pt') =
10.1206 + generate1 thy (case sel of
10.1207 + "#Given" => Add_Given' (ct, met')
10.1208 + | "#Find" => Add_Find' (ct, met')
10.1209 + | "#Relate"=> Add_Relation'(ct, met'))
10.1210 + Uistate (p,Met) pt
10.1211 + val pre' = check_preconds thy prls pre met'
10.1212 + val pb = foldl and_ (true, map fst pre')
10.1213 + (*val _=writeln("@@@ specify_additem: Met Add before nxt_spec")*)
10.1214 + val (p_,nxt) =
10.1215 + nxt_spec Met pb oris (dI',pI',mI') (pbl,met')
10.1216 + ((#ppc o get_pbt) cpI,ppc) (dI,pI,mI);
10.1217 + in ((p,p_), ((p,p_),Uistate),
10.1218 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
10.1219 + (Method cmI, itms2itemppc thy met' pre'))),
10.1220 + nxt,Safe,pt') end
10.1221 + | Err msg =>
10.1222 + let val pre' = check_preconds thy prls pre met
10.1223 + val pb = foldl and_ (true, map fst pre')
10.1224 + (*val _=writeln("@@@ specify_additem: Met Err before nxt_spec")*)
10.1225 + val (p_,nxt) =
10.1226 + nxt_spec Met pb oris (dI',pI',mI') (pbl,met)
10.1227 + ((#ppc o get_pbt) cpI,(#ppc o get_met) cmI) (dI,pI,mI);
10.1228 + in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end
10.1229 + end
10.1230 +(* val (p,_) = p;
10.1231 + *)
10.1232 +| specify_additem sel (ct,_) (p,_(*Frm, Pbl*)) c pt =
10.1233 + let
10.1234 + val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_),
10.1235 + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
10.1236 + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
10.1237 + val cpI = if pI = e_pblID then pI' else pI;
10.1238 + val cmI = if mI = e_metID then mI' else mI;
10.1239 + val {ppc,where_,prls,...} = get_pbt cpI;
10.1240 + in case appl_add thy sel oris pbl ppc ct of
10.1241 + Add itm (*..union old input *) =>
10.1242 + (* val Add itm = appl_add thy sel oris pbl ppc ct;
10.1243 + *)
10.1244 + let
10.1245 + (*val _= writeln("###specify_additem: itm= "^(itm2str_ itm));*)
10.1246 + val pbl' = insert_ppc thy itm pbl
10.1247 + val ((p,Pbl),_,_,pt') =
10.1248 + generate1 thy (case sel of
10.1249 + "#Given" => Add_Given' (ct, pbl')
10.1250 + | "#Find" => Add_Find' (ct, pbl')
10.1251 + | "#Relate"=> Add_Relation'(ct, pbl'))
10.1252 + Uistate (p,Pbl) pt
10.1253 + val pre = check_preconds thy prls where_ pbl'
10.1254 + val pb = foldl and_ (true, map fst pre)
10.1255 + (*val _=writeln("@@@ specify_additem: Pbl Add before nxt_spec")*)
10.1256 + val (p_,nxt) =
10.1257 + nxt_spec Pbl pb oris (dI',pI',mI') (pbl',met)
10.1258 + (ppc,(#ppc o get_met) cmI) (dI,pI,mI);
10.1259 + val ppc = if p_= Pbl then pbl' else met;
10.1260 + in ((p,p_), ((p,p_),Uistate),
10.1261 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
10.1262 + (header p_ pI cmI,
10.1263 + itms2itemppc thy ppc pre))), nxt,Safe,pt') end
10.1264 +
10.1265 + | Err msg =>
10.1266 + let val pre = check_preconds thy prls where_ pbl
10.1267 + val pb = foldl and_ (true, map fst pre)
10.1268 + (*val _=writeln("@@@ specify_additem: Pbl Err before nxt_spec")*)
10.1269 + val (p_,nxt) =
10.1270 + nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met)
10.1271 + (ppc,(#ppc o get_met) cmI) (dI,pI,mI);
10.1272 + in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end
10.1273 + end;
10.1274 +(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt;
10.1275 + val (_,_,f,nxt',_,pt')= specify_additem sel ct (p,Met) c pt;
10.1276 + *)
10.1277 +
10.1278 +(* ori
10.1279 +val (msg,itm) = appl_add thy sel oris ppc ct;
10.1280 +val (Cor(d,ts)) = #5 itm;
10.1281 +map (atomty) ts;
10.1282 +
10.1283 +pre
10.1284 +*)
10.1285 +
10.1286 +
10.1287 +(* val Init_Proof' (fmz,(dI',pI',mI')) = m;
10.1288 + specify (Init_Proof' (fmz,(dI',pI',mI'))) e_pos' [] EmptyPtree;
10.1289 + *)
10.1290 +fun specify (Init_Proof' (fmz,(dI',pI',mI'))) (_:pos') (_:cid) (_:ptree)=
10.1291 + let (* either """"""""""""""" all empty or complete *)
10.1292 + val thy = assoc_thy dI';
10.1293 + val oris = if dI' = e_domID orelse pI' = e_pblID then ([]:ori list)
10.1294 + else prep_ori fmz thy ((#ppc o get_pbt) pI');
10.1295 + val (pt,c) = cappend_problem e_ptree [] e_istate (fmz,(dI',pI',mI'))
10.1296 + (oris,(dI',pI',mI'),e_term);
10.1297 + val {ppc,prls,where_,...} = get_pbt pI'
10.1298 + (*val pbl = init_pbl ppc; WN.9.03: done in Model/Refine_Problem
10.1299 + val pt = update_pbl pt [] pbl;
10.1300 + val pre = check_preconds thy prls where_ pbl
10.1301 + val pb = foldl and_ (true, map fst pre)*)
10.1302 + val (pbl, pre, pb) = ([], [], false)
10.1303 + in case mI' of
10.1304 + ["no_met"] =>
10.1305 + (([],Pbl), (([],Pbl),Uistate),
10.1306 + Form' (PpcKF (0,EdUndef,(length []),Nundef,
10.1307 + (Problem [], itms2itemppc (assoc_thy dI') pbl pre))),
10.1308 + Refine_Tacitly pI', Safe,pt)
10.1309 + | _ =>
10.1310 + (([],Pbl), (([],Pbl),Uistate),
10.1311 + Form' (PpcKF (0,EdUndef,(length []),Nundef,
10.1312 + (Problem [], itms2itemppc (assoc_thy dI') pbl pre))),
10.1313 + Model_Problem,
10.1314 + Safe,pt)
10.1315 + end
10.1316 + (*ONLY for STARTING modeling phase*)
10.1317 + | specify (Model_Problem' (_,pbl,met)) (pos as (p,p_)) c pt =
10.1318 + let (* val (Model_Problem' (_,pbl), pos as (p,p_)) = (m, (p,p_));
10.1319 + *)
10.1320 + val (PblObj{origin=(oris,(dI',pI',mI'),_), spec=(dI,_,_),...}) =
10.1321 + get_obj I pt p
10.1322 + val thy' = if dI = e_domID then dI' else dI
10.1323 + val thy = assoc_thy thy'
10.1324 + val {ppc,prls,where_,...} = get_pbt pI'
10.1325 + val pre = check_preconds thy prls where_ pbl
10.1326 + val pb = foldl and_ (true, map fst pre)
10.1327 + val ((p,_),_,_,pt) =
10.1328 + generate1 thy (Model_Problem'([],pbl,met)) Uistate pos pt
10.1329 + val (_,nxt) = nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met)
10.1330 + (ppc,(#ppc o get_met) mI') (dI',pI',mI');
10.1331 + in ((p,Pbl), ((p,p_),Uistate),
10.1332 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
10.1333 + (Problem pI', itms2itemppc (assoc_thy dI') pbl pre))),
10.1334 + nxt, Safe, pt) end
10.1335 +
10.1336 +(*. called only if no_met is specified .*)
10.1337 + | specify (Refine_Tacitly' (pI,pIre,_,_,_)) (pos as (p,_)) c pt =
10.1338 + let (* val Refine_Tacitly' (pI,pIre,_,_,_) = m;
10.1339 + *)
10.1340 + val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met, ...}) =
10.1341 + get_obj I pt p;
10.1342 + val {prls,met,ppc,thy,where_,...} = get_pbt pIre
10.1343 + (*val pbl = init_pbl ppc --- Model_Problem recognizes probl=[]*)
10.1344 + (*val pt = update_pbl pt p pbl;
10.1345 + val pt = update_orispec pt p
10.1346 + (string_of_thy thy, pIre,
10.1347 + if length met = 0 then e_metID else hd met);*)
10.1348 + val (domID, metID) = (string_of_thy thy,
10.1349 + if length met = 0 then e_metID else hd met)
10.1350 + val ((p,_),_,_,pt) =
10.1351 + generate1 thy (Refine_Tacitly'(pI,pIre,domID,metID,(*pbl*)[]))
10.1352 + Uistate pos pt
10.1353 + (*val pre = check_preconds thy prls where_ pbl
10.1354 + val pb = foldl and_ (true, map fst pre)*)
10.1355 + val (pbl, pre, pb) = ([], [], false)
10.1356 + in ((p,Pbl), (pos,Uistate),
10.1357 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
10.1358 + (Problem pIre, itms2itemppc (assoc_thy dI') pbl pre))),
10.1359 + Model_Problem, Safe, pt) end
10.1360 +
10.1361 + | specify (Refine_Problem' (rfd as (pI,_))) pos c pt =
10.1362 + let val (pos,_,_,pt) = generate1 (assoc_thy "Isac.thy")
10.1363 + (Refine_Problem' rfd) Uistate pos pt
10.1364 + in (pos(*p,Pbl*), (pos(*p,Pbl*),Uistate), Problems (RefinedKF rfd),
10.1365 + Model_Problem, Safe, pt) end
10.1366 +
10.1367 +(* val (Specify_Problem' (pI, (ok, (itms, pre)))) = nxt; val (p,_) = p;
10.1368 + val (Specify_Problem' (pI, (ok, (itms, pre)))) = m; val (p,_) = p;
10.1369 + *)
10.1370 + | specify (Specify_Problem' (pI, (ok, (itms, pre)))) (pos as (p,_)) c pt =
10.1371 + let val (PblObj {origin=(oris,(dI',pI',mI'),_), spec=(dI,_,mI),
10.1372 + meth=met, ...}) = get_obj I pt p;
10.1373 + (*val pt = update_pbl pt p itms;
10.1374 + val pt = update_pblID pt p pI;*)
10.1375 + val thy = assoc_thy dI
10.1376 + val ((p,Pbl),_,_,pt)=
10.1377 + generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate pos pt
10.1378 + val dI'' = assoc_thy (if dI=e_domID then dI' else dI);
10.1379 + val mI'' = if mI=e_metID then mI' else mI;
10.1380 + (*val _=writeln("@@@ specify (Specify_Problem) before nxt_spec")*)
10.1381 + val (_,nxt) = nxt_spec Pbl ok oris (dI',pI',mI') (itms, met)
10.1382 + ((#ppc o get_pbt) pI,(#ppc o get_met) mI'') (dI,pI,mI);
10.1383 + in ((p,Pbl), (pos,Uistate),
10.1384 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
10.1385 + (Problem pI, itms2itemppc dI'' itms pre))),
10.1386 + nxt, Safe, pt) end
10.1387 +(* val Specify_Method' mID = nxt; val (p,_) = p;
10.1388 + val Specify_Method' mID = m;
10.1389 + specify (Specify_Method' mID) (p,p_) c pt;
10.1390 + *)
10.1391 + | specify (Specify_Method' (mID,_,_)) (pos as (p,_)) c pt =
10.1392 + let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI),
10.1393 + meth=met, ...}) = get_obj I pt p;
10.1394 + val {ppc,pre,prls,...} = get_met mID
10.1395 + val thy = assoc_thy dI
10.1396 + val oris = add_field' thy ppc oris;
10.1397 + (*val pt = update_oris pt p oris; 20.3.02: repl. "#undef"*)
10.1398 + val dI'' = if dI=e_domID then dI' else dI;
10.1399 + val pI'' = if pI = e_pblID then pI' else pI;
10.1400 + val met = if met=[] then pbl else met;
10.1401 + val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris;
10.1402 + (*val pt = update_met pt p itms;
10.1403 + val pt = update_metID pt p mID*)
10.1404 + val (pos,_,_,pt)=
10.1405 + generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt
10.1406 + (*val _=writeln("@@@ specify (Specify_Method) before nxt_spec")*)
10.1407 + val (_,nxt) = nxt_spec Met (*ok*)true oris (dI',pI',mI') (pbl, itms)
10.1408 + ((#ppc o get_pbt) pI'',ppc) (dI'',pI'',mID);
10.1409 + in (pos, (pos,Uistate),
10.1410 + Form' (PpcKF (0,EdUndef,(length p),Nundef,
10.1411 + (Method mID, itms2itemppc (assoc_thy dI'') itms pre'))),
10.1412 + nxt, Safe, pt) end
10.1413 +(* val Add_Find' ct = nxt; val sel = "#Find";
10.1414 + *)
10.1415 + | specify (Add_Given' ct) p c pt = specify_additem "#Given" ct p c pt
10.1416 + | specify (Add_Find' ct) p c pt = specify_additem "#Find" ct p c pt
10.1417 + | specify (Add_Relation' ct) p c pt=specify_additem"#Relate"ct p c pt
10.1418 +(* val Specify_Theory' domID = m;
10.1419 + val (Specify_Theory' domID, (p,p_)) = (m, pos);
10.1420 + *)
10.1421 + | specify (Specify_Theory' domID) (pos as (p,p_)) c pt =
10.1422 + let val p_ = case p_ of Met => Met | _ => Pbl
10.1423 + val thy = assoc_thy domID;
10.1424 + val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met,
10.1425 + probl=pbl, spec=(dI,pI,mI),...}) = get_obj I pt p;
10.1426 + val mppc = case p_ of Met => met | _ => pbl;
10.1427 + val cpI = if pI = e_pblID then pI' else pI;
10.1428 + val {prls=per,ppc,where_=pwh,...} = get_pbt cpI
10.1429 + val cmI = if mI = e_metID then mI' else mI;
10.1430 + val {prls=mer,ppc=mpc,pre=mwh,...} = get_met cmI
10.1431 + val pre =
10.1432 + case p_ of
10.1433 + Met => (check_preconds thy mer mwh met)
10.1434 + | _ => (check_preconds thy per pwh pbl)
10.1435 + val pb = foldl and_ (true, map fst pre)
10.1436 + in if domID = dI
10.1437 + then let
10.1438 + (*val _=writeln("@@@ specify (Specify_Theory) THEN before nxt_spec")*)
10.1439 + val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI')
10.1440 + (pbl,met) (ppc,mpc) (dI,pI,mI);
10.1441 + in ((p,p_), (pos,Uistate),
10.1442 + Form'(PpcKF (0,EdUndef,(length p), Nundef,
10.1443 + (header p_ pI cmI, itms2itemppc thy mppc pre))),
10.1444 + nxt,Safe,pt) end
10.1445 + else (*FIXME: check ppc wrt. (new!) domID ..? still parsable?*)
10.1446 + let
10.1447 + (*val pt = update_domID pt p domID;11.8.03*)
10.1448 + val ((p,p_),_,_,pt) = generate1 thy (Specify_Theory' domID)
10.1449 + Uistate (p,p_) pt
10.1450 + (*val _=writeln("@@@ specify (Specify_Theory) ELSE before nxt_spec")*)
10.1451 + val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') (pbl,met)
10.1452 + (ppc,mpc) (domID,pI,mI);
10.1453 + in ((p,p_), (pos,Uistate),
10.1454 + Form' (PpcKF (0, EdUndef, (length p),Nundef,
10.1455 + (header p_ pI cmI, itms2itemppc thy mppc pre))),
10.1456 + nxt, Safe,pt) end
10.1457 + end
10.1458 +(* itms2itemppc thy [](*mpc*) pre
10.1459 + *)
10.1460 + | specify m' _ _ _ =
10.1461 + raise error ("specify: not impl. for "^tac_2str m');
10.1462 +
10.1463 +(* val (sel, Add_Given ct, ptp as (pt,(p,Pbl))) = ("#Given", tac, ptp);
10.1464 + val (sel, Add_Find ct, ptp as (pt,(p,Pbl))) = ("#Find", tac, ptp);
10.1465 + *)
10.1466 +fun nxt_specif_additem sel ct (ptp as (pt,(p,Pbl))) =
10.1467 + let
10.1468 + val (PblObj{meth=met,origin=(oris,(dI',pI',_),_),
10.1469 + probl=pbl,spec=(dI,pI,_),...}) = get_obj I pt p;
10.1470 + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
10.1471 + val cpI = if pI = e_pblID then pI' else pI;
10.1472 + in case appl_add thy sel oris pbl ((#ppc o get_pbt) cpI) ct of
10.1473 + Add itm (*..union old input *) =>
10.1474 +(* val Add itm = appl_add thy sel oris pbl ppc ct;
10.1475 + *)
10.1476 + let
10.1477 + (*val _=writeln("###nxt_specif_additem: itm= "^(itm2str_ itm));*)
10.1478 + val pbl' = insert_ppc thy itm pbl
10.1479 + val (tac,tac_) =
10.1480 + case sel of
10.1481 + "#Given" => (Add_Given ct, Add_Given' (ct, pbl'))
10.1482 + | "#Find" => (Add_Find ct, Add_Find' (ct, pbl'))
10.1483 + | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, pbl'))
10.1484 + val ((p,Pbl),c,_,pt') =
10.1485 + generate1 thy tac_ Uistate (p,Pbl) pt
10.1486 + in ([(tac,tac_,((p,Pbl),Uistate))], c, (pt',(p,Pbl))):calcstate' end
10.1487 +
10.1488 + | Err msg =>
10.1489 + (*TODO.WN03 pass error-msgs to the frontend..
10.1490 + FIXME ..and dont abuse a tactic for that purpose*)
10.1491 + ([(Tac msg,
10.1492 + Tac_ (theory "Pure", msg,msg,msg),
10.1493 + (e_pos', e_istate))], [], ptp)
10.1494 + end
10.1495 +
10.1496 +(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt;
10.1497 + val (_,_,f,nxt',_,pt')= nxt_specif_additem sel ct (p,Met) c pt;
10.1498 + *)
10.1499 + | nxt_specif_additem sel ct (ptp as (pt,(p,Met))) =
10.1500 + let
10.1501 + val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_),
10.1502 + probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
10.1503 + val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
10.1504 + val cmI = if mI = e_metID then mI' else mI;
10.1505 + in case appl_add thy sel oris met ((#ppc o get_met) cmI) ct of
10.1506 + Add itm (*..union old input *) =>
10.1507 + let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct;
10.1508 + *)
10.1509 + val met' = insert_ppc thy itm met;
10.1510 + val (tac,tac_) =
10.1511 + case sel of
10.1512 + "#Given" => (Add_Given ct, Add_Given' (ct, met'))
10.1513 + | "#Find" => (Add_Find ct, Add_Find' (ct, met'))
10.1514 + | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, met'))
10.1515 + val ((p,Met),c,_,pt') =
10.1516 + generate1 thy tac_ Uistate (p,Met) pt
10.1517 + in ([(tac,tac_,((p,Met), Uistate))], c, (pt',(p,Met))) end
10.1518 +
10.1519 + | Err msg => ([(*tacis*)], [], ptp)
10.1520 + (*nxt_me collects tacis until not hide; here just no progress*)
10.1521 + end;
10.1522 +
10.1523 +(* ori
10.1524 +val (msg,itm) = appl_add thy sel oris ppc ct;
10.1525 +val (Cor(d,ts)) = #5 itm;
10.1526 +map (atomty) ts;
10.1527 +
10.1528 +pre
10.1529 +*)
10.1530 +fun ori2Coritm pbt ((i,v,f,d,ts):ori) =
10.1531 + (i,v,true,f, Cor ((d,ts),(((snd o snd o the o (find_first (eq1 d))) pbt)
10.1532 + handle _ => raise error ("ori2Coritm: dsc "^
10.1533 + term2str d^
10.1534 + "in ori, but not in pbt")
10.1535 + ,ts))):itm;
10.1536 +fun ori2Coritm (pbt:pat list) ((i,v,f,d,ts):ori) =
10.1537 + ((i,v,true,f, Cor ((d,ts),((snd o snd o the o
10.1538 + (find_first (eq1 d))) pbt,ts))):itm)
10.1539 + handle _ => (*dsc in oris, but not in pbl pat list: keep this dsc*)
10.1540 + ((i,v,true,f, Cor ((d,ts),(d,ts))):itm);
10.1541 +
10.1542 +
10.1543 +(*filter out oris which have same description in itms*)
10.1544 +fun filter_outs oris [] = oris
10.1545 + | filter_outs oris (i::itms) =
10.1546 + let val ors = filter_out ((curry op= ((d_in o #5) (i:itm))) o
10.1547 + (#4:ori -> term)) oris;
10.1548 + in filter_outs ors itms end;
10.1549 +
10.1550 +fun memI a b = member op = a b;
10.1551 +(*filter oris which are in pbt, too*)
10.1552 +fun filter_pbt oris pbt =
10.1553 + let val dscs = map (fst o snd) pbt
10.1554 + in filter ((memI dscs) o (#4: ori -> term)) oris end;
10.1555 +
10.1556 +(*.combine itms from pbl + met and complete them wrt. pbt.*)
10.1557 +(*FIXXXME.WN031205 complete_metitms doesnt handle incorrect itms !*)
10.1558 +local infix mem;
10.1559 +fun x mem [] = false
10.1560 + | x mem (y :: ys) = x = y orelse x mem ys;
10.1561 +in
10.1562 +fun complete_metitms (oris:ori list) (pits:itm list) (mits:itm list) met =
10.1563 +(* val met = (#ppc o get_met) ["DiffApp","max_by_calculus"];
10.1564 + *)
10.1565 + let val vat = max_vt pits;
10.1566 + val itms = pits @
10.1567 + (filter ((curry (op mem) vat) o (#2:itm -> int list)) mits);
10.1568 + val ors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris;
10.1569 + val os = filter_outs ors itms;
10.1570 + (*WN.12.03?: does _NOT_ add itms from met ?!*)
10.1571 + in itms @ (map (ori2Coritm met) os) end
10.1572 +end;
10.1573 +
10.1574 +
10.1575 +
10.1576 +(*.complete model and guard of a calc-head .*)
10.1577 +local infix mem;
10.1578 +fun x mem [] = false
10.1579 + | x mem (y :: ys) = x = y orelse x mem ys;
10.1580 +in
10.1581 +fun complete_mod_ (oris, mpc, ppc, probl) =
10.1582 + let val pits = filter_out ((curry op= false) o (#3: itm -> bool)) probl
10.1583 + val vat = if probl = [] then 1 else max_vt probl
10.1584 + val pors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris
10.1585 + val pors = filter_outs pors pits (*which are in pbl already*)
10.1586 + val pors = (filter_pbt pors ppc) (*which are in pbt, too*)
10.1587 +
10.1588 + val pits = pits @ (map (ori2Coritm ppc) pors)
10.1589 + val mits = complete_metitms oris pits [] mpc
10.1590 + in (pits, mits) end
10.1591 +end;
10.1592 +
10.1593 +fun some_spec ((odI, opI, omI):spec) ((dI, pI, mI):spec) =
10.1594 + (if dI = e_domID then odI else dI,
10.1595 + if pI = e_pblID then opI else pI,
10.1596 + if mI = e_metID then omI else mI):spec;
10.1597 +
10.1598 +
10.1599 +(*.find a next applicable tac (for calcstate) and update ptree
10.1600 + (for ev. finding several more tacs due to hide).*)
10.1601 +(*FIXXXME: unify ... fun nxt_specif = nxt_spec + applicable_in + specify !!*)
10.1602 +(*WN.24.10.03 ~~~~~~~~~~~~~~ -> tac -> tac_ -> -"- as arg*)
10.1603 +(*WN.24.10.03 fun nxt_solv = ...................................??*)
10.1604 +fun nxt_specif (tac as Model_Problem) (pt, pos as (p,p_)) =
10.1605 + let
10.1606 + val (PblObj{origin=(oris,ospec,_),probl,spec,...}) = get_obj I pt p
10.1607 + val (dI,pI,mI) = some_spec ospec spec
10.1608 + val thy = assoc_thy dI
10.1609 + val mpc = (#ppc o get_met) mI (*just for reuse complete_mod_*)
10.1610 + val {cas,ppc,...} = get_pbt pI
10.1611 + val pbl = init_pbl ppc (*fill in descriptions*)
10.1612 + (*--------------if you think, this should be done by the Dialog
10.1613 + in the java front-end, search there for WN060225-modelProblem----*)
10.1614 + val (pbl,met) = case cas of NONE => (pbl,[])
10.1615 + | _ => complete_mod_ (oris, mpc, ppc, probl)
10.1616 + (*----------------------------------------------------------------*)
10.1617 + val tac_ = Model_Problem' (pI, pbl, met)
10.1618 + val (pos,c,_,pt) = generate1 thy tac_ Uistate pos pt
10.1619 + in ([(tac,tac_, (pos, Uistate))], c, (pt,pos)):calcstate' end
10.1620 +
10.1621 +(* val Add_Find ct = tac;
10.1622 + *)
10.1623 + | nxt_specif (Add_Given ct) ptp = nxt_specif_additem "#Given" ct ptp
10.1624 + | nxt_specif (Add_Find ct) ptp = nxt_specif_additem "#Find" ct ptp
10.1625 + | nxt_specif (Add_Relation ct) ptp = nxt_specif_additem"#Relate" ct ptp
10.1626 +
10.1627 +(*. called only if no_met is specified .*)
10.1628 + | nxt_specif (Refine_Tacitly pI) (ptp as (pt, pos as (p,_))) =
10.1629 + let val (PblObj {origin = (oris, (dI,_,_),_), ...}) = get_obj I pt p
10.1630 + val opt = refine_ori oris pI
10.1631 + in case opt of
10.1632 + SOME pI' =>
10.1633 + let val {met,ppc,...} = get_pbt pI'
10.1634 + val pbl = init_pbl ppc
10.1635 + (*val pt = update_pbl pt p pbl ..done by Model_Problem*)
10.1636 + val mI = if length met = 0 then e_metID else hd met
10.1637 + val thy = assoc_thy dI
10.1638 + val (pos,c,_,pt) =
10.1639 + generate1 thy (Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[]))
10.1640 + Uistate pos pt
10.1641 + in ([(Refine_Tacitly pI, Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[]),
10.1642 + (pos, Uistate))], c, (pt,pos)) end
10.1643 + | NONE => ([], [], ptp)
10.1644 + end
10.1645 +
10.1646 + | nxt_specif (Refine_Problem pI) (ptp as (pt, pos as (p,_))) =
10.1647 + let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_),
10.1648 + probl, ...}) = get_obj I pt p
10.1649 + val thy = if dI' = e_domID then dI else dI'
10.1650 + in case refine_pbl (assoc_thy thy) pI probl of
10.1651 + NONE => ([], [], ptp)
10.1652 + | SOME (rfd as (pI',_)) =>
10.1653 + let val (pos,c,_,pt) =
10.1654 + generate1 (assoc_thy thy)
10.1655 + (Refine_Problem' rfd) Uistate pos pt
10.1656 + in ([(Refine_Problem pI, Refine_Problem' rfd,
10.1657 + (pos, Uistate))], c, (pt,pos)) end
10.1658 + end
10.1659 +
10.1660 + | nxt_specif (Specify_Problem pI) (pt, pos as (p,_)) =
10.1661 + let val (PblObj {origin=(oris,(dI,_,_),_),spec=(dI',pI',_),
10.1662 + probl, ...}) = get_obj I pt p;
10.1663 + val thy = assoc_thy (if dI' = e_domID then dI else dI');
10.1664 + val {ppc,where_,prls,...} = get_pbt pI
10.1665 + val pbl as (_,(itms,_)) =
10.1666 + if pI'=e_pblID andalso pI=e_pblID
10.1667 + then (false, (init_pbl ppc, []))
10.1668 + else match_itms_oris thy probl (ppc,where_,prls) oris(*FIXXXXXME?*)
10.1669 + (*FIXXXME~~~~~~~~~~~~~~~: take pbl and compare with new pI WN.8.03*)
10.1670 + val ((p,Pbl),c,_,pt)=
10.1671 + generate1 thy (Specify_Problem' (pI, pbl)) Uistate pos pt
10.1672 + in ([(Specify_Problem pI, Specify_Problem' (pI, pbl),
10.1673 + (pos,Uistate))], c, (pt,pos)) end
10.1674 +
10.1675 + (*transfers oris (not required in pbl) to met-model for script-env
10.1676 + FIXME.WN.8.03: application of several mIDs to SAME model?*)
10.1677 + | nxt_specif (Specify_Method mID) (ptp as (pt, pos as (p,_))) =
10.1678 + let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI),
10.1679 + meth=met, ...}) = get_obj I pt p;
10.1680 + val {ppc,pre,prls,...} = get_met mID
10.1681 + val thy = assoc_thy dI
10.1682 + val oris = add_field' thy ppc oris;
10.1683 + val dI'' = if dI=e_domID then dI' else dI;
10.1684 + val pI'' = if pI = e_pblID then pI' else pI;
10.1685 + val met = if met=[] then pbl else met;(*WN0602 what if more itms in met?*)
10.1686 + val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris;
10.1687 + val (pos,c,_,pt)=
10.1688 + generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt
10.1689 + in ([(Specify_Method mID, Specify_Method' (mID, oris, itms),
10.1690 + (pos,Uistate))], c, (pt,pos)) end
10.1691 +
10.1692 + | nxt_specif (Specify_Theory dI) (pt, pos as (p,Pbl)) =
10.1693 + let val (dI',_,_) = get_obj g_spec pt p
10.1694 + val (pos,c,_,pt) =
10.1695 + generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI)
10.1696 + Uistate pos pt
10.1697 + in (*FIXXXME: check if pbl can still be parsed*)
10.1698 + ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c,
10.1699 + (pt, pos)) end
10.1700 +
10.1701 + | nxt_specif (Specify_Theory dI) (pt, pos as (p,Met)) =
10.1702 + let val (dI',_,_) = get_obj g_spec pt p
10.1703 + val (pos,c,_,pt) =
10.1704 + generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI)
10.1705 + Uistate pos pt
10.1706 + in (*FIXXXME: check if met can still be parsed*)
10.1707 + ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c,
10.1708 + (pt, pos)) end
10.1709 +
10.1710 + | nxt_specif m' _ =
10.1711 + raise error ("nxt_specif: not impl. for "^tac2str m');
10.1712 +
10.1713 +(*.get the values from oris; handle the term list w.r.t. penv.*)
10.1714 +
10.1715 +local infix mem;
10.1716 +fun x mem [] = false
10.1717 + | x mem (y :: ys) = x = y orelse x mem ys;
10.1718 +in
10.1719 +fun vals_of_oris oris =
10.1720 + ((map (mkval' o (#5:ori -> term list))) o
10.1721 + (filter ((curry (op mem) 1) o (#2:ori -> int list)))) oris
10.1722 +end;
10.1723 +
10.1724 +
10.1725 +
10.1726 +(*.create a calc-tree with oris via an cas.refined pbl.*)
10.1727 +fun nxt_specify_init_calc (([],(dI,pI,mI)): fmz) =
10.1728 +(* val ([],(dI,pI,mI)) = (fmz, sp);
10.1729 + *)
10.1730 + if pI <> [] then (*comes from pbl-browser*)
10.1731 + let val {cas,met,ppc,thy,...} = get_pbt pI
10.1732 + val dI = if dI = "" then theory2theory' thy else dI
10.1733 + val thy = assoc_thy dI
10.1734 + val mI = if mI = [] then hd met else mI
10.1735 + val hdl = case cas of NONE => pblterm dI pI | SOME t => t
10.1736 + val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI))
10.1737 + ([], (dI,pI,mI), hdl)
10.1738 + val pt = update_spec pt [] (dI,pI,mI)
10.1739 + val pits = init_pbl' ppc
10.1740 + val pt = update_pbl pt [] pits
10.1741 + in ((pt,([],Pbl)), []): calcstate end
10.1742 + else if mI <> [] then (*comes from met-browser*)
10.1743 + let val {ppc,...} = get_met mI
10.1744 + val dI = if dI = "" then "Isac.thy" else dI
10.1745 + val thy = assoc_thy dI
10.1746 + val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI))
10.1747 + ([], (dI,pI,mI), e_term(*FIXME met*))
10.1748 + val pt = update_spec pt [] (dI,pI,mI)
10.1749 + val mits = init_pbl' ppc
10.1750 + val pt = update_met pt [] mits
10.1751 + in ((pt,([],Met)), []) end
10.1752 + else (*completely new example*)
10.1753 + let val (pt,_) = cappend_problem e_ptree [] e_istate ([], e_spec)
10.1754 + ([], e_spec, e_term)
10.1755 + in ((pt,([],Pbl)), []) end
10.1756 +(* val (fmz, (dI,pI,mI)) = (fmz, sp);
10.1757 + *)
10.1758 + | nxt_specify_init_calc (fmz:fmz_,(dI,pI,mI):spec) =
10.1759 + let (* either """"""""""""""" all empty or complete *)
10.1760 + val thy = assoc_thy dI
10.1761 + val (pI, pors, mI) =
10.1762 + if mI = ["no_met"]
10.1763 + then let val pors = prep_ori fmz thy ((#ppc o get_pbt) pI)
10.1764 + val pI' = refine_ori' pors pI;
10.1765 + in (pI', pors (*refinement over models with diff.prec only*),
10.1766 + (hd o #met o get_pbt) pI') end
10.1767 + else (pI, prep_ori fmz thy ((#ppc o get_pbt) pI), mI)
10.1768 + val {cas,ppc,thy=thy',...} = get_pbt pI (*take dI from _refined_ pbl*)
10.1769 + val dI = theory2theory' (maxthy thy thy');
10.1770 + val hdl = case cas of
10.1771 + NONE => pblterm dI pI
10.1772 + | SOME t => subst_atomic ((vars_of_pbl_' ppc)
10.1773 + ~~~ vals_of_oris pors) t
10.1774 + val (pt,_) = cappend_problem e_ptree [] e_istate (fmz,(dI,pI,mI))
10.1775 + (pors,(dI,pI,mI),hdl)
10.1776 + (*val pbl = init_pbl ppc WN.9.03: done by Model/Refine_Problem
10.1777 + val pt = update_pbl pt [] pbl*)
10.1778 + in ((pt,([],Pbl)), fst3 (nxt_specif Model_Problem (pt, ([],Pbl))))
10.1779 + end;
10.1780 +
10.1781 +
10.1782 +
10.1783 +(*18.12.99*)
10.1784 +fun get_spec_form (m:tac_) ((p,p_):pos') (pt:ptree) =
10.1785 +(* case appl_spec p pt m of /// 19.1.00
10.1786 + Notappl e => Error' (Error_ e)
10.1787 + | Appl =>
10.1788 +*) let val (_,_,f,_,_,_) = specify m (p,p_) [] pt
10.1789 + in f end;
10.1790 +
10.1791 +
10.1792 +(*fun tag_form thy (formal, given) = cterm_of thy
10.1793 + (((head_of o term_of) given) $ (term_of formal)); WN100819*)
10.1794 +fun tag_form thy (formal, given) =
10.1795 + (let val gf = (head_of given) $ formal;
10.1796 + val _ = cterm_of thy gf
10.1797 + in gf end)
10.1798 + handle _ => raise error ("calchead.tag_form: " ^
10.1799 + Syntax.string_of_term (thy2ctxt thy) given ^
10.1800 + " .. " ^
10.1801 + Syntax.string_of_term (thy2ctxt thy) formal ^
10.1802 + " ..types do not match");
10.1803 +(* val formal = (the o (parse thy)) "[R::real]";
10.1804 +> val given = (the o (parse thy)) "fixed_values (cs::real list)";
10.1805 +> tag_form thy (formal, given);
10.1806 +val it = "fixed_values [R]" : cterm
10.1807 +*)
10.1808 +fun chktyp thy (n, fs, gs) =
10.1809 + ((writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) fs;
10.1810 + (writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) gs;
10.1811 + tag_form thy (nth n fs, nth n gs));
10.1812 +
10.1813 +fun chktyps thy (fs, gs) = map (tag_form thy) (fs ~~ gs);
10.1814 +
10.1815 +(* #####################################################
10.1816 + find the failing item:
10.1817 +> val n = 2;
10.1818 +> val tag__form = chktyp (n,formals,givens);
10.1819 +> (type_of o term_of o (nth n)) formals;
10.1820 +> (type_of o term_of o (nth n)) givens;
10.1821 +> atomty ((term_of o (nth n)) formals);
10.1822 +> atomty ((term_of o (nth n)) givens);
10.1823 +> atomty (term_of tag__form);
10.1824 +> use_thy"isa-98-1-HOL-plus/knowl-base/DiffAppl";
10.1825 + ##################################################### *)
10.1826 +
10.1827 +(* #####################################################
10.1828 + testdata setup
10.1829 +val origin = ["sqrt(9+4*x)=sqrt x + sqrt(5+x)","x::rat","(+0)"];
10.1830 +val formals = map (the o (parse thy)) origin;
10.1831 +
10.1832 +val given = ["equation (lhs=rhs)",
10.1833 + "bound_variable bdv", (* TODO type *)
10.1834 + "error_bound apx"];
10.1835 +val where_ = ["e is_root_equation_in bdv",
10.1836 + "bdv is_var",
10.1837 + "apx is_const_expr"];
10.1838 +val find = ["L::rat set"];
10.1839 +val with_ = ["L = {bdv. || ((%x. lhs) bdv) - ((%x. rhs) bdv) || < apx}"];
10.1840 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
10.1841 +val givens = map (the o (parse thy)) given;
10.1842 +
10.1843 +val tag__forms = chktyps (formals, givens);
10.1844 +map ((atomty) o term_of) tag__forms;
10.1845 + ##################################################### *)
10.1846 +
10.1847 +
10.1848 +(* check pbltypes, announces one failure a time *)
10.1849 +(*fun chk_vars ctppc =
10.1850 + let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} =
10.1851 + appc flat (mappc (vars o term_of) ctppc)
10.1852 + in if (wh\\gi) <> [] then ("wh\\gi",wh\\gi)
10.1853 + else if (re\\(gi union fi)) <> []
10.1854 + then ("re\\(gi union fi)",re\\(gi union fi))
10.1855 + else ("ok",[]) end;*)
10.1856 +fun chk_vars ctppc =
10.1857 + let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} =
10.1858 + appc flat (mappc vars ctppc)
10.1859 + val chked = subtract op = gi wh
10.1860 + in if chked <> [] then ("wh\\gi", chked)
10.1861 + else let val chked = subtract op = (union op = gi fi) re
10.1862 + in if chked <> []
10.1863 + then ("re\\(gi union fi)", chked)
10.1864 + else ("ok", [])
10.1865 + end
10.1866 + end;
10.1867 +
10.1868 +(* check a new pbltype: variables (Free) unbound by given, find*)
10.1869 +fun unbound_ppc ctppc =
10.1870 + let val {Given=gi,Find=fi,Relate=re,...} =
10.1871 + appc flat (mappc vars ctppc)
10.1872 + in distinct (*re\\(gi union fi)*)
10.1873 + (subtract op = (union op = gi fi) re) end;
10.1874 +(*
10.1875 +> val org = {Given=["[R=(R::real)]"],Where=[],
10.1876 + Find=["[A::real]"],With=[],
10.1877 + Relate=["[A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"]
10.1878 + }:string ppc;
10.1879 +> val ctppc = mappc (the o (parse thy)) org;
10.1880 +> unbound_ppc ctppc;
10.1881 +val it = [("a","RealDef.real"),("b","RealDef.real")] : (string * typ) list
10.1882 +*)
10.1883 +
10.1884 +
10.1885 +(* f, a binary operator, is nested rightassociative *)
10.1886 +fun foldr1 f xs =
10.1887 + let
10.1888 + fun fld f (x::[]) = x
10.1889 + | fld f (x::x'::[]) = f (x',x)
10.1890 + | fld f (x::x'::xs) = f (fld f (x'::xs),x);
10.1891 + in ((fld f) o rev) xs end;
10.1892 +(*
10.1893 +> val (SOME ct) = parse thy "[a=b,c=d,e=f]";
10.1894 +> val ces = map (cterm_of thy) (isalist2list (term_of ct));
10.1895 +> val conj = foldr1 HOLogic.mk_conj (isalist2list (term_of ct));
10.1896 +> cterm_of thy conj;
10.1897 +val it = "(a = b & c = d) & e = f" : cterm
10.1898 +*)
10.1899 +
10.1900 +(* f, a binary operator, is nested leftassociative *)
10.1901 +fun foldl1 f (x::[]) = x
10.1902 + | foldl1 f (x::x'::[]) = f (x,x')
10.1903 + | foldl1 f (x::x'::xs) = f (x,foldl1 f (x'::xs));
10.1904 +(*
10.1905 +> val (SOME ct) = parse thy "[a=b,c=d,e=f,g=h]";
10.1906 +> val ces = map (cterm_of thy) (isalist2list (term_of ct));
10.1907 +> val conj = foldl1 HOLogic.mk_conj (isalist2list (term_of ct));
10.1908 +> cterm_of thy conj;
10.1909 +val it = "a = b & c = d & e = f & g = h" : cterm
10.1910 +*)
10.1911 +
10.1912 +
10.1913 +(* called only once, if a Subproblem has been located in the script*)
10.1914 +fun nxt_model_pbl (Subproblem'((_,pblID,metID),_,_,_,_)) ptp =
10.1915 +(* val (Subproblem'((_,pblID,metID),_,_,_,_),ptp) = (m', (pt,(p,p_)));
10.1916 + *)
10.1917 + (case metID of
10.1918 + ["no_met"] =>
10.1919 + (snd3 o hd o fst3) (nxt_specif (Refine_Tacitly pblID) ptp)
10.1920 + | _ => (snd3 o hd o fst3) (nxt_specif Model_Problem ptp))
10.1921 + (*all stored in tac_ itms ^^^^^^^^^^*)
10.1922 + | nxt_model_pbl tac_ _ =
10.1923 + raise error ("nxt_model_pbl: called by tac= "^tac_2str tac_);
10.1924 +(* run subp_rooteq.sml ''
10.1925 + until nxt=("Subproblem",Subproblem ("SqRoot.thy",["univariate","equation"]))
10.1926 +> val (_, (Subproblem'((_,pblID,metID),_,_,_,_),_,_,_,_,_)) =
10.1927 + (last_elem o drop_last) ets'';
10.1928 +> val mst = (last_elem o drop_last) ets'';
10.1929 +> nxt_model_pbl mst;
10.1930 +val it = Refine_Tacitly ["univariate","equation"] : tac
10.1931 +*)
10.1932 +
10.1933 +(*fun eq1 d (_,(d',_)) = (d = d'); ---modspec.sml*)
10.1934 +fun eq4 v (_,vts,_,_,_) = member op = vts v;
10.1935 +fun eq5 (_,_,_,_,itm_) (_,_,_,d,_) = d_in itm_ = d;
10.1936 +
10.1937 +
10.1938 +
10.1939 +(*
10.1940 + writeln (oris2str pors);
10.1941 +
10.1942 + writeln (itms2str_ thy pits);
10.1943 + writeln (itms2str_ thy mits);
10.1944 + *)
10.1945 +
10.1946 +
10.1947 +(*.complete _NON_empty calc-head for autocalc (sub-)pbl from oris
10.1948 + + met from fmz; assumes pos on PblObj, meth = [].*)
10.1949 +fun complete_mod (pt, pos as (p, p_):pos') =
10.1950 +(* val (pt, (p, _)) = (pt, p);
10.1951 + val (pt, (p, _)) = (pt, pos);
10.1952 + *)
10.1953 + let val _= if p_ <> Pbl
10.1954 + then writeln("###complete_mod: only impl.for Pbl, called with "^
10.1955 + pos'2str pos) else ()
10.1956 + val (PblObj{origin=(oris, ospec, hdl), probl, spec,...}) =
10.1957 + get_obj I pt p
10.1958 + val (dI,pI,mI) = some_spec ospec spec
10.1959 + val mpc = (#ppc o get_met) mI
10.1960 + val ppc = (#ppc o get_pbt) pI
10.1961 + val (pits, mits) = complete_mod_ (oris, mpc, ppc, probl)
10.1962 + val pt = update_pblppc pt p pits
10.1963 + val pt = update_metppc pt p mits
10.1964 + in (pt, (p,Met):pos') end
10.1965 +;
10.1966 +(*| complete_mod (pt, pos as (p, Met):pos') =
10.1967 + raise error ("###complete_mod: only impl.for Pbl, called with "^
10.1968 + pos'2str pos);*)
10.1969 +
10.1970 +(*.complete _EMPTY_ calc-head for autocalc (sub-)pbl from oris(+met from fmz);
10.1971 + oris and spec (incl. pbl-refinement) given from init_calc or SubProblem .*)
10.1972 +fun all_modspec (pt, (p,_):pos') =
10.1973 +(* val (pt, (p,_)) = ptp;
10.1974 + *)
10.1975 + let val (PblObj{fmz=(fmz_,_), origin=(pors, spec as (dI,pI,mI), hdl),
10.1976 + ...}) = get_obj I pt p;
10.1977 + val thy = assoc_thy dI;
10.1978 + val {ppc,...} = get_met mI;
10.1979 + val mors = prep_ori fmz_ thy ppc;
10.1980 + val pt = update_pblppc pt p (map (ori2Coritm ppc) pors);
10.1981 + val pt = update_metppc pt p (map (ori2Coritm ppc) mors);
10.1982 + val pt = update_spec pt p (dI,pI,mI);
10.1983 + in (pt, (p,Met): pos') end;
10.1984 +
10.1985 +(*WN.12.03: use in nxt_spec, too ? what about variants ???*)
10.1986 +fun is_complete_mod_ ([]: itm list) = false
10.1987 + | is_complete_mod_ itms =
10.1988 + foldl and_ (true, (map #3 itms));
10.1989 +fun is_complete_mod (pt, pos as (p, Pbl): pos') =
10.1990 + if (is_pblobj o (get_obj I pt)) p
10.1991 + then (is_complete_mod_ o (get_obj g_pbl pt)) p
10.1992 + else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos)
10.1993 + | is_complete_mod (pt, pos as (p, Met)) =
10.1994 + if (is_pblobj o (get_obj I pt)) p
10.1995 + then (is_complete_mod_ o (get_obj g_met pt)) p
10.1996 + else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos)
10.1997 + | is_complete_mod (_, pos) =
10.1998 + raise error ("is_complete_mod called by "^pos'2str pos^
10.1999 + " (should be Pbl or Met)");
10.2000 +
10.2001 +(*.have (thy, pbl, met) _all_ been specified explicitly ?.*)
10.2002 +fun is_complete_spec (pt, pos as (p,_): pos') =
10.2003 + if (not o is_pblobj o (get_obj I pt)) p
10.2004 + then raise error ("is_complete_spec: called by PrfObj at "^pos'2str pos)
10.2005 + else let val (dI,pI,mI) = get_obj g_spec pt p
10.2006 + in dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID end;
10.2007 +(*.complete empty items in specification from origin (pbl, met ev.refined);
10.2008 + assumes 'is_complete_mod'.*)
10.2009 +fun complete_spec (pt, pos as (p,_): pos') =
10.2010 + let val PblObj {origin = (_,ospec,_), spec,...} = get_obj I pt p
10.2011 + val pt = update_spec pt p (some_spec ospec spec)
10.2012 + in (pt, pos) end;
10.2013 +
10.2014 +fun is_complete_modspec ptp =
10.2015 + is_complete_mod ptp andalso is_complete_spec ptp;
10.2016 +
10.2017 +
10.2018 +
10.2019 +
10.2020 +fun pt_model (PblObj {meth,spec,origin=(_,spec',hdl),...}) Met =
10.2021 +(* val ((PblObj {meth,spec,origin=(_,spec',hdl),...}), Met) = (ppobj, p_);
10.2022 + *)
10.2023 + let val (_,_,metID) = get_somespec' spec spec'
10.2024 + val pre =
10.2025 + if metID = e_metID then []
10.2026 + else let val {prls,pre=where_,...} = get_met metID
10.2027 + val pre = check_preconds' prls where_ meth 0
10.2028 + in pre end
10.2029 + val allcorrect = is_complete_mod_ meth
10.2030 + andalso foldl and_ (true, (map #1 pre))
10.2031 + in ModSpec (allcorrect, Met, hdl, meth, pre, spec) end
10.2032 + | pt_model (PblObj {probl,spec,origin=(_,spec',hdl),...}) _(*Frm,Pbl*) =
10.2033 +(* val ((PblObj {probl,spec,origin=(_,spec',hdl),...}),_) = (ppobj, p_);
10.2034 + *)
10.2035 + let val (_,pI,_) = get_somespec' spec spec'
10.2036 + val pre =
10.2037 + if pI = e_pblID then []
10.2038 + else let val {prls,where_,cas,...} = get_pbt pI
10.2039 + val pre = check_preconds' prls where_ probl 0
10.2040 + in pre end
10.2041 + val allcorrect = is_complete_mod_ probl
10.2042 + andalso foldl and_ (true, (map #1 pre))
10.2043 + in ModSpec (allcorrect, Pbl, hdl, probl, pre, spec) end;
10.2044 +
10.2045 +
10.2046 +fun pt_form (PrfObj {form,...}) = Form form
10.2047 + | pt_form (PblObj {probl,spec,origin=(_,spec',_),...}) =
10.2048 + let val (dI, pI, _) = get_somespec' spec spec'
10.2049 + val {cas,...} = get_pbt pI
10.2050 + in case cas of
10.2051 + NONE => Form (pblterm dI pI)
10.2052 + | SOME t => Form (subst_atomic (mk_env probl) t)
10.2053 + end;
10.2054 +(*vvv takes the tac _generating_ the formula=result, asm ok....
10.2055 +fun pt_result (PrfObj {result=(t,asm), tac,...}) =
10.2056 + (Form t,
10.2057 + if null asm then NONE else SOME asm,
10.2058 + SOME tac)
10.2059 + | pt_result (PblObj {result=(t,asm), origin = (_,ospec,_), spec,...}) =
10.2060 + let val (_,_,metID) = some_spec ospec spec
10.2061 + in (Form t,
10.2062 + if null asm then NONE else SOME asm,
10.2063 + if metID = e_metID then NONE else SOME (Apply_Method metID)) end;
10.2064 +-------------------------------------------------------------------------*)
10.2065 +
10.2066 +
10.2067 +(*.pt_extract returns
10.2068 + # the formula at pos
10.2069 + # the tactic applied to this formula
10.2070 + # the list of assumptions generated at this formula
10.2071 + (by application of another tac to the preceding formula !)
10.2072 + pos is assumed to come from the frontend, ie. generated by moveDown.*)
10.2073 +(*cannot be in ctree.sml, because ModSpec has to be calculated*)
10.2074 +fun pt_extract (pt,([],Res)) =
10.2075 +(* val (pt,([],Res)) = ptp;
10.2076 + *)
10.2077 + let val (f, asm) = get_obj g_result pt []
10.2078 + in (Form f, NONE, asm) end
10.2079 +(* val p = [3,2];
10.2080 + *)
10.2081 + | pt_extract (pt,(p,Res)) =
10.2082 +(* val (pt,(p,Res)) = ptp;
10.2083 + *)
10.2084 + let val (f, asm) = get_obj g_result pt p
10.2085 + val tac = if last_onlev pt p
10.2086 + then if is_pblobj' pt (lev_up p)
10.2087 + then let val (PblObj{spec=(_,pI,_),...}) =
10.2088 + get_obj I pt (lev_up p)
10.2089 + in if pI = e_pblID then NONE
10.2090 + else SOME (Check_Postcond pI) end
10.2091 + else SOME End_Trans (*WN0502 TODO for other branches*)
10.2092 + else let val p' = lev_on p
10.2093 + in if is_pblobj' pt p'
10.2094 + then let val (PblObj{origin = (_,(dI,pI,_),_),...}) =
10.2095 + get_obj I pt p'
10.2096 + in SOME (Subproblem (dI, pI)) end
10.2097 + else if f = get_obj g_form pt p'
10.2098 + then SOME (get_obj g_tac pt p')
10.2099 + (*because this Frm ~~~is not on worksheet*)
10.2100 + else SOME (Take (term2str (get_obj g_form pt p')))
10.2101 + end
10.2102 + in (Form f, tac, asm) end
10.2103 +
10.2104 + | pt_extract (pt, pos as (p,p_(*Frm,Pbl*))) =
10.2105 +(* val (pt, pos as (p,p_(*Frm,Pbl*))) = ptp;
10.2106 + val (pt, pos as (p,p_(*Frm,Pbl*))) = (pt, p);
10.2107 + *)
10.2108 + let val ppobj = get_obj I pt p
10.2109 + val f = if is_pblobj ppobj then pt_model ppobj p_
10.2110 + else get_obj pt_form pt p
10.2111 + val tac = g_tac ppobj
10.2112 + in (f, SOME tac, []) end;
10.2113 +
10.2114 +
10.2115 +(**. get the formula from a ctree-node:
10.2116 + take form+res from PblObj and 1.PrfObj and (PrfObj after PblObj)
10.2117 + take res from all other PrfObj's .**)
10.2118 +(*designed for interSteps, outcommented 04 in favour of calcChangedEvent*)
10.2119 +fun formres p (Nd (PblObj {origin = (_,_, h), result = (r, _),...}, _)) =
10.2120 + [("headline", (p, Frm), h),
10.2121 + ("stepform", (p, Res), r)]
10.2122 + | formres p (Nd (PrfObj {form, result = (r, _),...}, _)) =
10.2123 + [("stepform", (p, Frm), form),
10.2124 + ("stepform", (p, Res), r)];
10.2125 +
10.2126 +fun form p (Nd (PrfObj {result = (r, _),...}, _)) =
10.2127 + [("stepform", (p, Res), r)]
10.2128 +
10.2129 +(*assumes to take whole level, in particular hd -- for use in interSteps*)
10.2130 +fun get_formress fs p [] = flat fs
10.2131 + | get_formress fs p (nd::nds) =
10.2132 + (* start with 'form+res' and continue with trying 'res' only*)
10.2133 + get_forms (fs @ [formres p nd]) (lev_on p) nds
10.2134 +and get_forms fs p [] = flat fs
10.2135 + | get_forms fs p (nd::nds) =
10.2136 + if is_pblnd nd
10.2137 + (* start again with 'form+res' ///ugly repeat with Check_elementwise
10.2138 + then get_formress (fs @ [formres p nd]) (lev_on p) nds *)
10.2139 + then get_forms (fs @ [formres p nd]) (lev_on p) nds
10.2140 + (* continue with trying 'res' only*)
10.2141 + else get_forms (fs @ [form p nd]) (lev_on p) nds;
10.2142 +
10.2143 +(**.get an 'interval' 'from' 'to' of formulae from a ptree.**)
10.2144 +(*WN050219 made robust against _'to' below or after Complete nodes
10.2145 + by handling exn caused by move_dn*)
10.2146 +(*WN0401 this functionality belongs to ctree.sml,
10.2147 +but fetching a calc_head requires calculations defined in modspec.sml
10.2148 +transfer to ME/me.sml !!!
10.2149 +WN051224 ^^^ doesnt hold any longer, since only the headline of a calc_head
10.2150 +is returned !!!!!!!!!!!!!
10.2151 +*)
10.2152 +fun eq_pos' (p1,Frm) (p2,Frm) = p1 = p2
10.2153 + | eq_pos' (p1,Res) (p2,Res) = p1 = p2
10.2154 + | eq_pos' (p1,Pbl) (p2,p2_) = p1 = p2 andalso (case p2_ of
10.2155 + Pbl => true
10.2156 + | Met => true
10.2157 + | _ => false)
10.2158 + | eq_pos' (p1,Met) (p2,p2_) = p1 = p2 andalso (case p2_ of
10.2159 + Pbl => true
10.2160 + | Met => true
10.2161 + | _ => false)
10.2162 + | eq_pos' _ _ = false;
10.2163 +
10.2164 +(*.get an 'interval' from the ctree; 'interval' is w.r.t. the
10.2165 + total ordering Position#compareTo(Position p) in the java-code
10.2166 +val get_interval = fn
10.2167 + : pos' -> : from is "move_up 1st-element" to return
10.2168 + pos' -> : to the last element to be returned; from < to
10.2169 + int -> : level: 0 gets the flattest sub-tree possible
10.2170 + >999 gets the deepest sub-tree possible
10.2171 + ptree -> :
10.2172 + (pos' * : of the formula
10.2173 + Term.term) : the formula
10.2174 + list
10.2175 +.*)
10.2176 +fun get_interval from to level pt =
10.2177 +(* val (from,level) = (f,lev);
10.2178 + val (from, to, level) = (([3, 2, 1], Res), ([],Res), 9999);
10.2179 + *)
10.2180 + let fun get_inter c (from:pos') (to:pos') lev pt =
10.2181 +(* val (c, from, to, lev) = ([], from, to, level);
10.2182 + ------for recursion.......
10.2183 + val (c, from:pos', to:pos') = (c @ [(from, f)], move_dn [] pt from, to);
10.2184 + *)
10.2185 + if eq_pos' from to orelse from = ([],Res)
10.2186 + (*orelse ... avoids Exception- PTREE "end of calculation" raised,
10.2187 + if 'to' has values NOT generated by move_dn, see systest/me.sml
10.2188 + TODO.WN0501: introduce an order on pos' and check "from > to"..
10.2189 + ...there is an order in Java!
10.2190 + WN051224 the hack got worse with returning term instead ptform*)
10.2191 + then let val (f,_,_) = pt_extract (pt, from)
10.2192 + in case f of
10.2193 + ModSpec (_,_,headline,_,_,_) => c @ [(from, headline)]
10.2194 + | Form t => c @ [(from, t)]
10.2195 + end
10.2196 + else
10.2197 + if lev < lev_of from
10.2198 + then (get_inter c (move_dn [] pt from) to lev pt)
10.2199 + handle (PTREE _(*from move_dn too far*)) => c
10.2200 + else let val (f,_,_) = pt_extract (pt, from)
10.2201 + val term = case f of
10.2202 + ModSpec (_,_,headline,_,_,_)=> headline
10.2203 + | Form t => t
10.2204 + in (get_inter (c @ [(from, term)])
10.2205 + (move_dn [] pt from) to lev pt)
10.2206 + handle (PTREE _(*from move_dn too far*))
10.2207 + => c @ [(from, term)] end
10.2208 + in get_inter [] from to level pt end;
10.2209 +
10.2210 +(*for tests*)
10.2211 +fun posform2str (pos:pos', form) =
10.2212 + "("^ pos'2str pos ^", "^
10.2213 + (case form of
10.2214 + Form f => term2str f
10.2215 + | ModSpec c => term2str (#3 c(*the headline*)))
10.2216 + ^")";
10.2217 +fun posforms2str pfs = (strs2str' o (map (curry op ^ "\n")) o
10.2218 + (map posform2str)) pfs;
10.2219 +fun posterm2str (pos:pos', t) =
10.2220 + "("^ pos'2str pos ^", "^term2str t^")";
10.2221 +fun posterms2str pfs = (strs2str' o (map (curry op ^ "\n")) o
10.2222 + (map posterm2str)) pfs;
10.2223 +
10.2224 +
10.2225 +(*WN050225 omits the last step, if pt is incomplete*)
10.2226 +fun show_pt pt =
10.2227 + writeln (posterms2str (get_interval ([],Frm) ([],Res) 99999 pt));
10.2228 +
10.2229 +(*.get a calchead from a PblObj-node in the ctree;
10.2230 + preconditions must be calculated.*)
10.2231 +fun get_ocalhd (pt, pos' as (p,Pbl):pos') =
10.2232 + let val PblObj {origin = (oris, ospec, hdf'), spec, probl,...} =
10.2233 + get_obj I pt p
10.2234 + val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec))
10.2235 + val pre = check_preconds (assoc_thy"Isac.thy") prls where_ probl
10.2236 + in (ocalhd_complete probl pre spec, Pbl, hdf', probl, pre, spec):ocalhd end
10.2237 +| get_ocalhd (pt, pos' as (p,Met):pos') =
10.2238 + let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'),
10.2239 + spec, meth,...} =
10.2240 + get_obj I pt p
10.2241 + val {prls,pre,...} = get_met (#3 (some_spec ospec spec))
10.2242 + val pre = check_preconds (assoc_thy"Isac.thy") prls pre meth
10.2243 + in (ocalhd_complete meth pre spec, Met, hdf', meth, pre, spec):ocalhd end;
10.2244 +
10.2245 +(*.at the activeFormula set the Model, the Guard and the Specification
10.2246 + to empty and return a CalcHead;
10.2247 + the 'origin' remains (for reconstructing all that).*)
10.2248 +fun reset_calchead (pt, pos' as (p,_):pos') =
10.2249 + let val PblObj {origin = (_, _, hdf'),...} = get_obj I pt p
10.2250 + val pt = update_pbl pt p []
10.2251 + val pt = update_met pt p []
10.2252 + val pt = update_spec pt p e_spec
10.2253 + in (pt, (p,Pbl):pos') end;
10.2254 +
10.2255 +(*---------------------------------------------------------------------*)
10.2256 +end
10.2257 +
10.2258 +open CalcHead;
10.2259 +(*---------------------------------------------------------------------*)
10.2260 +
11.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2 +++ b/src/Tools/isac/Interpret/ctree.sml Wed Aug 25 16:20:07 2010 +0200
11.3 @@ -0,0 +1,2154 @@
11.4 +(* use"../ME/ctree.sml";
11.5 + use"ME/ctree.sml";
11.6 + use"ctree.sml";
11.7 + W.N.26.10.99
11.8 +
11.9 +writeln (pr_ptree pr_short pt);
11.10 +
11.11 +val Nd ( _, ns) = pt;
11.12 +
11.13 +*)
11.14 +
11.15 +(*structure Ptree (**): PTREE (**) = ###### outcommented ######*)
11.16 +signature PTREE =
11.17 +sig
11.18 + type ptree
11.19 + type envp
11.20 + val e_ptree : ptree
11.21 + exception PTREE of string
11.22 + type branch
11.23 + type ostate
11.24 + type cellID
11.25 + type cid
11.26 + type posel
11.27 + type pos
11.28 + type pos'
11.29 + type loc
11.30 + type domID
11.31 + type pblID
11.32 + type metID
11.33 + type spec
11.34 + type 'a ppc
11.35 + type con
11.36 + type subs
11.37 + type subst
11.38 + type env
11.39 + type ets
11.40 + val ets2str : ets -> string
11.41 + type item
11.42 + type tac
11.43 + type tac_
11.44 + val tac_2str : tac_ -> string
11.45 + type safe
11.46 + val safe2str : safe -> string
11.47 +
11.48 + type meth
11.49 + val cappend_atomic : ptree -> pos -> loc -> cterm' -> tac
11.50 + -> cterm' -> ostate -> cid -> ptree * posel list * cid
11.51 + val cappend_form : ptree
11.52 + -> pos -> loc -> cterm' -> cid -> ptree * pos * cid
11.53 + val cappend_parent : ptree -> pos -> loc -> cterm' -> tac
11.54 + -> branch -> cid -> ptree * int list * cid
11.55 + val cappend_problem : ptree -> posel list(*FIXME*) -> loc
11.56 + -> cterm' list * spec -> cid -> ptree * int list * cellID list
11.57 + val append_result : ptree -> pos -> cterm' -> ostate -> ptree * pos
11.58 +
11.59 + type ppobj
11.60 + val g_branch : ppobj -> branch
11.61 + val g_cell : ppobj -> cid
11.62 + val g_args : ppobj -> (int * (term list)) list (*args of scr*)
11.63 + val g_form : ppobj -> cterm'
11.64 + val g_loc : ppobj -> loc
11.65 + val g_met : ppobj -> meth
11.66 + val g_domID : ppobj -> domID
11.67 + val g_metID : ppobj -> metID
11.68 + val g_model : ppobj -> cterm' ppc
11.69 + val g_tac : ppobj -> tac
11.70 + val g_origin : ppobj -> cterm' list * spec
11.71 + val g_ostate : ppobj -> ostate
11.72 + val g_pbl : ppobj -> pblID * item ppc
11.73 + val g_result : ppobj -> cterm'
11.74 + val g_spec : ppobj -> spec
11.75 +(* val get_all : (ppobj -> 'a) -> ptree -> 'a list
11.76 + val get_alls : (ppobj -> 'a) -> ptree list -> 'a list *)
11.77 + val get_obj : (ppobj -> 'a) -> ptree -> pos -> 'a
11.78 + val gpt_cell : ptree -> cid
11.79 + val par_pblobj : ptree -> pos -> pos
11.80 + val pre_pos : pos -> pos
11.81 + val lev_dn : int list -> int list
11.82 + val lev_on : pos -> posel list
11.83 + val lev_pred : pos -> pos
11.84 + val lev_up : pos -> pos
11.85 +(* val pr_cell : pos -> ppobj -> string
11.86 + val pr_pos : int list -> string *)
11.87 + val pr_ptree : (pos -> ppobj -> string) -> ptree -> string
11.88 + val pr_short : pos -> ppobj -> string
11.89 +(* val repl : 'a list -> int -> 'a -> 'a list
11.90 + val repl_app : 'a list -> int -> 'a -> 'a list
11.91 + val repl_branch : branch -> ppobj -> ppobj
11.92 + val repl_domID : domID -> ppobj -> ppobj
11.93 + val repl_form : cterm' -> ppobj -> ppobj
11.94 + val repl_met : item ppc -> ppobj -> ppobj
11.95 + val repl_metID : metID -> ppobj -> ppobj
11.96 + val repl_model : cterm' list -> ppobj -> ppobj
11.97 + val repl_tac : tac -> ppobj -> ppobj
11.98 + val repl_pbl : item ppc -> ppobj -> ppobj
11.99 + val repl_pblID : pblID -> ppobj -> ppobj
11.100 + val repl_result : cterm' -> ostate -> ppobj -> ppobj
11.101 + val repl_spec : spec -> ppobj -> ppobj
11.102 + val repl_subs : (string * string) list -> ppobj -> ppobj *)
11.103 + val rootthy : ptree -> domID
11.104 +(* val test_trans : ppobj -> bool
11.105 + val uni__asm : (string * pos) list -> ppobj -> ppobj
11.106 + val uni__cid : cellID list -> ppobj -> ppobj *)
11.107 + val union_asm : ptree -> pos -> (string * pos) list -> ptree
11.108 + val union_cid : ptree -> pos -> cellID list -> ptree
11.109 + val update_branch : ptree -> pos -> branch -> ptree
11.110 + val update_domID : ptree -> pos -> domID -> ptree
11.111 + val update_met : ptree -> pos -> meth -> ptree
11.112 + val update_metppc : ptree -> pos -> item ppc -> ptree
11.113 + val update_metID : ptree -> pos -> metID -> ptree
11.114 + val update_tac : ptree -> pos -> tac -> ptree
11.115 + val update_pbl : ptree -> pos -> pblID * item ppc -> ptree
11.116 + val update_pblppc : ptree -> pos -> item ppc -> ptree
11.117 + val update_pblID : ptree -> pos -> pblID -> ptree
11.118 + val update_spec : ptree -> pos -> spec -> ptree
11.119 + val update_subs : ptree -> pos -> (string * string) list -> ptree
11.120 +
11.121 + val rep_pblobj : ppobj
11.122 + -> {branch:branch, cell:cid, env:envp, loc:loc, meth:meth, model:cterm' ppc,
11.123 + origin:cterm' list * spec, ostate:ostate, probl:pblID * item ppc,
11.124 + result:cterm', spec:spec}
11.125 + val rep_prfobj : ppobj
11.126 + -> {branch:branch, cell:cid, form:cterm', loc:loc, tac:tac,
11.127 + ostate:ostate, result:cterm'}
11.128 +end
11.129 +
11.130 +(* --------------
11.131 +structure Ptree (**): PTREE (**) =
11.132 +struct
11.133 + -------------- *)
11.134 +
11.135 +type env = (term * term) list;
11.136 +
11.137 +
11.138 +datatype branch =
11.139 + NoBranch | AndB | OrB
11.140 + | TransitiveB (* FIXXXME.8.03: set branch from met in Apply_Method
11.141 + FIXXXME.0402: -"- in Begin_Trans'*)
11.142 + | SequenceB | IntersectB | CollectB | MapB;
11.143 +fun branch2str NoBranch = "NoBranch"
11.144 + | branch2str AndB = "AndB"
11.145 + | branch2str OrB = "OrB"
11.146 + | branch2str TransitiveB = "TransitiveB"
11.147 + | branch2str SequenceB = "SequenceB"
11.148 + | branch2str IntersectB = "IntersectB"
11.149 + | branch2str CollectB = "CollectB"
11.150 + | branch2str MapB = "MapB";
11.151 +
11.152 +datatype ostate =
11.153 + Incomplete | Complete | Inconsistent(*WN041020 latter unused*);
11.154 +fun ostate2str Incomplete = "Incomplete"
11.155 + | ostate2str Complete = "Complete"
11.156 + | ostate2str Inconsistent = "Inconsistent";
11.157 +
11.158 +type cellID = int;
11.159 +type cid = cellID list;
11.160 +
11.161 +type posel = int; (* roundabout for (some of) nice signatures *)
11.162 +type pos = posel list;
11.163 +val pos2str = ints2str';
11.164 +datatype pos_ =
11.165 + Pbl (*PblObj-position: problem-type*)
11.166 + | Met (*PblObj-position: method*)
11.167 + | Frm (*PblObj-position: -> Pbl in ME (not by moveDown !)
11.168 + | PrfObj-position: formula*)
11.169 + | Res (*PblObj | PrfObj-position: result*)
11.170 + | Und; (*undefined*)
11.171 +fun pos_2str Pbl = "Pbl"
11.172 + | pos_2str Met = "Met"
11.173 + | pos_2str Frm = "Frm"
11.174 + | pos_2str Res = "Res"
11.175 + | pos_2str Und = "Und";
11.176 +
11.177 +type pos' = pos * pos_;
11.178 +(*WN.12.03 remembering interator (pos * pos_) for ptree
11.179 + pos : lev_on, lev_dn, lev_up,
11.180 + lev_onFrm, lev_dnRes (..see solve Apply_Method !)
11.181 + pos_:
11.182 +# generate1 sets pos_ if possible ...?WN0502?NOT...
11.183 +# generate1 does NOT set pos, because certain nodes can be lev_on OR lev_dn
11.184 + exceptions: Begin/End_Trans
11.185 +# thus generate(1) called in
11.186 +.# assy, locate_gen
11.187 +.# nxt_solv (tac_ -cases); general case:
11.188 + val pos' = case pos' of (p,Res) => (lev_on p',Res) | _ => pos'
11.189 +# WN050220, S(604):
11.190 + generate1...(Rewrite(f,..,res))..(pos, pos_)
11.191 + cappend_atomic.................pos ////// gets f+res always!!!
11.192 + cut_tree....................pos, pos_
11.193 +*)
11.194 +fun pos'2str (p,p_) = pair2str (ints2str' p, pos_2str p_);
11.195 +fun pos's2str ps = (strs2str' o (map pos'2str)) ps;
11.196 +val e_pos' = ([],Und):pos';
11.197 +
11.198 +fun res2str (t, ts) = pair2str (term2str t, terms2str ts);
11.199 +fun asm2str (t, p:pos) = pair2str (term2str t, ints2str' p);
11.200 +fun asms2str asms = (strs2str' o (map asm2str)) asms;
11.201 +
11.202 +
11.203 +
11.204 +(*26.4.02: never used after introduction of scripts !!!
11.205 +type loc = loc_ * (* + interpreter-state *)
11.206 + (loc_ * rls') (* -"- for script of the ruleset*)
11.207 + option;
11.208 +val e_loc = ([],NONE):loc;
11.209 +val ee_loc = (e_loc,e_loc);*)
11.210 +
11.211 +
11.212 +datatype safe = Sundef | Safe | Unsafe | Helpless;
11.213 +fun safe2str Sundef = "Sundef"
11.214 + | safe2str Safe = "Safe"
11.215 + | safe2str Unsafe = "Unsafe"
11.216 + | safe2str Helpless = "Helpless";
11.217 +
11.218 +type subs = cterm' list; (*16.11.00 for FE-KE*)
11.219 +val e_subs = ["(bdv, x)"];
11.220 +
11.221 +(*._sub_stitution as strings of _e_qualities.*)
11.222 +type sube = cterm' list;
11.223 +val e_sube = []:cterm' list;
11.224 +fun sube2str s = strs2str s;
11.225 +
11.226 +(*._sub_stitution as _t_erms of _e_qualities.*)
11.227 +type subte = term list;
11.228 +val e_subte = []:term list;
11.229 +fun subte2str ss = terms2str ss;
11.230 +
11.231 +fun subte2sube ss = map term2str ss;
11.232 +
11.233 +fun subst2subs s = map (pair2str o
11.234 + (apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o
11.235 + (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s;
11.236 +fun subst2subs' s = map ((apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o
11.237 + (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s;
11.238 +fun subs2subst thy s = map (isapair2pair o term_of o the o (parse thy)) s;
11.239 +(*> subs2subst thy ["(bdv,x)","(err,#0)"];
11.240 +val it =
11.241 + [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real")),
11.242 + (Free ("err","RealDef.real"),Free ("#0","RealDef.real"))]
11.243 + : (term * term) list*)
11.244 +(*["bdv=x","err=0"] ---> [(bdv,x), (err,0)]*)
11.245 +fun sube2subst thy s = map (dest_equals' o term_of o the o (parse thy)) s;
11.246 +(* val ts = sube2subst thy ["bdv=x","err=0"];
11.247 + subst2str' ts;
11.248 + *)
11.249 +fun sube2subte ss = map str2term ss;
11.250 +
11.251 +
11.252 +fun isasub2subst isasub = ((map isapair2pair) o isalist2list) isasub;
11.253 +
11.254 +
11.255 +type scrstate = (*state for script interpreter*)
11.256 + env(*stack*) (*used to instantiate tac for checking assod
11.257 + 12.03.noticed: e_ not updated during execution ?!?*)
11.258 + * loc_ (*location of tac in script*)
11.259 + * term option(*argument of curried functions*)
11.260 + * term (*value obtained by tac executed
11.261 + updated also after a derivation by 'new_val'*)
11.262 + * safe (*estimation of how result will be obtained*)
11.263 + * bool; (*true = strongly .., false = weakly associated:
11.264 + only used during ass_dn/up*)
11.265 +val e_scrstate = ([],[],NONE,e_term,Sundef,false):scrstate;
11.266 +
11.267 +
11.268 +(*21.8.02 ---> definitions.sml for datatype scr
11.269 +type rrlsstate = (*state for reverse rewriting*)
11.270 + (term * (*the current formula*)
11.271 + rule list (*of reverse rewrite set (#1#)*)
11.272 + list * (*may be serveral, eg. in norm_rational*)
11.273 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
11.274 + (term * (*... rewrite with ...*)
11.275 + term list)) (*... assumptions*)
11.276 + list); (*derivation from given term to normalform
11.277 + in reverse order with sym_thm;
11.278 + (#1#) could be extracted from here #1*) --------*)
11.279 +
11.280 +datatype istate = (*interpreter state*)
11.281 + Uistate (*undefined in modspec, in '_deriv'ation*)
11.282 + | ScrState of scrstate (*for script interpreter*)
11.283 + | RrlsState of rrlsstate; (*for reverse rewriting*)
11.284 +val e_istate = (ScrState ([],[],NONE,e_term,Sundef,false)):istate;
11.285 +
11.286 +type iist = istate option * istate option;
11.287 +(*val e_iist = (e_istate, e_istate); --- sinnlos f"ur NICHT-equality-type*)
11.288 +
11.289 +
11.290 +fun rta2str (r,(t,a)) = "\n("^(rule2str r)^",("^(term2str t)^", "^
11.291 + (terms2str a)^"))";
11.292 +fun istate2str Uistate = "Uistate"
11.293 + | istate2str (ScrState (e,l,to,t,s,b):istate) =
11.294 + "ScrState ("^ subst2str e ^",\n "^
11.295 + loc_2str l ^", "^ termopt2str to ^",\n "^
11.296 + term2str t ^", "^ safe2str s ^", "^ bool2str b ^")"
11.297 + | istate2str (RrlsState (t,t1,rss,rtas)) =
11.298 + "RrlsState ("^(term2str t)^", "^(term2str t1)^", "^
11.299 + ((strs2str o (map (strs2str o (map rule2str)))) rss)^", "^
11.300 + ((strs2str o (map rta2str)) rtas)^")";
11.301 +fun istates2str (NONE, NONE) = "(#NONE, #NONE)"
11.302 + | istates2str (NONE, SOME ist) = "(#NONE,\n#SOME "^istate2str ist^")"
11.303 + | istates2str (SOME ist, NONE) = "(#SOME "^istate2str ist^",\n #NONE)"
11.304 + | istates2str (SOME i1, SOME i2) = "(#SOME "^istate2str i1^",\n #SOME "^
11.305 + istate2str i2^")";
11.306 +
11.307 +fun new_val v (ScrState (env, loc_, topt, _, safe, bool)) =
11.308 + (ScrState (env, loc_, topt, v, safe, bool))
11.309 + | new_val _ _ = raise error "new_val: only for ScrState";
11.310 +
11.311 +datatype con = land | lor;
11.312 +
11.313 +
11.314 +type spec =
11.315 + domID * (*WN.12.03: is replaced by thy from get_met ?FIXME? in:
11.316 + specify (Init_Proof..), nxt_specify_init_calc,
11.317 + assod (.SubProblem...), stac2tac (.SubProblem...)*)
11.318 + pblID *
11.319 + metID;
11.320 +fun spec2str ((dom,pbl,met)(*:spec*)) =
11.321 + "(" ^ (quote dom) ^ ", " ^ (strs2str pbl) ^
11.322 + ", " ^ (strs2str met) ^ ")";
11.323 +(*> spec2str empty_spec;
11.324 +val it = "(\"\", [], (\"\", \"\"))" : string *)
11.325 +val empty_spec = (e_domID,e_pblID,e_metID):spec;
11.326 +val e_spec = empty_spec;
11.327 +
11.328 +
11.329 +
11.330 +(*.tactics propagate the construction of the calc-tree;
11.331 + there are
11.332 + (a) 'specsteps' for the specify-phase, and others for the solve-phase
11.333 + (b) those of the solve-phase are 'initac's and others;
11.334 + initacs start with a formula different from the preceding formula.
11.335 + see 'type tac_' for the internal representation of tactics.*)
11.336 +datatype tac =
11.337 + Init_Proof of ((cterm' list) * spec)
11.338 +(*'specsteps'...*)
11.339 +| Model_Problem
11.340 +| Refine_Problem of pblID | Refine_Tacitly of pblID
11.341 +
11.342 +| Add_Given of cterm' | Del_Given of cterm'
11.343 +| Add_Find of cterm' | Del_Find of cterm'
11.344 +| Add_Relation of cterm' | Del_Relation of cterm'
11.345 +
11.346 +| Specify_Theory of domID | Specify_Problem of pblID
11.347 +| Specify_Method of metID
11.348 +(*...'specsteps'*)
11.349 +| Apply_Method of metID
11.350 +(*.creates an 'istate' in PblObj.env; in case of 'init_form'
11.351 + creates a formula at ((lev_on o lev_dn) p, Frm) and in this ppobj.'loc'
11.352 + 'SOME istate' (at fst of 'loc').
11.353 + As each step (in the solve-phase) has a resulting formula (at the front-end)
11.354 + Apply_Method also does the 1st step in the script (an 'initac') if there
11.355 + is no 'init_form' .*)
11.356 +| Check_Postcond of pblID
11.357 +| Free_Solve
11.358 +
11.359 +| Rewrite_Inst of ( subs * thm') | Rewrite of thm'
11.360 + | Rewrite_Asm of thm'
11.361 +| Rewrite_Set_Inst of ( subs * rls') | Rewrite_Set of rls'
11.362 +| Detail_Set_Inst of ( subs * rls') | Detail_Set of rls'
11.363 +| End_Detail (*end of script from next_tac,
11.364 + in solve: switches back to parent script WN0509 drop!*)
11.365 +| Derive of rls' (*an input formula using rls WN0509 drop!*)
11.366 +| Calculate of string (* plus | minus | times | cancel | pow | sqrt *)
11.367 +| End_Ruleset
11.368 +| Substitute of sube | Apply_Assumption of cterm' list
11.369 +
11.370 +| Take of cterm' (*an 'initac'*)
11.371 +| Take_Inst of cterm'
11.372 +| Group of (con * int list )
11.373 +| Subproblem of (domID * pblID) (*an 'initac'*)
11.374 +| CAScmd of cterm' (*6.6.02 URD: Function formula; WN0509 drop!*)
11.375 +| End_Subproblem (*WN0509 drop!*)
11.376 +
11.377 +| Split_And | Conclude_And
11.378 +| Split_Or | Conclude_Or
11.379 +| Begin_Trans | End_Trans
11.380 +| Begin_Sequ | End_Sequ(* substitute root.env *)
11.381 +| Split_Intersect | End_Intersect
11.382 +| Check_elementwise of cterm' | Collect_Trues
11.383 +| Or_to_List
11.384 +
11.385 +| Empty_Tac (*TODO.11.6.03 ... of string: could carry msg of (Notappl msg)
11.386 + in 'helpless'*)
11.387 +| Tac of string(* eg.'repeat'*WN0509 drop!*)
11.388 +| User (*internal, for ets*WN0509 drop!*)
11.389 +| End_Proof';(* inout*)
11.390 +
11.391 +(* tac2str /--> library.sml: needed in dialog.sml for 'separable *)
11.392 +fun tac2str (ma:tac) = case ma of
11.393 + Init_Proof (ppc, spec) =>
11.394 + "Init_Proof "^(pair2str (strs2str ppc, spec2str spec))
11.395 + | Model_Problem => "Model_Problem "
11.396 + | Refine_Tacitly pblID => "Refine_Tacitly "^(strs2str pblID)
11.397 + | Refine_Problem pblID => "Refine_Problem "^(strs2str pblID)
11.398 + | Add_Given cterm' => "Add_Given "^cterm'
11.399 + | Del_Given cterm' => "Del_Given "^cterm'
11.400 + | Add_Find cterm' => "Add_Find "^cterm'
11.401 + | Del_Find cterm' => "Del_Find "^cterm'
11.402 + | Add_Relation cterm' => "Add_Relation "^cterm'
11.403 + | Del_Relation cterm' => "Del_Relation "^cterm'
11.404 +
11.405 + | Specify_Theory domID => "Specify_Theory "^(quote domID )
11.406 + | Specify_Problem pblID => "Specify_Problem "^(strs2str pblID )
11.407 + | Specify_Method metID => "Specify_Method "^(strs2str metID)
11.408 + | Apply_Method metID => "Apply_Method "^(strs2str metID)
11.409 + | Check_Postcond pblID => "Check_Postcond "^(strs2str pblID)
11.410 + | Free_Solve => "Free_Solve"
11.411 +
11.412 + | Rewrite_Inst (subs,thm')=>
11.413 + "Rewrite_Inst "^(pair2str (subs2str subs, spair2str thm'))
11.414 + | Rewrite thm' => "Rewrite "^(spair2str thm')
11.415 + | Rewrite_Asm thm' => "Rewrite_Asm "^(spair2str thm')
11.416 + | Rewrite_Set_Inst (subs, rls) =>
11.417 + "Rewrite_Set_Inst "^(pair2str (subs2str subs, quote rls))
11.418 + | Rewrite_Set rls => "Rewrite_Set "^(quote rls )
11.419 + | Detail_Set rls => "Detail_Set "^(quote rls )
11.420 + | Detail_Set_Inst (subs, rls) =>
11.421 + "Detail_Set_Inst "^(pair2str (subs2str subs, quote rls))
11.422 + | End_Detail => "End_Detail"
11.423 + | Derive rls' => "Derive "^rls'
11.424 + | Calculate op_ => "Calculate "^op_
11.425 + | Substitute sube => "Substitute "^sube2str sube
11.426 + | Apply_Assumption ct's => "Apply_Assumption "^(strs2str ct's)
11.427 +
11.428 + | Take cterm' => "Take "^(quote cterm' )
11.429 + | Take_Inst cterm' => "Take_Inst "^(quote cterm' )
11.430 + | Group (con, ints) =>
11.431 + "Group "^(pair2str (con2str con, ints2str ints))
11.432 + | Subproblem (domID, pblID) =>
11.433 + "Subproblem "^(pair2str (domID, strs2str pblID))
11.434 +(*| Subproblem_Full (spec, cts') =>
11.435 + "Subproblem_Full "^(pair2str (spec2str spec, strs2str cts'))*)
11.436 + | End_Subproblem => "End_Subproblem"
11.437 + | CAScmd cterm' => "CAScmd "^(quote cterm')
11.438 +
11.439 + | Check_elementwise cterm'=> "Check_elementwise "^(quote cterm')
11.440 + | Or_to_List => "Or_to_List "
11.441 + | Collect_Trues => "Collect_Trues"
11.442 +
11.443 + | Empty_Tac => "Empty_Tac"
11.444 + | Tac string => "Tac "^string
11.445 + | User => "User"
11.446 + | End_Proof' => "tac End_Proof'"
11.447 + | _ => "tac2str not impl. for ?!";
11.448 +
11.449 +fun is_rewset (Rewrite_Set_Inst _) = true
11.450 + | is_rewset (Rewrite_Set _) = true
11.451 + | is_rewset _ = false;
11.452 +fun is_rewtac (Rewrite _) = true
11.453 + | is_rewtac (Rewrite_Inst _) = true
11.454 + | is_rewtac (Rewrite_Asm _) = true
11.455 + | is_rewtac tac = is_rewset tac;
11.456 +
11.457 +fun tac2IDstr (ma:tac) = case ma of
11.458 + Model_Problem => "Model_Problem"
11.459 + | Refine_Tacitly pblID => "Refine_Tacitly"
11.460 + | Refine_Problem pblID => "Refine_Problem"
11.461 + | Add_Given cterm' => "Add_Given"
11.462 + | Del_Given cterm' => "Del_Given"
11.463 + | Add_Find cterm' => "Add_Find"
11.464 + | Del_Find cterm' => "Del_Find"
11.465 + | Add_Relation cterm' => "Add_Relation"
11.466 + | Del_Relation cterm' => "Del_Relation"
11.467 +
11.468 + | Specify_Theory domID => "Specify_Theory"
11.469 + | Specify_Problem pblID => "Specify_Problem"
11.470 + | Specify_Method metID => "Specify_Method"
11.471 + | Apply_Method metID => "Apply_Method"
11.472 + | Check_Postcond pblID => "Check_Postcond"
11.473 + | Free_Solve => "Free_Solve"
11.474 +
11.475 + | Rewrite_Inst (subs,thm')=> "Rewrite_Inst"
11.476 + | Rewrite thm' => "Rewrite"
11.477 + | Rewrite_Asm thm' => "Rewrite_Asm"
11.478 + | Rewrite_Set_Inst (subs, rls) => "Rewrite_Set_Inst"
11.479 + | Rewrite_Set rls => "Rewrite_Set"
11.480 + | Detail_Set rls => "Detail_Set"
11.481 + | Detail_Set_Inst (subs, rls) => "Detail_Set_Inst"
11.482 + | Derive rls' => "Derive "
11.483 + | Calculate op_ => "Calculate "
11.484 + | Substitute subs => "Substitute"
11.485 + | Apply_Assumption ct's => "Apply_Assumption"
11.486 +
11.487 + | Take cterm' => "Take"
11.488 + | Take_Inst cterm' => "Take_Inst"
11.489 + | Group (con, ints) => "Group"
11.490 + | Subproblem (domID, pblID) => "Subproblem"
11.491 + | End_Subproblem => "End_Subproblem"
11.492 + | CAScmd cterm' => "CAScmd"
11.493 +
11.494 + | Check_elementwise cterm'=> "Check_elementwise"
11.495 + | Or_to_List => "Or_to_List "
11.496 + | Collect_Trues => "Collect_Trues"
11.497 +
11.498 + | Empty_Tac => "Empty_Tac"
11.499 + | Tac string => "Tac "
11.500 + | User => "User"
11.501 + | End_Proof' => "End_Proof'"
11.502 + | _ => "tac2str not impl. for ?!";
11.503 +
11.504 +fun rls_of (Rewrite_Set_Inst (_, rls)) = rls
11.505 + | rls_of (Rewrite_Set rls) = rls
11.506 + | rls_of tac = raise error ("rls_of: called with tac '"^tac2IDstr tac^"'");
11.507 +
11.508 +fun thm_of_rew (Rewrite_Inst (subs,(thmID,_))) =
11.509 + (thmID, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst))
11.510 + | thm_of_rew (Rewrite (thmID,_)) = (thmID, NONE)
11.511 + | thm_of_rew (Rewrite_Asm (thmID,_)) = (thmID, NONE);
11.512 +
11.513 +fun rls_of_rewset (Rewrite_Set_Inst (subs,rls)) =
11.514 + (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst))
11.515 + | rls_of_rewset (Rewrite_Set rls) = (rls, NONE)
11.516 + | rls_of_rewset (Detail_Set rls) = (rls, NONE)
11.517 + | rls_of_rewset (Detail_Set_Inst (subs, rls)) =
11.518 + (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst));
11.519 +
11.520 +fun rule2tac _ (Calc (opID, thm)) = Calculate (calID2calcID opID)
11.521 + | rule2tac [] (Thm (thmID, thm)) = Rewrite (thmID, string_of_thmI thm)
11.522 + | rule2tac subst (Thm (thmID, thm)) =
11.523 + Rewrite_Inst (subst2subs subst, (thmID, string_of_thmI thm))
11.524 + | rule2tac [] (Rls_ rls) = Rewrite_Set (id_rls rls)
11.525 + | rule2tac subst (Rls_ rls) =
11.526 + Rewrite_Set_Inst (subst2subs subst, (id_rls rls))
11.527 + | rule2tac _ rule =
11.528 + raise error ("rule2tac: called with '" ^ rule2str rule ^ "'");
11.529 +
11.530 +type fmz_ = cterm' list;
11.531 +
11.532 +(*.a formalization of an example containing data
11.533 + sufficient for mechanically finding the solution for the example.*)
11.534 +(*FIXME.WN051014: dont store fmz = (_,spec) in the PblObj,
11.535 + this is done in origin*)
11.536 +type fmz = fmz_ * spec;
11.537 +val e_fmz = ([],e_spec);
11.538 +
11.539 +(*tac_ is made from tac in applicable_in,
11.540 + and carries all data necessary for generate;*)
11.541 +datatype tac_ =
11.542 +(* datatype tac = *)
11.543 + Init_Proof' of ((cterm' list) * spec)
11.544 + (* ori list !: code specify -> applicable*)
11.545 +| Model_Problem' of pblID *
11.546 + itm list * (*the 'untouched' pbl*)
11.547 + itm list (*the casually completed met*)
11.548 +| Refine_Tacitly' of pblID * (*input*)
11.549 + pblID * (*the refined from applicable_in*)
11.550 + domID * (*from new pbt?! filled in specify*)
11.551 + metID * (*from new pbt?! filled in specify*)
11.552 + itm list (*drop ! 9.03: remains [] for
11.553 + Model_Problem recognizing its activation*)
11.554 +| Refine_Problem' of (pblID * (itm list * (bool * Term.term) list))
11.555 + (*FIXME?040215 drop: done automatically in init_proof + Subproblem'*)
11.556 +| Add_Given' of cterm' *
11.557 + itm list (*updated with input in fun specify_additem*)
11.558 +| Add_Find' of cterm' *
11.559 + itm list (*updated with input in fun specify_additem*)
11.560 +| Add_Relation' of cterm' *
11.561 + itm list (*updated with input in fun specify_additem*)
11.562 +| Del_Given' of cterm' | Del_Find' of cterm' | Del_Relation' of cterm'
11.563 + (*4.00.: all.. term: in applicable_in ..? Syn ?only for FormFK?*)
11.564 +
11.565 +| Specify_Theory' of domID
11.566 +| Specify_Problem' of (pblID * (* *)
11.567 + (bool * (* matches *)
11.568 + (itm list * (* ppc *)
11.569 + (bool * term) list))) (* preconditions *)
11.570 +| Specify_Method' of metID *
11.571 + ori list * (*repl. "#undef"*)
11.572 + itm list (*... updated from pbl to met*)
11.573 +| Apply_Method' of metID *
11.574 + (term option) * (*init_form*)
11.575 + istate
11.576 +| Check_Postcond' of
11.577 + pblID *
11.578 + (term * (*returnvalue of script in solve*)
11.579 + cterm' list)(*collect by get_assumptions_ in applicable_in, except if
11.580 + butlast tac is Check_elementwise: take only these asms*)
11.581 +| Free_Solve'
11.582 +
11.583 +| Rewrite_Inst' of theory' * rew_ord' * rls
11.584 + * bool * subst * thm' * term * (term * term list)
11.585 +| Rewrite' of theory' * rew_ord' * rls * bool * thm' *
11.586 + term * (term * term list)
11.587 +| Rewrite_Asm' of theory' * rew_ord' * rls * bool * thm' *
11.588 + term * (term * term list)
11.589 +| Rewrite_Set_Inst' of theory' * bool * subst * rls *
11.590 + term * (term * term list)
11.591 +| Detail_Set_Inst' of theory' * bool * subst * rls *
11.592 + term * (term * term list)
11.593 +| Rewrite_Set' of theory' * bool * rls * term * (term * term list)
11.594 +| Detail_Set' of theory' * bool * rls * term * (term * term list)
11.595 +| End_Detail' of (term * (term list)) (*see End_Trans'*)
11.596 +| End_Ruleset' of term
11.597 +| Derive' of rls
11.598 +| Calculate' of theory' * string * term * (term * thm')
11.599 + (*WN.29.4.03 asm?: * term list??*)
11.600 +| Substitute' of subte (*the 'substitution': terms of type bool*)
11.601 + * term (*to be substituted in*)
11.602 + * term (*resulting from the substitution*)
11.603 +| Apply_Assumption' of term list * term
11.604 +
11.605 +| Take' of term | Take_Inst' of term
11.606 +| Group' of (con * int list * term)
11.607 +| Subproblem' of (spec *
11.608 + (ori list) * (*filled in assod Subproblem'*)
11.609 + term * (*-"-, headline of calc-head *)
11.610 + fmz_ *
11.611 + term) (*Subproblem(dom,pbl)*)
11.612 +| CAScmd' of term
11.613 +| End_Subproblem' of term (*???*)
11.614 +| Split_And' of term | Conclude_And' of term
11.615 +| Split_Or' of term | Conclude_Or' of term
11.616 +| Begin_Trans' of term | End_Trans' of (term * (term list))
11.617 +| Begin_Sequ' | End_Sequ'(* substitute root.env*)
11.618 +| Split_Intersect' of term | End_Intersect' of term
11.619 +| Check_elementwise' of (*special case:*)
11.620 + term * (*(1)the current formula: [x=1,x=...]*)
11.621 + string * (*(2)the pred from Check_elementwise *)
11.622 + (term * (*(3)composed from (1) and (2): {x. pred}*)
11.623 + term list) (*20.5.03 assumptions*)
11.624 +
11.625 +| Or_to_List' of term * term (* (a | b, [a,b]) *)
11.626 +| Collect_Trues' of term
11.627 +
11.628 +| Empty_Tac_ | Tac_ of (*for dummies*)
11.629 + theory *
11.630 + string * (*form*)
11.631 + string * (*in Tac*)
11.632 + string (*result of Tac".."*)
11.633 +| User' (*internal for ets*) | End_Proof'';(*End_Proof:inout*)
11.634 +
11.635 +fun tac_2str ma = case ma of
11.636 + Init_Proof' (ppc, spec) =>
11.637 + "Init_Proof' "^(pair2str (strs2str ppc, spec2str spec))
11.638 + | Model_Problem' (pblID,_,_) => "Model_Problem' "^(strs2str pblID )
11.639 + | Refine_Tacitly'(p,prefin,domID,metID,itms)=>
11.640 + "Refine_Tacitly' ("
11.641 + ^(strs2str p)^", "^(strs2str prefin)^", "
11.642 + ^domID^", "^(strs2str metID)^", pbl-itms)"
11.643 + | Refine_Problem' ms => "Refine_Problem' ("^(*matchs2str ms*)"..."^")"
11.644 +(*| Match_Problem' (pI, (ok, (itms, pre))) =>
11.645 + "Match_Problem' "^(spair2str (strs2str pI,
11.646 + spair2str (bool2str ok,
11.647 + spair2str ("itms2str_ itms",
11.648 + "items2str pre"))))*)
11.649 + | Add_Given' cterm' => "Add_Given' "(*^cterm'*)
11.650 + | Del_Given' cterm' => "Del_Given' "(*^cterm'*)
11.651 + | Add_Find' cterm' => "Add_Find' "(*^cterm'*)
11.652 + | Del_Find' cterm' => "Del_Find' "(*^cterm'*)
11.653 + | Add_Relation' cterm' => "Add_Relation' "(*^cterm'*)
11.654 + | Del_Relation' cterm' => "Del_Relation' "(*^cterm'*)
11.655 +
11.656 + | Specify_Theory' domID => "Specify_Theory' "^(quote domID )
11.657 + | Specify_Problem' (pI, (ok, (itms, pre))) =>
11.658 + "Specify_Problem' "^(spair2str (strs2str pI,
11.659 + spair2str (bool2str ok,
11.660 + spair2str ("itms2str_ itms",
11.661 + "items2str pre"))))
11.662 + | Specify_Method' (pI,oris,itms) =>
11.663 + "Specify_Method' ("^metID2str pI^", "^oris2str oris^", )"
11.664 +
11.665 + | Apply_Method' (metID,_,_) => "Apply_Method' "^(strs2str metID)
11.666 + | Check_Postcond' (pblID,(scval,asm)) =>
11.667 + "Check_Postcond' "^(spair2str(strs2str pblID,
11.668 + spair2str (term2str scval, strs2str asm)))
11.669 +
11.670 + | Free_Solve' => "Free_Solve'"
11.671 +
11.672 + | Rewrite_Inst' (*subs,thm'*) _ =>
11.673 + "Rewrite_Inst' "(*^(pair2str (subs2str subs, spair2str thm'))*)
11.674 + | Rewrite' thm' => "Rewrite' "(*^(spair2str thm')*)
11.675 + | Rewrite_Asm' thm' => "Rewrite_Asm' "(*^(spair2str thm')*)
11.676 + | Rewrite_Set_Inst' (*subs,thm'*) _ =>
11.677 + "Rewrite_Set_Inst' "(*^(pair2str (subs2str subs, quote rls))*)
11.678 + | Rewrite_Set'(thy',pasm,rls',f,(f',asm))
11.679 + => "Rewrite_Set' ("^thy'^","^(bool2str pasm)^","^(id_rls rls')^","
11.680 + ^(Syntax.string_of_term (thy2ctxt' "Isac") f)^",("^(Syntax.string_of_term (thy2ctxt' "Isac") f')
11.681 + ^","^((strs2str o (map (Syntax.string_of_term (thy2ctxt' "Isac")))) asm)^"))"
11.682 +
11.683 + | End_Detail' _ => "End_Detail' xxx"
11.684 + | Detail_Set' _ => "Detail_Set' xxx"
11.685 + | Detail_Set_Inst' _ => "Detail_Set_Inst' xxx"
11.686 +
11.687 + | Derive' rls => "Derive' "^id_rls rls
11.688 + | Calculate' _ => "Calculate' "
11.689 + | Substitute' subs => "Substitute' "(*^(subs2str subs)*)
11.690 + | Apply_Assumption' ct's => "Apply_Assumption' "(*^(strs2str ct's)*)
11.691 +
11.692 + | Take' cterm' => "Take' "(*^(quote cterm' )*)
11.693 + | Take_Inst' cterm' => "Take_Inst' "(*^(quote cterm' )*)
11.694 + | Group' (con, ints, _) =>
11.695 + "Group' "^(pair2str (con2str con, ints2str ints))
11.696 + | Subproblem' (spec, oris, _,_,pbl_form) =>
11.697 + "Subproblem' "(*^(pair2str (domID, strs2str ,...))*)
11.698 + | End_Subproblem' _ => "End_Subproblem'"
11.699 + | CAScmd' cterm' => "CAScmd' "(*^(quote cterm')*)
11.700 +
11.701 + | Empty_Tac_ => "Empty_Tac_"
11.702 + | User' => "User'"
11.703 + | Tac_ (_,form,id,result) => "Tac_ (thy,"^form^","^id^","^result^")"
11.704 + | _ => "tac_2str not impl. for arg";
11.705 +
11.706 +(*'executed tactics' (tac_s) with local environment etc.;
11.707 + used for continuing eval script + for generate*)
11.708 +type ets =
11.709 + (loc_ * (* of tactic in scr, tactic (weakly) associated with tac_*)
11.710 + (tac_ * (* (for generate) *)
11.711 + env * (* with 'tactic=result' as a rule, tactic ev. _not_ ready:
11.712 + for handling 'parallel let'*)
11.713 + env * (* with results of (ready) tacs *)
11.714 + term * (* itr_arg of tactic, for upd. env at Repeat, Try*)
11.715 + term * (* result value of the tac *)
11.716 + safe))
11.717 + list;
11.718 +val Ets = []:ets;
11.719 +
11.720 +
11.721 +fun ets2s (l,(m,eno,env,iar,res,s)) =
11.722 + "\n("^(loc_2str l)^",("^(tac_2str m)^
11.723 + ",\n ens= "^(subst2str eno)^
11.724 + ",\n env= "^(subst2str env)^
11.725 + ",\n iar= "^(Syntax.string_of_term (thy2ctxt' "Isac") iar)^
11.726 + ",\n res= "^(Syntax.string_of_term (thy2ctxt' "Isac") res)^
11.727 + ",\n "^(safe2str s)^"))";
11.728 +fun ets2str (ets:ets) = (strs2str o (map ets2s)) ets;
11.729 +
11.730 +
11.731 +type envp =(*9.5.03: unused, delete with field in ptree.PblObj FIXXXME*)
11.732 + (int * term list) list * (*assoc-list: args of met*)
11.733 + (int * rls) list * (*assoc-list: tacs already done ///15.9.00*)
11.734 + (int * ets) list * (*assoc-list: tacs etc. already done*)
11.735 + (string * pos) list; (*asms * from where*)
11.736 +val empty_envp = ([],[],[],[]):envp;
11.737 +
11.738 +datatype ppobj =
11.739 + PrfObj of {cell : lrd option, (*where in form tac has been applied*)
11.740 + (*^^^FIXME.WN0607 rename this field*)
11.741 + form : term,
11.742 + tac : tac, (* also in istate*)
11.743 + loc : istate option * istate option, (*for form, result
11.744 +13.8.02: (NONE,NONE) <==> e_istate ! see update_loc, get_loc*)
11.745 + branch: branch,
11.746 + result: term * term list,
11.747 + ostate: ostate} (*Complete <=> result is OK*)
11.748 + | PblObj of {cell : lrd option,(*unused: meaningful only for some _Prf_Obj*)
11.749 + fmz : fmz, (*from init:FIXME never use this spec;-drop*)
11.750 + origin: (ori list) * (*representation from fmz+pbt
11.751 + for efficiently adding items in probl, meth*)
11.752 + spec * (*updated by Refine_Tacitly*)
11.753 + term, (*headline of calc-head, as calculated
11.754 + initially(!)*)
11.755 + (*# the origin of a root-pbl is created from fmz
11.756 + (thus providing help for input to the user),
11.757 + # the origin of a sub-pbl is created from the argument
11.758 + -list of a script-tac 'SubProblem (spec) [arg-list]'
11.759 + by 'match_ags'*)
11.760 + spec : spec, (*explicitly input*)
11.761 + probl : itm list, (*itms explicitly input*)
11.762 + meth : itm list, (*itms automatically added to copy of probl
11.763 + TODO: input like to 'probl'*)
11.764 + env : istate option,(*for problem with initac in script*)
11.765 + loc : istate option * istate option, (*for pbl+met * result*)
11.766 + branch: branch,
11.767 + result: term * term list,
11.768 + ostate: ostate}; (*Complete <=> result is _proven_ OK*)
11.769 +
11.770 +(*.this tree contains isac's calculations; TODO.WN03 rename to ctree;
11.771 + the structure has been copied from an early version of Theorema(c);
11.772 + it has the disadvantage, that there is no space
11.773 + for the first tactic in a script generating the first formula at (p,Frm);
11.774 + this trouble has been covered by 'init_form' and 'Take' so far,
11.775 + but it is crucial if the first tactic in a script is eg. 'Subproblem';
11.776 + see 'type tac ', Apply_Method.
11.777 +.*)
11.778 +datatype ptree =
11.779 + EmptyPtree
11.780 + | Nd of ppobj * (ptree list);
11.781 +val e_ptree = EmptyPtree;
11.782 +
11.783 +fun rep_prfobj (PrfObj {cell,form,tac,loc,branch,result,ostate}) =
11.784 + {cell=cell,form=form,tac=tac,loc=loc,branch=branch,result=result,ostate=ostate};
11.785 +fun rep_pblobj (PblObj {cell,origin,fmz,spec,probl,meth,env,
11.786 + loc,branch,result,ostate}) =
11.787 + {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,meth=meth,
11.788 + env=env,loc=loc,branch=branch,result=result,ostate=ostate};
11.789 +fun is_prfobj (PrfObj _) = true
11.790 + | is_prfobj _ =false;
11.791 +(*val is_prfobj' = get_obj is_prfobj; *)
11.792 +fun is_pblobj (PblObj _) = true
11.793 + | is_pblobj _ = false;
11.794 +(*val is_pblobj' = get_obj is_pblobj; 'Error: unbound constructor get_obj'*)
11.795 +
11.796 +
11.797 +exception PTREE of string;
11.798 +fun nth _ [] = raise PTREE "nth _ []"
11.799 + | nth 1 (x::xs) = x
11.800 + | nth n (x::xs) = nth (n-1) xs;
11.801 +(*> nth 2 [11,22,33]; -->> val it = 22 : int*)
11.802 +
11.803 +fun lev_up ([]:pos) = raise PTREE "lev_up []"
11.804 + | lev_up p = (drop_last p):pos;
11.805 +fun lev_on ([]:pos) = raise PTREE "lev_on []"
11.806 + | lev_on pos =
11.807 + let val len = length pos
11.808 + in (drop_last pos) @ [(nth len pos)+1] end;
11.809 +fun lev_onFrm ((p,_):pos') = (lev_on p,Frm):pos'
11.810 + | lev_onFrm p = raise PTREE ("*** lev_onFrm: pos'="^(pos'2str p));
11.811 +(*040216: for inform --> embed_deriv: remains on same level*)
11.812 +fun lev_back (([],_):pos') = raise PTREE "lev_on_back: called by ([],_)"
11.813 + | lev_back (p,_) =
11.814 + if last_elem p <= 1 then (p, Frm):pos'
11.815 + else ((drop_last p) @ [(nth (length p) p) - 1], Res);
11.816 +(*.increase pos by n within a level.*)
11.817 +fun pos_plus 0 pos = pos
11.818 + | pos_plus n ((p,Frm):pos') = pos_plus (n-1) (p, Res)
11.819 + | pos_plus n ((p, _):pos') = pos_plus (n-1) (lev_on p, Res);
11.820 +
11.821 +
11.822 +
11.823 +fun lev_pred ([]:pos) = raise PTREE "lev_pred []"
11.824 + | lev_pred (pos:pos) =
11.825 + let val len = length pos
11.826 + in ((drop_last pos) @ [(nth len pos)-1]):pos end;
11.827 +(*lev_pred [1,2,3];
11.828 +val it = [1,2,2] : pos
11.829 +> lev_pred [1];
11.830 +val it = [0] : pos *)
11.831 +
11.832 +fun lev_dn p = p @ [0];
11.833 +(*> (lev_dn o lev_on) [1,2,3];
11.834 +val it = [1,2,4,0] : pos *)
11.835 +(*fun lev_dn' ((p,p_):pos') = (lev_dn p, Frm):pos'; WN.3.12.03: never used*)
11.836 +fun lev_dnRes ((p,_):pos') = (lev_dn p, Res):pos';
11.837 +
11.838 +(*4.4.00*)
11.839 +fun lev_up_ ((p,Res):pos') = (lev_up p,Res):pos'
11.840 + | lev_up_ p' = raise error ("lev_up_: called for "^(pos'2str p'));
11.841 +fun lev_dn_ ((p,_):pos') = (lev_dn p,Res):pos'
11.842 +fun ind ((p,_):pos') = length p; (*WN050108 deprecated in favour of lev_of*)
11.843 +fun lev_of ((p,_):pos') = length p;
11.844 +
11.845 +
11.846 +(** convert ptree to a string **)
11.847 +
11.848 +(* convert a pos from list to string *)
11.849 +fun pr_pos ps = (space_implode "." (map string_of_int ps))^". ";
11.850 +(* show hd origin or form only *)
11.851 +fun pr_short (p:pos) (PblObj {origin = (ori,_,_),...}) =
11.852 + ((pr_pos p) ^ " ----- pblobj -----\n")
11.853 +(* ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^
11.854 + (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^
11.855 + "\n") *)
11.856 + | pr_short p (PrfObj {form = form,...}) =
11.857 + ((pr_pos p) ^ (term2str form) ^ "\n");
11.858 +(*
11.859 +fun pr_cell (p:pos) (PblObj {cell = c, origin = (ori,_,_),...}) =
11.860 + ((ints2str c) ^" "^
11.861 + ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^
11.862 + (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^
11.863 + "\n")
11.864 + | pr_cell p (PrfObj {cell = c, form = form,...}) =
11.865 + ((ints2str c) ^" "^ (term2str form) ^ "\n");
11.866 +*)
11.867 +
11.868 +(* convert ptree *)
11.869 +fun pr_ptree f pt =
11.870 + let
11.871 + fun pr_pt pfn _ EmptyPtree = ""
11.872 + | pr_pt pfn ps (Nd (b, [])) = pfn ps b
11.873 + | pr_pt pfn ps (Nd (b, ts)) = (pfn ps b)^
11.874 + (prts pfn (ps:pos) 1 ts)
11.875 + and prts pfn ps p [] = ""
11.876 + | prts pfn ps p (t::ts) = (pr_pt pfn (ps @ [p]) t)^
11.877 + (prts pfn ps (p+1) ts)
11.878 + in pr_pt f [] pt end;
11.879 +(*
11.880 +> fun prfn ps b = (pr_pos ps)^" "^b(*TODO*)^"\n";
11.881 +> val pt = ref EmptyPtree;
11.882 +> pt:=Nd("root",
11.883 + [Nd("xx1",[]),
11.884 + Nd("xx2",
11.885 + [Nd("xx2.1.",[]),
11.886 + Nd("xx2.2.",[])]),
11.887 + Nd("xx3",[])]);
11.888 +> writeln (pr_ptree prfn (!pt));
11.889 +*)
11.890 +
11.891 +
11.892 +(** access the branches of ptree **)
11.893 +
11.894 +fun ins_nth 1 e l = e::l
11.895 + | ins_nth n e [] = raise PTREE "ins_nth n e []"
11.896 + | ins_nth n e (l::ls) = l::(ins_nth (n-1) e ls);
11.897 +fun repl [] _ _ = raise PTREE "repl [] _ _"
11.898 + | repl (l::ls) 1 e = e::ls
11.899 + | repl (l::ls) n e = l::(repl ls (n-1) e);
11.900 +fun repl_app ls n e =
11.901 + let val lim = 1 + length ls
11.902 + in if n > lim then raise PTREE "repl_app: n > lim"
11.903 + else if n = lim then ls @ [e]
11.904 + else repl ls n e end;
11.905 +(*
11.906 +> repl [1,2,3] 2 22222;
11.907 +val it = [1,22222,3] : int list
11.908 +> repl_app [1,2,3,4] 5 5555;
11.909 +val it = [1,2,3,4,5555] : int list
11.910 +> repl_app [1,2,3] 2 22222;
11.911 +val it = [1,22222,3] : int list
11.912 +> repl_app [1] 2 22222 ;
11.913 +val it = [1,22222] : int list
11.914 +*)
11.915 +
11.916 +
11.917 +(*.get from obj at pos by f : ppobj -> 'a.*)
11.918 +fun get_obj f EmptyPtree (_:pos) = raise PTREE "get_obj f EmptyPtree"
11.919 + | get_obj f (Nd (b, _)) [] = f b
11.920 + | get_obj f (Nd (b, bs)) (p::ps) =
11.921 +(* val (f, Nd (b, bs), (p::ps)) = (I, pt, p);
11.922 + *)
11.923 + let val _ = (nth p bs) handle _ => raise PTREE ("get_obj: pos = "^
11.924 + (ints2str' (p::ps))^" does not exist");
11.925 + in (get_obj f (nth p bs) (ps:pos))
11.926 + (*before WN050419: 'wrong type..' raised also if pos doesn't exist*)
11.927 + handle _ => raise PTREE (*"get_obj: at pos = "^
11.928 + (ints2str' (p::ps))^" wrong type of ppobj"*)
11.929 + ("get_obj: pos = "^
11.930 + (ints2str' (p::ps))^" does not exist")
11.931 + end;
11.932 +fun get_nd EmptyPtree _ = raise PTREE "get_nd EmptyPtree"
11.933 + | get_nd n [] = n
11.934 + | get_nd (Nd (_,nds)) (pos as p::(ps:pos)) = (get_nd (nth p nds) ps)
11.935 + handle _ => raise PTREE ("get_nd: not existent pos = "^(ints2str' pos));
11.936 +
11.937 +
11.938 +(* for use by get_obj *)
11.939 +fun g_cell (PblObj {cell = c,...}) = NONE
11.940 + | g_cell (PrfObj {cell = c,...}) = c;(*WN0607 hack for quick introduction of lrd + rewrite-at (thms, calcs)*)
11.941 +fun g_form (PrfObj {form = f,...}) = f
11.942 + | g_form (PblObj {origin=(_,_,f),...}) = f;
11.943 +fun g_form' (Nd (PrfObj {form = f,...}, _)) = f
11.944 + | g_form' (Nd (PblObj {origin=(_,_,f),...}, _)) = f;
11.945 +(* | g_form _ = raise PTREE "g_form not for PblObj";*)
11.946 +fun g_origin (PblObj {origin = ori,...}) = ori
11.947 + | g_origin _ = raise PTREE "g_origin not for PrfObj";
11.948 +fun g_fmz (PblObj {fmz = f,...}) = f
11.949 + | g_fmz _ = raise PTREE "g_fmz not for PrfObj";
11.950 +fun g_spec (PblObj {spec = s,...}) = s
11.951 + | g_spec _ = raise PTREE "g_spec not for PrfObj";
11.952 +fun g_pbl (PblObj {probl = p,...}) = p
11.953 + | g_pbl _ = raise PTREE "g_pbl not for PrfObj";
11.954 +fun g_met (PblObj {meth = p,...}) = p
11.955 + | g_met _ = raise PTREE "g_met not for PrfObj";
11.956 +fun g_domID (PblObj {spec = (d,_,_),...}) = d
11.957 + | g_domID _ = raise PTREE "g_metID not for PrfObj";
11.958 +fun g_metID (PblObj {spec = (_,_,m),...}) = m
11.959 + | g_metID _ = raise PTREE "g_metID not for PrfObj";
11.960 +fun g_env (PblObj {env,...}) = env
11.961 + | g_env _ = raise PTREE "g_env not for PrfObj";
11.962 +fun g_loc (PblObj {loc = l,...}) = l
11.963 + | g_loc (PrfObj {loc = l,...}) = l;
11.964 +fun g_branch (PblObj {branch = b,...}) = b
11.965 + | g_branch (PrfObj {branch = b,...}) = b;
11.966 +fun g_tac (PblObj {spec = (d,p,m),...}) = Apply_Method m
11.967 + | g_tac (PrfObj {tac = m,...}) = m;
11.968 +fun g_result (PblObj {result = r,...}) = r
11.969 + | g_result (PrfObj {result = r,...}) = r;
11.970 +fun g_res (PblObj {result = (r,_),...}) = r
11.971 + | g_res (PrfObj {result = (r,_),...}) = r;
11.972 +fun g_res' (Nd (PblObj {result = (r,_),...}, _)) = r
11.973 + | g_res' (Nd (PrfObj {result = (r,_),...}, _)) = r;
11.974 +fun g_ostate (PblObj {ostate = r,...}) = r
11.975 + | g_ostate (PrfObj {ostate = r,...}) = r;
11.976 +fun g_ostate' (Nd (PblObj {ostate = r,...}, _)) = r
11.977 + | g_ostate' (Nd (PrfObj {ostate = r,...}, _)) = r;
11.978 +
11.979 +fun gpt_cell (Nd (PblObj {cell = c,...},_)) = NONE
11.980 + | gpt_cell (Nd (PrfObj {cell = c,...},_)) = c;
11.981 +
11.982 +(*in CalcTree/Subproblem an 'just_created_' model is created;
11.983 + this is filled to 'untouched' by Model/Refine_Problem*)
11.984 +fun just_created_ (PblObj {meth, probl, spec, ...}) =
11.985 + null meth andalso null probl andalso spec = e_spec;
11.986 +val e_origin = ([],e_spec,e_term): (ori list) * spec * term;
11.987 +
11.988 +fun just_created (pt,(p,_):pos') =
11.989 + let val ppobj = get_obj I pt p
11.990 + in is_pblobj ppobj andalso just_created_ ppobj end;
11.991 +
11.992 +(*.does the pos in the ctree exist ?.*)
11.993 +fun existpt pos pt = can (get_obj I pt) pos;
11.994 +(*.does the pos' in the ctree exist, ie. extra check for result in the node.*)
11.995 +fun existpt' ((p,p_):pos') pt =
11.996 + if can (get_obj I pt) p
11.997 + then case p_ of
11.998 + Res => get_obj g_ostate pt p = Complete
11.999 + | _ => true
11.1000 + else false;
11.1001 +
11.1002 +(*.is this position appropriate for calculating intermediate steps?.*)
11.1003 +fun is_interpos ((_, Res):pos') = true
11.1004 + | is_interpos _ = false;
11.1005 +
11.1006 +fun last_onlev pt pos = not (existpt (lev_on pos) pt);
11.1007 +
11.1008 +
11.1009 +(*.find the position of the next parent which is a PblObj in ptree.*)
11.1010 +fun par_pblobj pt ([]:pos) = ([]:pos)
11.1011 + | par_pblobj pt p =
11.1012 + let fun par pt [] = []
11.1013 + | par pt p = if is_pblobj (get_obj I pt p) then p
11.1014 + else par pt (lev_up p)
11.1015 + in par pt (lev_up p) end;
11.1016 +(* lev_up for hard_gen operating with pos = [...,0] *)
11.1017 +
11.1018 +(*.find the position and the children of the next parent which is a PblObj.*)
11.1019 +fun par_children (Nd (PblObj _, children)) ([]:pos) = (children, []:pos)
11.1020 + | par_children (pt as Nd (PblObj _, children)) p =
11.1021 + let fun par [] = (children, [])
11.1022 + | par p = let val Nd (obj, children) = get_nd pt p
11.1023 + in if is_pblobj obj then (children, p) else par (lev_up p)
11.1024 + end;
11.1025 + in par (lev_up p) end;
11.1026 +
11.1027 +(*.get the children of a node in ptree.*)
11.1028 +fun children (Nd (PblObj _, cn)) = cn
11.1029 + | children (Nd (PrfObj _, cn)) = cn;
11.1030 +
11.1031 +
11.1032 +(*.find the next parent, which is either a PblObj (return true)
11.1033 + or a PrfObj with tac = Detail_Set (return false).*)
11.1034 +(*FIXME.3.4.03:re-organize par_pbl_det after rls' --> rls*)
11.1035 +fun par_pbl_det pt ([]:pos) = (true, []:pos, Erls)
11.1036 + | par_pbl_det pt p =
11.1037 + let fun par pt [] = (true, [], Erls)
11.1038 + | par pt p = if is_pblobj (get_obj I pt p) then (true, p, Erls)
11.1039 + else case get_obj g_tac pt p of
11.1040 + (*Detail_Set rls' => (false, p, assoc_rls rls')
11.1041 + (*^^^--- before 040206 after ---vvv*)
11.1042 + |*)Rewrite_Set rls' => (false, p, assoc_rls rls')
11.1043 + | Rewrite_Set_Inst (_, rls') =>
11.1044 + (false, p, assoc_rls rls')
11.1045 + | _ => par pt (lev_up p)
11.1046 + in par pt (lev_up p) end;
11.1047 +
11.1048 +
11.1049 +
11.1050 +
11.1051 +(*.get from the whole ptree by f : ppobj -> 'a.*)
11.1052 +fun get_all f EmptyPtree = []
11.1053 + | get_all f (Nd (b, [])) = [f b]
11.1054 + | get_all f (Nd (b, bs)) = [f b] @ (get_alls f bs)
11.1055 +and get_alls f [] = []
11.1056 + | get_alls f pts = flat (map (get_all f) pts);
11.1057 +
11.1058 +
11.1059 +(*.insert obj b into ptree at pos, ev.overwriting this pos.*)
11.1060 +fun insert b EmptyPtree ([]:pos) = Nd (b, [])
11.1061 + | insert b EmptyPtree _ = raise PTREE "insert b Empty _"
11.1062 + | insert b (Nd ( _, _)) [] = raise PTREE "insert b _ []"
11.1063 + | insert b (Nd (b', bs)) (p::[]) =
11.1064 + Nd (b', repl_app bs p (Nd (b,[])))
11.1065 + | insert b (Nd (b', bs)) (p::ps) =
11.1066 + Nd (b', repl_app bs p (insert b (nth p bs) ps));
11.1067 +(*
11.1068 +> type ppobj = string;
11.1069 +> writeln (pr_ptree prfn (!pt));
11.1070 + val pt = ref Empty;
11.1071 + pt:= insert ("root":ppobj) EmptyPtree [];
11.1072 + pt:= insert ("xx1":ppobj) (!pt) [1];
11.1073 + pt:= insert ("xx2":ppobj) (!pt) [2];
11.1074 + pt:= insert ("xx3":ppobj) (!pt) [3];
11.1075 + pt:= insert ("xx2.1":ppobj) (!pt) [2,1];
11.1076 + pt:= insert ("xx2.2":ppobj) (!pt) [2,2];
11.1077 + pt:= insert ("xx2.1.1":ppobj) (!pt) [2,1,1];
11.1078 + pt:= insert ("xx2.1.2":ppobj) (!pt) [2,1,2];
11.1079 + pt:= insert ("xx2.1.3":ppobj) (!pt) [2,1,3];
11.1080 +*)
11.1081 +
11.1082 +(*.insert children to a node without children.*)
11.1083 +(*compare: fun insert*)
11.1084 +fun ins_chn _ EmptyPtree (_:pos) = raise PTREE "ins_chn: EmptyPtree"
11.1085 + | ins_chn ns (Nd _) [] = raise PTREE "ins_chn: pos = []"
11.1086 + | ins_chn ns (Nd (b, bs)) (p::[]) =
11.1087 + if p > length bs then raise PTREE "ins_chn: pos not existent"
11.1088 + else let val Nd (b', bs') = nth p bs
11.1089 + in if null bs' then Nd (b, repl_app bs p (Nd (b', ns)))
11.1090 + else raise PTREE "ins_chn: pos mustNOT be overwritten" end
11.1091 + | ins_chn ns (Nd (b, bs)) (p::ps) =
11.1092 + Nd (b, repl_app bs p (ins_chn ns (nth p bs) ps));
11.1093 +
11.1094 +(* print_depth 11;ins_chn;print_depth 3; ###insert#########################*);
11.1095 +
11.1096 +
11.1097 +(** apply f to obj at pos, f: ppobj -> ppobj **)
11.1098 +
11.1099 +fun appl_to_node f (Nd (b,bs)) = Nd (f b, bs);
11.1100 +fun appl_obj f EmptyPtree [] = EmptyPtree
11.1101 + | appl_obj f EmptyPtree _ = raise PTREE "appl_obj f Empty _"
11.1102 + | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs)
11.1103 + | appl_obj f (Nd (b, bs)) (p::[]) =
11.1104 + Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs))
11.1105 + | appl_obj f (Nd (b, bs)) (p::ps) =
11.1106 + Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos)));
11.1107 +
11.1108 +(* for use by appl_obj *)
11.1109 +fun repl_form f (PrfObj {cell=c,form= _,tac=tac,loc=loc,
11.1110 + branch=branch,result=result,ostate=ostate}) =
11.1111 + PrfObj {cell=c,form= f,tac=tac,loc=loc,
11.1112 + branch=branch,result=result,ostate=ostate}
11.1113 + | repl_form _ _ = raise PTREE "repl_form takes no PblObj";
11.1114 +fun repl_pbl x (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1115 + spec=spec,probl=_,meth=meth,env=env,loc=loc,
11.1116 + branch=branch,result=result,ostate=ostate}) =
11.1117 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl= x,
11.1118 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
11.1119 + | repl_pbl _ _ = raise PTREE "repl_pbl takes no PrfObj";
11.1120 +fun repl_met x (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1121 + spec=spec,probl=probl,meth=_,env=env,loc=loc,
11.1122 + branch=branch,result=result,ostate=ostate}) =
11.1123 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
11.1124 + meth= x,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
11.1125 + | repl_met _ _ = raise PTREE "repl_pbl takes no PrfObj";
11.1126 +
11.1127 +fun repl_spec x (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1128 + spec= _,probl=probl,meth=meth,env=env,loc=loc,
11.1129 + branch=branch,result=result,ostate=ostate}) =
11.1130 + PblObj {cell=cell,origin=origin,fmz=fmz,spec= x,probl=probl,
11.1131 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
11.1132 + | repl_spec _ _ = raise PTREE "repl_domID takes no PrfObj";
11.1133 +fun repl_domID x (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1134 + spec=(_,p,m),probl=probl,meth=meth,env=env,loc=loc,
11.1135 + branch=branch,result=result,ostate=ostate}) =
11.1136 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(x,p,m),probl=probl,
11.1137 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
11.1138 + | repl_domID _ _ = raise PTREE "repl_domID takes no PrfObj";
11.1139 +fun repl_pblID x (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1140 + spec=(d,_,m),probl=probl,meth=meth,env=env,loc=loc,
11.1141 + branch=branch,result=result,ostate=ostate}) =
11.1142 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,x,m),probl=probl,
11.1143 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
11.1144 + | repl_pblID _ _ = raise PTREE "repl_pblID takes no PrfObj";
11.1145 +fun repl_metID x (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1146 + spec=(d,p,_),probl=probl,meth=meth,env=env,loc=loc,
11.1147 + branch=branch,result=result,ostate=ostate}) =
11.1148 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,p,x),probl=probl,
11.1149 + meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
11.1150 + | repl_metID _ _ = raise PTREE "repl_metID takes no PrfObj";
11.1151 +
11.1152 +fun repl_result l f' s (PrfObj {cell=cell,form=form,tac=tac,loc=_,
11.1153 + branch=branch,result = _ ,ostate = _}) =
11.1154 + PrfObj {cell=cell,form=form,tac=tac,loc= l,
11.1155 + branch=branch,result = f',ostate = s}
11.1156 + | repl_result l f' s (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1157 + spec=spec,probl=probl,meth=meth,env=env,loc=_,
11.1158 + branch=branch,result= _ ,ostate= _}) =
11.1159 + PblObj {cell=cell,origin=origin,fmz=fmz,
11.1160 + spec=spec,probl=probl,meth=meth,env=env,loc= l,
11.1161 + branch=branch,result= f',ostate= s};
11.1162 +
11.1163 +fun repl_tac x (PrfObj {cell=cell,form=form,tac= _,loc=loc,
11.1164 + branch=branch,result=result,ostate=ostate}) =
11.1165 + PrfObj {cell=cell,form=form,tac= x,loc=loc,
11.1166 + branch=branch,result=result,ostate=ostate}
11.1167 + | repl_tac _ _ = raise PTREE "repl_tac takes no PblObj";
11.1168 +
11.1169 +fun repl_branch b (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1170 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
11.1171 + branch= _,result=result,ostate=ostate}) =
11.1172 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
11.1173 + meth=meth,env=env,loc=loc,branch= b,result=result,ostate=ostate}
11.1174 + | repl_branch b (PrfObj {cell=cell,form=form,tac=tac,loc=loc,
11.1175 + branch= _,result=result,ostate=ostate}) =
11.1176 + PrfObj {cell=cell,form=form,tac=tac,loc=loc,
11.1177 + branch= b,result=result,ostate=ostate};
11.1178 +
11.1179 +fun repl_env e
11.1180 + (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1181 + spec=spec,probl=probl,meth=meth,env=_,loc=loc,
11.1182 + branch=branch,result=result,ostate=ostate}) =
11.1183 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
11.1184 + meth=meth,env=e,loc=loc,branch=branch,
11.1185 + result=result,ostate=ostate}
11.1186 + | repl_env _ _ = raise PTREE "repl_ets takes no PrfObj";
11.1187 +
11.1188 +fun repl_oris oris
11.1189 + (PblObj {cell=cell,origin=(_,spe,hdf),fmz=fmz,
11.1190 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
11.1191 + branch=branch,result=result,ostate=ostate}) =
11.1192 + PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl,
11.1193 + meth=meth,env=env,loc=loc,branch=branch,
11.1194 + result=result,ostate=ostate}
11.1195 + | repl_oris _ _ = raise PTREE "repl_oris takes no PrfObj";
11.1196 +fun repl_orispec spe
11.1197 + (PblObj {cell=cell,origin=(oris,_,hdf),fmz=fmz,
11.1198 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
11.1199 + branch=branch,result=result,ostate=ostate}) =
11.1200 + PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl,
11.1201 + meth=meth,env=env,loc=loc,branch=branch,
11.1202 + result=result,ostate=ostate}
11.1203 + | repl_orispec _ _ = raise PTREE "repl_orispec takes no PrfObj";
11.1204 +
11.1205 +fun repl_loc l (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1206 + spec=spec,probl=probl,meth=meth,env=env,loc=_,
11.1207 + branch=branch,result=result,ostate=ostate}) =
11.1208 + PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
11.1209 + meth=meth,env=env,loc=l,branch=branch,result=result,ostate=ostate}
11.1210 + | repl_loc l (PrfObj {cell=cell,form=form,tac=tac,loc=_,
11.1211 + branch=branch,result=result,ostate=ostate}) =
11.1212 + PrfObj {cell=cell,form=form,tac=tac,loc= l,
11.1213 + branch=branch,result=result,ostate=ostate};
11.1214 +(*
11.1215 +fun uni__cid cell'
11.1216 + (PblObj {cell=cell,origin=origin,fmz=fmz,
11.1217 + spec=spec,probl=probl,meth=meth,env=env,loc=loc,
11.1218 + branch=branch,result=result,ostate=ostate}) =
11.1219 + PblObj {cell=cell union cell',origin=origin,fmz=fmz,spec=spec,probl=probl,
11.1220 + meth=meth,env=env,loc=loc,branch=branch,
11.1221 + result=result,ostate=ostate}
11.1222 + | uni__cid cell'
11.1223 + (PrfObj {cell=cell,form=form,tac=tac,loc=loc,
11.1224 + branch=branch,result=result,ostate=ostate}) =
11.1225 + PrfObj {cell=cell union cell',form=form,tac=tac,loc=loc,
11.1226 + branch=branch,result=result,ostate=ostate};
11.1227 +*)
11.1228 +
11.1229 +(*WN050219 put here for interpreting code for cut_tree below...*)
11.1230 +type ocalhd =
11.1231 + bool * (*ALL itms+preconds true*)
11.1232 + pos_ * (*model belongs to Problem | Method*)
11.1233 + term * (*header: Problem... or Cas
11.1234 + FIXXXME.12.03: item! for marking syntaxerrors*)
11.1235 + itm list * (*model: given, find, relate*)
11.1236 + ((bool * term) list) *(*model: preconds*)
11.1237 + spec; (*specification*)
11.1238 +val e_ocalhd = (false, Und, e_term, [e_itm], [(false, e_term)], e_spec);
11.1239 +
11.1240 +datatype ptform =
11.1241 + Form of term
11.1242 + | ModSpec of ocalhd;
11.1243 +val e_ptform = Form e_term;
11.1244 +val e_ptform' = ModSpec e_ocalhd;
11.1245 +
11.1246 +
11.1247 +
11.1248 +(*.applies (snd f) to the branches at a pos if ((fst f) b),
11.1249 + f : (ppobj -> bool) * (int -> ptree list -> ptree list).*)
11.1250 +
11.1251 +fun appl_branch f EmptyPtree [] = (EmptyPtree, false)
11.1252 + | appl_branch f EmptyPtree _ = raise PTREE "appl_branch f Empty _"
11.1253 + | appl_branch f (Nd ( _, _)) [] = raise PTREE "appl_branch f _ []"
11.1254 + | appl_branch f (Nd (b, bs)) (p::[]) =
11.1255 + if (fst f) b then (Nd (b, (snd f) (p:posel) bs), true)
11.1256 + else (Nd (b, bs), false)
11.1257 + | appl_branch f (Nd (b, bs)) (p::ps) =
11.1258 + let val (b',bool) = appl_branch f (nth p bs) ps
11.1259 + in (Nd (b, repl_app bs p b'), bool) end;
11.1260 +
11.1261 +(* for cut_level; appl_branch(deprecated) *)
11.1262 +fun test_trans (PrfObj{branch = Transitive,...}) = true
11.1263 + | test_trans (PblObj{branch = Transitive,...}) = true
11.1264 + | test_trans _ = false;
11.1265 +
11.1266 +fun is_pblobj' pt (p:pos) =
11.1267 + let val ppobj = get_obj I pt p
11.1268 + in is_pblobj ppobj end;
11.1269 +
11.1270 +
11.1271 +fun delete_result pt (p:pos) =
11.1272 + (appl_obj (repl_result (fst (get_obj g_loc pt p), NONE)
11.1273 + (e_term,[]) Incomplete) pt p);
11.1274 +
11.1275 +fun del_res (PblObj {cell, fmz, origin, spec, probl, meth,
11.1276 + env, loc=(l1,_), branch, result, ostate}) =
11.1277 + PblObj {cell=cell,fmz=fmz,origin=origin,spec=spec,probl=probl,meth=meth,
11.1278 + env=env, loc=(l1,NONE), branch=branch, result=(e_term,[]),
11.1279 + ostate=Incomplete}
11.1280 +
11.1281 + | del_res (PrfObj {cell, form, tac, loc=(l1,_), branch, result, ostate}) =
11.1282 + PrfObj {cell=cell,form=form,tac=tac, loc=(l1,NONE), branch=branch,
11.1283 + result=(e_term,[]), ostate=Incomplete};
11.1284 +
11.1285 +
11.1286 +(*
11.1287 +fun update_fmz pt pos x = appl_obj (repl_fmz x) pt pos;
11.1288 + 1.00 not used anymore*)
11.1289 +
11.1290 +(*FIXME.WN.12.03: update_X X pos pt -> pt could be chained by o (efficiency?)*)
11.1291 +fun update_env pt pos x = appl_obj (repl_env x) pt pos;
11.1292 +fun update_domID pt pos x = appl_obj (repl_domID x) pt pos;
11.1293 +fun update_pblID pt pos x = appl_obj (repl_pblID x) pt pos;
11.1294 +fun update_metID pt pos x = appl_obj (repl_metID x) pt pos;
11.1295 +fun update_spec pt pos x = appl_obj (repl_spec x) pt pos;
11.1296 +
11.1297 +fun update_pbl pt pos x = appl_obj (repl_pbl x) pt pos;
11.1298 +fun update_pblppc pt pos x = appl_obj (repl_pbl x) pt pos;
11.1299 +
11.1300 +fun update_met pt pos x = appl_obj (repl_met x) pt pos;
11.1301 +(*1.09.01 ----
11.1302 +fun update_metppc pt pos x =
11.1303 + let val {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,...} =
11.1304 + get_obj g_met pt pos
11.1305 + in appl_obj (repl_met
11.1306 + {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,ppc=x})
11.1307 + pt pos end;*)
11.1308 +fun update_metppc pt pos x = appl_obj (repl_met x) pt pos;
11.1309 +
11.1310 +(*fun union_cid pt pos x = appl_obj (uni__cid x) pt pos;*)
11.1311 +
11.1312 +fun update_branch pt pos x = appl_obj (repl_branch x) pt pos;
11.1313 +fun update_tac pt pos x = appl_obj (repl_tac x) pt pos;
11.1314 +
11.1315 +fun update_oris pt pos x = appl_obj (repl_oris x) pt pos;
11.1316 +fun update_orispec pt pos x = appl_obj (repl_orispec x) pt pos;
11.1317 +
11.1318 + (*done by append_* !! 3.5.02; ununsed WN050305 thus outcommented
11.1319 +fun update_loc pt (p,_) (ScrState ([],[],NONE,
11.1320 + Const ("empty",_),Sundef,false)) =
11.1321 + appl_obj (repl_loc (NONE,NONE)) pt p
11.1322 + | update_loc pt (p,Res) x =
11.1323 + let val (lform,_) = get_obj g_loc pt p
11.1324 + in appl_obj (repl_loc (lform,SOME x)) pt p end
11.1325 +
11.1326 + | update_loc pt (p,_) x =
11.1327 + let val (_,lres) = get_obj g_loc pt p
11.1328 + in appl_obj (repl_loc (SOME x,lres)) pt p end;-------------*)
11.1329 +
11.1330 +(*WN050305 for handling cut_tree in cappend_atomic -- TODO redesign !*)
11.1331 +fun update_loc' pt p iss = appl_obj (repl_loc iss) pt p;
11.1332 +
11.1333 +(*13.8.02---------------------------
11.1334 +fun get_loc EmptyPtree _ = NONE
11.1335 + | get_loc pt (p,Res) =
11.1336 + let val (lfrm,lres) = get_obj g_loc pt p
11.1337 + in if lres = e_istate then lfrm else lres end
11.1338 + | get_loc pt (p,_) =
11.1339 + let val (lfrm,lres) = get_obj g_loc pt p
11.1340 + in if lfrm = e_istate then lres else lfrm end; 5.10.00: too liberal ?*)
11.1341 +(*13.8.02: options, because istate is no equalitype any more*)
11.1342 +fun get_loc EmptyPtree _ = e_istate
11.1343 + | get_loc pt (p,Res) =
11.1344 + (case get_obj g_loc pt p of
11.1345 + (SOME i, NONE) => i
11.1346 + | (NONE , NONE) => e_istate
11.1347 + | (_ , SOME i) => i)
11.1348 + | get_loc pt (p,_) =
11.1349 + (case get_obj g_loc pt p of
11.1350 + (NONE , SOME i) => i (*13.8.02 just copied from ^^^: too liberal ?*)
11.1351 + | (NONE , NONE) => e_istate
11.1352 + | (SOME i, _) => i);
11.1353 +val get_istate = get_loc; (*3.5.02*)
11.1354 +
11.1355 +(*.collect the assumptions within a problem up to a certain position.*)
11.1356 +type asms = (term * pos) list;(*WN0502 should be (pos' * term) list
11.1357 + ...........===^===*)
11.1358 +
11.1359 +fun get_asm (b:pos, p:pos) (Nd (PblObj {result=(_,asm),...},_)) =
11.1360 + ((*writeln ("### get_asm PblObj:(b,p)= "^
11.1361 + (pair2str(ints2str b, ints2str p)));*)
11.1362 + (map (rpair b) asm):asms)
11.1363 + | get_asm (b, p) (Nd (PrfObj {result=(_,asm),...}, [])) =
11.1364 + ((*writeln ("### get_asm PrfObj []:(b,p)= "^
11.1365 + (pair2str(ints2str b, ints2str p)));*)
11.1366 + (map (rpair b) asm))
11.1367 + | get_asm (b, p:pos) (Nd (PrfObj _, nds)) =
11.1368 + let (*val _= writeln ("### get_asm PrfObj nds:(b,p)= "^
11.1369 + (pair2str(ints2str b, ints2str p)));*)
11.1370 + val levdn =
11.1371 + if p <> [] then (b @ [hd p]:pos, tl p:pos)
11.1372 + else (b @ [1], [99999]) (*_deeper_ nesting is always _before_ p*)
11.1373 + in gets_asm levdn 1 nds end
11.1374 +and gets_asm _ _ [] = []
11.1375 + | gets_asm (b, p' as p::ps) i (nd::nds) =
11.1376 + if p < i then []
11.1377 + else ((*writeln ("### gets_asm: (b,p')= "^(pair2str(ints2str b,
11.1378 + ints2str p')));*)
11.1379 + (get_asm (b @ [i], ps) nd) @ (gets_asm (b, p') (i + 1) nds));
11.1380 +
11.1381 +fun get_assumptions_ (Nd (PblObj {result=(r,asm),...}, cn)) (([], _):pos') =
11.1382 + if r = e_term then gets_asm ([], [99999]) 1 cn
11.1383 + else map (rpair []) asm
11.1384 + | get_assumptions_ pt (p,p_) =
11.1385 + let val (cn, base) = par_children pt p
11.1386 + val offset = drop (length base, p)
11.1387 + val base' = replicate (length base) 1
11.1388 + val offset' = case p_ of
11.1389 + Frm => let val (qs,q) = split_last offset
11.1390 + in qs @ [q - 1] end
11.1391 + | _ => offset
11.1392 + (*val _= writeln ("... get_assumptions: (b,o)= "^
11.1393 + (pair2str(ints2str base',ints2str offset)))*)
11.1394 + in gets_asm (base', offset) 1 cn end;
11.1395 +
11.1396 +
11.1397 +(*---------
11.1398 +end
11.1399 +
11.1400 +open Ptree;
11.1401 +----------*)
11.1402 +
11.1403 +(*pos of the formula on FE relative to the current pos,
11.1404 + which is the next writepos*)
11.1405 +fun pre_pos ([]:pos) = []:pos
11.1406 + | pre_pos pp =
11.1407 + let val (ps,p) = split_last pp
11.1408 + in case p of 1 => ps | n => ps @ [n-1] end;
11.1409 +
11.1410 +(*WN.20.5.03 ... but not used*)
11.1411 +fun posless [] (_::_) = true
11.1412 + | posless (_::_) [] = false
11.1413 + | posless (p::ps) (q::qs) = if p = q then posless ps qs else p < q;
11.1414 +(* posless [2,3,4] [3,4,5];
11.1415 +true
11.1416 +> posless [2,3,4] [1,2,3];
11.1417 +false
11.1418 +> posless [2,3] [2,3,4];
11.1419 +true
11.1420 +> posless [2,3,4] [2,3];
11.1421 +false
11.1422 +> posless [6] [6,5,2];
11.1423 +true
11.1424 ++++ see Isabelle/../library.ML*)
11.1425 +
11.1426 +
11.1427 +(**.development for extracting an 'interval' from ptree.**)
11.1428 +
11.1429 +(*version 1 stopped 8.03 in favour of get_interval with !!!move_dn
11.1430 + actually used (inefficient) version with move_dn: see modspec.sml*)
11.1431 +local
11.1432 +
11.1433 +fun hdp [] = 1 | hdp [0] = 1 | hdp x = hd x;(*start with first*)
11.1434 +fun hdq [] = 99999 | hdq [0] = 99999 | hdq x = hd x;(*take until last*)
11.1435 +fun tlp [] = [0] | tlp [_] = [0] | tlp x = tl x;
11.1436 +fun tlq [] = [99999] | tlq [_] = [99999] | tlq x = tl x;
11.1437 +
11.1438 +fun getnd i (b,p) q (Nd (po, nds)) =
11.1439 + (if i <= 0 then [[b]] else []) @
11.1440 + (getnds (i-1) true (b@[hdp p], tlp p) (tlq q)
11.1441 + (take_fromto (hdp p) (hdq q) nds))
11.1442 +
11.1443 +and getnds _ _ _ _ [] = [] (*no children*)
11.1444 + | getnds i _ (b,p) q [nd] = (getnd i (b,p) q nd) (*l+r-margin*)
11.1445 +
11.1446 + | getnds i true (b,p) q [n1, n2] = (*l-margin, r-margin*)
11.1447 + (getnd i ( b, p ) [99999] n1) @
11.1448 + (getnd ~99999 (lev_on b,[0]) q n2)
11.1449 +
11.1450 + | getnds i _ (b,p) q [n1, n2] = (*intern, r-margin*)
11.1451 + (getnd i ( b,[0]) [99999] n1) @
11.1452 + (getnd ~99999 (lev_on b,[0]) q n2)
11.1453 +
11.1454 + | getnds i true (b,p) q (nd::(nds as _::_)) = (*l-margin, intern*)
11.1455 + (getnd i ( b, p ) [99999] nd) @
11.1456 + (getnds ~99999 false (lev_on b,[0]) q nds)
11.1457 +
11.1458 + | getnds i _ (b,p) q (nd::(nds as _::_)) = (*intern, ...*)
11.1459 + (getnd i ( b,[0]) [99999] nd) @
11.1460 + (getnds ~99999 false (lev_on b,[0]) q nds);
11.1461 +in
11.1462 +(*get an 'interval from to' from a ptree as 'intervals f t' of respective nodes
11.1463 + where 'from' are pos, i.e. a key as int list, 'f' an int (to,t analoguous)
11.1464 +(1) the 'f' are given
11.1465 +(1a) by 'from' if 'f' = the respective element of 'from' (left margin)
11.1466 +(1b) -inifinity, if 'f' > the respective element of 'from' (internal node)
11.1467 +(2) the 't' ar given
11.1468 +(2a) by 'to' if 't' = the respective element of 'to' (right margin)
11.1469 +(2b) inifinity, if 't' < the respective element of 'to (internal node)'
11.1470 +the 'f' and 't' are set by hdp,... *)
11.1471 +fun get_trace pt p q =
11.1472 + (flat o (getnds ((length p) -1) true ([hdp p], tlp p) (tlq q)))
11.1473 + (take_fromto (hdp p) (hdq q) (children pt));
11.1474 +end;
11.1475 +(*WN0510 stoppde this development;
11.1476 + actually used (inefficient) version with move_dn: getFormulaeFromTo*)
11.1477 +
11.1478 +
11.1479 +
11.1480 +
11.1481 +fun get_somespec ((dI,pI,mI):spec) ((dI',pI',mI'):spec) =
11.1482 + let val domID = if dI = e_domID
11.1483 + then if dI' = e_domID
11.1484 + then raise error"pt_extract: no domID in probl,origin"
11.1485 + else dI'
11.1486 + else dI
11.1487 + val pblID = if pI = e_pblID
11.1488 + then if pI' = e_pblID
11.1489 + then raise error"pt_extract: no pblID in probl,origin"
11.1490 + else pI'
11.1491 + else pI
11.1492 + val metID = if mI = e_metID
11.1493 + then if pI' = e_metID
11.1494 + then raise error"pt_extract: no metID in probl,origin"
11.1495 + else mI'
11.1496 + else mI
11.1497 + in (domID, pblID, metID):spec end;
11.1498 +fun get_somespec' ((dI,pI,mI):spec) ((dI',pI',mI'):spec) =
11.1499 + let val domID = if dI = e_domID then dI' else dI
11.1500 + val pblID = if pI = e_pblID then pI' else pI
11.1501 + val metID = if mI = e_metID then mI' else mI
11.1502 + in (domID, pblID, metID):spec end;
11.1503 +
11.1504 +(*extract a formula or model from ptree for itms2itemppc or model2xml*)
11.1505 +fun preconds2str bts =
11.1506 + (strs2str o (map (linefeed o pair2str o
11.1507 + (apsnd term2str) o
11.1508 + (apfst bool2str)))) bts;
11.1509 +fun ocalhd2str ((b, p, hdf, itms, prec, spec):ocalhd) =
11.1510 + "("^bool2str b^", "^pos_2str p^", "^term2str hdf^
11.1511 + ", "^itms2str_ (thy2ctxt' "Isac") itms^
11.1512 + ", "^preconds2str prec^", \n"^spec2str spec^" )";
11.1513 +
11.1514 +
11.1515 +
11.1516 +fun is_pblnd (Nd (ppobj, _)) = is_pblobj ppobj;
11.1517 +
11.1518 +
11.1519 +(**.functions for the 'ptree iterator' as seen from the FE-Kernel interface.**)
11.1520 +
11.1521 +(*move one step down into existing nodes of ptree; regard TransitiveB
11.1522 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~##################
11.1523 +fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*)
11.1524 +(* val (Nd (c, ns), ([],p_)) = (pt, get_pos cI uI);
11.1525 + *)
11.1526 + if is_pblobj c
11.1527 + then case p_ of (*Frm => ([], Pbl) 1.12.03
11.1528 + |*) Res => raise PTREE "move_dn: end of calculation"
11.1529 + | _ => if null ns (*go down from Pbl + Met*)
11.1530 + then raise PTREE "move_dn: solve problem not started"
11.1531 + else ([1], Frm)
11.1532 + else (case p_ of Res => raise PTREE "move_dn: end of (sub-)tree"
11.1533 + | _ => if null ns
11.1534 + then raise PTREE "move_dn: pos not existent 1"
11.1535 + else ([1], Frm))
11.1536 +
11.1537 + (*iterate towards end of pos*)
11.1538 +(* val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ([]:pos, pt, get_pos cI uI);
11.1539 + val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ((P@[p]),(nth p ns),(ps, p_));
11.1540 + *)
11.1541 + | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
11.1542 + if p > length ns then raise PTREE "move_dn: pos not existent 2"
11.1543 + else move_dn ((P@[p]): pos) (nth p ns) (ps, p_)
11.1544 +(* val (P, (Nd (c, ns)), ([p], p_)) = ((P@[p]), (nth p ns), (ps, p_));
11.1545 + val (P, (Nd (c, ns)), ([p], p_)) = ([],pt,get_pos cI uI);
11.1546 + *)
11.1547 + | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
11.1548 + if p > length ns then raise PTREE "move_dn: pos not existent 3"
11.1549 + else if is_pblnd (nth p ns) then
11.1550 + ((*writeln("### move_dn: is_pblnd (nth p ns), P= "^ints2str' P^", \n"^
11.1551 + "length ns= "^((string_of_int o length) ns)^
11.1552 + ", p= "^string_of_int p^", p_= "^pos_2str p_);*)
11.1553 + case p_ of Res => if p = length ns
11.1554 + then if g_ostate c = Complete then (P, Res)
11.1555 + else raise PTREE (ints2str' P^" not complete")
11.1556 + (*FIXME here handle not-sequent-branches*)
11.1557 + else if g_branch c = TransitiveB
11.1558 + andalso (not o is_pblnd o (nth (p+1))) ns
11.1559 + then (P@[p+1], Res)
11.1560 + else (P@[p+1], if is_pblnd (nth (p+1) ns)
11.1561 + then Pbl else Frm)
11.1562 + | _ => if (null o children o (nth p)) ns (*go down from Pbl*)
11.1563 + then raise PTREE "move_dn: solve subproblem not started"
11.1564 + else (P @ [p, 1],
11.1565 + if (is_pblnd o hd o children o (nth p)) ns
11.1566 + then Pbl else Frm)
11.1567 + )
11.1568 + (* val (P, Nd (c, ns), ([p], p_)) = ([], pt, ([1], Frm));
11.1569 + *)
11.1570 + else case p_ of Frm => if (null o children o (nth p)) ns
11.1571 + (*then if g_ostate c = Complete then (P@[p],Res)*)
11.1572 + then if g_ostate' (nth p ns) = Complete
11.1573 + then (P@[p],Res)
11.1574 + else raise PTREE "move_dn: pos not existent 4"
11.1575 + else (P @ [p, 1], (*go down*)
11.1576 + if (is_pblnd o hd o children o (nth p)) ns
11.1577 + then Pbl else Frm)
11.1578 + | Res => if p = length ns
11.1579 + then
11.1580 + if g_ostate c = Complete then (P, Res)
11.1581 + else raise PTREE (ints2str' P^" not complete")
11.1582 + else
11.1583 + if g_branch c = TransitiveB
11.1584 + andalso (not o is_pblnd o (nth (p+1))) ns
11.1585 + then if (null o children o (nth (p+1))) ns
11.1586 + then (P@[p+1], Res)
11.1587 + else (P@[p+1,1], Frm)(*040221*)
11.1588 + else (P@[p+1], if is_pblnd (nth (p+1) ns)
11.1589 + then Pbl else Frm);
11.1590 +*)
11.1591 +(*.move one step down into existing nodes of ptree; skip Res = Frm.nxt;
11.1592 + move_dn at the end of the calc-tree raises PTREE.*)
11.1593 +fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*)
11.1594 + (case p_ of
11.1595 + Res => raise PTREE "move_dn: end of calculation"
11.1596 + | _ => if null ns (*go down from Pbl + Met*)
11.1597 + then raise PTREE "move_dn: solve problem not started"
11.1598 + else ([1], Frm))
11.1599 + | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =(*iterate to end of pos*)
11.1600 + if p > length ns then raise PTREE "move_dn: pos not existent 2"
11.1601 + else move_dn ((P@[p]): pos) (nth p ns) (ps, p_)
11.1602 +
11.1603 + | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
11.1604 + if p > length ns then raise PTREE "move_dn: pos not existent 3"
11.1605 + else case p_ of
11.1606 + Res =>
11.1607 + if p = length ns (*last Res on this level: go a level up*)
11.1608 + then if g_ostate c = Complete then (P, Res)
11.1609 + else raise PTREE (ints2str' P^" not complete 1")
11.1610 + else (*go to the next Nd on this level, or down into the next Nd*)
11.1611 + if is_pblnd (nth (p+1) ns) then (P@[p+1], Pbl)
11.1612 + else
11.1613 + if g_res' (nth p ns) = g_form' (nth (p+1) ns)
11.1614 + then if (null o children o (nth (p+1))) ns
11.1615 + then (*take the Res if Complete*)
11.1616 + if g_ostate' (nth (p+1) ns) = Complete
11.1617 + then (P@[p+1], Res)
11.1618 + else raise PTREE (ints2str' (P@[p+1])^
11.1619 + " not complete 2")
11.1620 + else (P@[p+1,1], Frm)(*go down into the next PrfObj*)
11.1621 + else (P@[p+1], Frm)(*take Frm: exists if the Nd exists*)
11.1622 + | Frm => (*go down or to the Res of this Nd*)
11.1623 + if (null o children o (nth p)) ns
11.1624 + then if g_ostate' (nth p ns) = Complete then (P @ [p], Res)
11.1625 + else raise PTREE (ints2str' (P @ [p])^" not complete 3")
11.1626 + else (P @ [p, 1], Frm)
11.1627 + | _ => (*is Pbl or Met*)
11.1628 + if (null o children o (nth p)) ns
11.1629 + then raise PTREE "move_dn:solve subproblem not startd"
11.1630 + else (P @ [p, 1],
11.1631 + if (is_pblnd o hd o children o (nth p)) ns
11.1632 + then Pbl else Frm);
11.1633 +
11.1634 +
11.1635 +(*.go one level down into ptree.*)
11.1636 +fun movelevel_dn [] (Nd (c, ns)) ([],p_) = (*root problem*)
11.1637 + if is_pblobj c
11.1638 + then if null ns
11.1639 + then raise PTREE "solve problem not started"
11.1640 + else ([1], if (is_pblnd o hd) ns then Pbl else Frm)
11.1641 + else raise PTREE "pos not existent 1"
11.1642 +
11.1643 + (*iterate towards end of pos*)
11.1644 + | movelevel_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
11.1645 + if p > length ns then raise PTREE "pos not existent 2"
11.1646 + else movelevel_dn (P@[p]) (nth p ns) (ps, p_)
11.1647 +
11.1648 + | movelevel_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
11.1649 + if p > length ns then raise PTREE "pos not existent 3" else
11.1650 + case p_ of Res =>
11.1651 + if p = length ns
11.1652 + then raise PTREE "no children"
11.1653 + else
11.1654 + if g_branch c = TransitiveB
11.1655 + then if (null o children o (nth (p+1))) ns
11.1656 + then raise PTREE "no children"
11.1657 + else (P @ [p+1, 1],
11.1658 + if (is_pblnd o hd o children o (nth (p+1))) ns
11.1659 + then Pbl else Frm)
11.1660 + else if (null o children o (nth p)) ns
11.1661 + then raise PTREE "no children"
11.1662 + else (P @ [p, 1], if (is_pblnd o hd o children o (nth p)) ns
11.1663 + then Pbl else Frm)
11.1664 + | _ => if (null o children o (nth p)) ns
11.1665 + then raise PTREE "no children"
11.1666 + else (P @ [p, 1], (*go down*)
11.1667 + if (is_pblnd o hd o children o (nth p)) ns
11.1668 + then Pbl else Frm);
11.1669 +
11.1670 +
11.1671 +
11.1672 +(*.go to the previous position in ptree; regard TransitiveB.*)
11.1673 +fun move_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*)
11.1674 + if is_pblobj c
11.1675 + then case p_ of Res => if null ns then ([], Pbl) (*Res -> Pbl (not Met)!*)
11.1676 + else ([length ns], Res)
11.1677 + | _ => raise PTREE "begin of calculation"
11.1678 + else raise PTREE "pos not existent"
11.1679 +
11.1680 + | move_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = (*iterate to end of pos*)
11.1681 + if p > length ns then raise PTREE "pos not existent"
11.1682 + else move_up (P@[p]) (nth p ns) (ps,p_)
11.1683 +
11.1684 + | move_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
11.1685 + if p > length ns then raise PTREE "pos not existent"
11.1686 + else if is_pblnd (nth p ns) then
11.1687 + case p_ of Res =>
11.1688 + let val nc = (length o children o (nth p)) ns
11.1689 + in if nc = 0 then (P@[p], Pbl) (*Res -> Pbl (not Met)!*)
11.1690 + else (P @ [p, nc], Res) end (*go down*)
11.1691 + | _ => if p = 1 then (P, Pbl) else (P@[p-1], Res)
11.1692 + else case p_ of Frm => if p <> 1 then (P, Frm)
11.1693 + else if is_pblobj c then (P, Pbl) else (P, Frm)
11.1694 + | Res =>
11.1695 + let val nc = (length o children o (nth p)) ns
11.1696 + in if nc = 0 (*cannot go down*)
11.1697 + then if g_branch c = TransitiveB andalso p <> 1
11.1698 + then (P@[p-1], Res) else (P@[p], Frm)
11.1699 + else (P @ [p, nc], Res) end; (*go down*)
11.1700 +
11.1701 +
11.1702 +
11.1703 +(*.go one level up in ptree; sets the position on Frm.*)
11.1704 +fun movelevel_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*)
11.1705 + raise PTREE "pos not existent"
11.1706 +
11.1707 + (*iterate towards end of pos*)
11.1708 + | movelevel_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
11.1709 + if p > length ns then raise PTREE "pos not existent"
11.1710 + else movelevel_up (P@[p]) (nth p ns) (ps,p_)
11.1711 +
11.1712 + | movelevel_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
11.1713 + if p > length ns then raise PTREE "pos not existent"
11.1714 + else if is_pblobj c then (P, Pbl) else (P, Frm);
11.1715 +
11.1716 +
11.1717 +(*.go to the next calc-head up in the calc-tree.*)
11.1718 +fun movecalchd_up pt ((p, Res):pos') =
11.1719 + (par_pblobj pt p, Pbl):pos'
11.1720 + | movecalchd_up pt (p, _) =
11.1721 + if is_pblobj (get_obj I pt p)
11.1722 + then (p, Pbl) else (par_pblobj pt p, Pbl);
11.1723 +
11.1724 +(*.determine the previous pos' on the same level.*)
11.1725 +(*WN0502 made for interSteps; _only_ works for branch TransitiveB*)
11.1726 +fun lev_pred' pt (pos:pos' as ([],Res)) = ([],Pbl):pos'
11.1727 + | lev_pred' pt (pos:pos' as (p, Res)) =
11.1728 + let val (p', last) = split_last p
11.1729 + in if last = 1
11.1730 + then if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
11.1731 + else if get_obj g_res pt (p' @ [last - 1]) = get_obj g_form pt p
11.1732 + then (p' @ [last - 1], Res) (*TransitiveB*)
11.1733 + else if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
11.1734 + end;
11.1735 +
11.1736 +(*.determine the next pos' on the same level.*)
11.1737 +fun lev_on' pt (([],Pbl):pos') = ([],Res):pos'
11.1738 + | lev_on' pt (p, Res) =
11.1739 + if get_obj g_res pt p = get_obj g_form pt (lev_on p)(*TransitiveB*)
11.1740 + then if existpt' (lev_on p, Res) pt then (lev_on p, Res)
11.1741 + else raise error ("lev_on': (p, Res) -> (p, Res) not existent, \
11.1742 + \p = "^ints2str' (lev_on p))
11.1743 + else (lev_on p, Frm)
11.1744 + | lev_on' pt (p, _) =
11.1745 + if existpt' (p, Res) pt then (p, Res)
11.1746 + else raise error ("lev_on': (p, Frm) -> (p, Res) not existent, \
11.1747 + \p = "^ints2str' p);
11.1748 +
11.1749 +fun exist_lev_on' pt p = (lev_on' pt p; true) handle _ => false;
11.1750 +
11.1751 +(*.is the pos' at the last element of a calulation _AND_ can be continued.*)
11.1752 +(* val (pt, pos as (p,p_)) = (pt, ([1],Frm));
11.1753 + *)
11.1754 +fun is_curr_endof_calc pt (([],Res) : pos') = false
11.1755 + | is_curr_endof_calc pt (pos as (p,_)) =
11.1756 + not (exist_lev_on' pt pos)
11.1757 + andalso get_obj g_ostate pt (lev_up p) = Incomplete;
11.1758 +
11.1759 +
11.1760 +(**.insert into ctree and cut branches accordingly.**)
11.1761 +
11.1762 +(*.get all positions of certain intervals on the ctree.*)
11.1763 +(*OLD VERSION without move_dn; kept for occasional redesign
11.1764 + get all pos's to be cut in a ptree
11.1765 + below a pos or from a ptree list after i-th element (NO level_up).*)
11.1766 +fun get_allpos' (_:pos, _:posel) EmptyPtree = ([]:pos' list)
11.1767 + | get_allpos' (p, 1) (Nd (b, bs)) = (*p is pos of Nd*)
11.1768 + if g_ostate b = Incomplete
11.1769 + then ((*writeln("get_allpos' (p, 1) Incomplete: p="^ints2str' p);*)
11.1770 + [(p,Frm)] @ (get_allpos's (p, 1) bs)
11.1771 + )
11.1772 + else ((*writeln("get_allpos' (p, 1) else: p="^ints2str' p);*)
11.1773 + [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)]
11.1774 + )
11.1775 + (*WN041020 here we assume what is presented on the worksheet ?!*)
11.1776 + | get_allpos' (p, i) (Nd (b, bs)) = (*p is pos of Nd*)
11.1777 + if length bs > 0 orelse is_pblobj b
11.1778 + then if g_ostate b = Incomplete
11.1779 + then [(p,Frm)] @ (get_allpos's (p, 1) bs)
11.1780 + else [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)]
11.1781 + else
11.1782 + if g_ostate b = Incomplete
11.1783 + then []
11.1784 + else [(p,Res)]
11.1785 +(*WN041020 here we assume what is presented on the worksheet ?!*)
11.1786 +and get_allpos's _ [] = []
11.1787 + | get_allpos's (p, i) (pt::pts) = (*p is pos of parent-Nd*)
11.1788 + (get_allpos' (p@[i], i) pt) @ (get_allpos's (p, i+1) pts);
11.1789 +
11.1790 +(*.get all positions of certain intervals on the ctree.*)
11.1791 +(*NEW version WN050225*)
11.1792 +
11.1793 +
11.1794 +(*.cut branches.*)
11.1795 +(*before WN041019......
11.1796 +val cut_branch = (test_trans, curry take):
11.1797 + (ppobj -> bool) * (int -> ptree list -> ptree list);
11.1798 +.. formlery used for ...
11.1799 +fun cut_tree''' _ [] = EmptyPtree
11.1800 + | cut_tree''' pt pos =
11.1801 + let val (pt',cut) = appl_branch cut_branch pt pos
11.1802 + in if cut andalso length pos > 1 then cut_tree''' pt' (lev_up pos)
11.1803 + else pt' end;
11.1804 +*)
11.1805 +(*OLD version before WN050225*)
11.1806 +(*WN050106 like cut_level, but deletes exactly 1 node --- for tests ONLY*)
11.1807 +fun cut_level_'_ (_:pos' list) (_:pos) EmptyPtree (_:pos') =
11.1808 + raise PTREE "cut_level_'_ Empty _"
11.1809 + | cut_level_'_ _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level_'_ _ []"
11.1810 + | cut_level_'_ cuts P (Nd (b, bs)) (p::[],p_) =
11.1811 + if test_trans b
11.1812 + then (Nd (b, drop_nth [] (p:posel, bs)),
11.1813 + (* ~~~~~~~~~~~*)
11.1814 + cuts @
11.1815 + (if p_ = Frm then [(P@[p],Res)] else ([]:pos' list)) @
11.1816 + (*WN041020 here we assume what is presented on the worksheet ?!*)
11.1817 + (get_allpos's (P, p+1) (drop_nth [] (p, bs))))
11.1818 + (* ~~~~~~~~~~~*)
11.1819 + else (Nd (b, bs), cuts)
11.1820 + | cut_level_'_ cuts P (Nd (b, bs)) ((p::ps),p_) =
11.1821 + let val (bs',cuts') = cut_level_'_ cuts P (nth p bs) (ps, p_)
11.1822 + in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
11.1823 +
11.1824 +(*before WN050219*)
11.1825 +fun cut_level (_:pos' list) (_:pos) EmptyPtree (_:pos') =
11.1826 + raise PTREE "cut_level EmptyPtree _"
11.1827 + | cut_level _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level _ []"
11.1828 +
11.1829 + | cut_level cuts P (Nd (b, bs)) (p::[],p_) =
11.1830 + if test_trans b
11.1831 + then (Nd (b, take (p:posel, bs)),
11.1832 + cuts @
11.1833 + (if p_ = Frm andalso (*#*) g_ostate b = Complete
11.1834 + then [(P@[p],Res)] else ([]:pos' list)) @
11.1835 + (*WN041020 here we assume what is presented on the worksheet ?!*)
11.1836 + (get_allpos's (P, p+1) (takerest (p, bs))))
11.1837 + else (Nd (b, bs), cuts)
11.1838 +
11.1839 + | cut_level cuts P (Nd (b, bs)) ((p::ps),p_) =
11.1840 + let val (bs',cuts') = cut_level cuts P (nth p bs) (ps, p_)
11.1841 + in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
11.1842 +
11.1843 +(*OLD version before WN050219, overwritten below*)
11.1844 +fun cut_tree _ (([],_):pos') = raise PTREE "cut_tree _ ([],_)"
11.1845 + | cut_tree pt (pos as ([p],_)) =
11.1846 + let val (pt', cuts) = cut_level ([]:pos' list) [] pt pos
11.1847 + in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete
11.1848 + then [] else [([],Res)])) end
11.1849 + | cut_tree pt (p,p_) =
11.1850 + let
11.1851 + fun cutfn pt cuts (p,p_) =
11.1852 + let val (pt', cuts') = cut_level [] (lev_up p) pt (p,p_)
11.1853 + val cuts'' = if get_obj g_ostate pt (lev_up p) = Incomplete
11.1854 + then [] else [(lev_up p, Res)]
11.1855 + in if length cuts' > 0 andalso length p > 1
11.1856 + then cutfn pt' (cuts @ cuts') (lev_up p, Frm(*-->(p,Res)*))
11.1857 + else (pt',cuts @ cuts') end
11.1858 + val (pt', cuts) = cutfn pt [] (p,p_)
11.1859 + in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete
11.1860 + then [] else [([], Res)])) end;
11.1861 +
11.1862 +
11.1863 +(*########/ inserted from ctreeNEW.sml \#################################**)
11.1864 +
11.1865 +(*.get all positions in a ptree until ([],Res) or ostate=Incomplete
11.1866 +val get_allp = fn :
11.1867 + pos' list -> : accumulated, start with []
11.1868 + pos -> : the offset for subtrees wrt the root
11.1869 + ptree -> : (sub)tree
11.1870 + pos' : initialization (the last pos' before ...)
11.1871 + -> pos' list : of positions in this (sub) tree (relative to the root)
11.1872 +.*)
11.1873 +(* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([], Frm):pos');
11.1874 + val (cuts, P, pt, pos) = ([], [2], get_nd pt [2], ([], Frm):pos');
11.1875 + length (children pt);
11.1876 + *)
11.1877 +fun get_allp (cuts:pos' list) (P:pos, pos:pos') pt =
11.1878 + (let val nxt = move_dn [] pt pos (*exn if Incomplete reached*)
11.1879 + in if nxt <> ([],Res)
11.1880 + then get_allp (cuts @ [nxt]) (P, nxt) pt
11.1881 + else (map (apfst (curry op@ P)) (cuts @ [nxt])): pos' list
11.1882 + end) handle PTREE _ => (map (apfst (curry op@ P)) cuts);
11.1883 +
11.1884 +
11.1885 +(*the pts are assumed to be on the same level*)
11.1886 +fun get_allps (cuts: pos' list) (P:pos) [] = cuts
11.1887 + | get_allps cuts P (pt::pts) =
11.1888 + let val below = get_allp [] (P, ([], Frm)) pt
11.1889 + val levfrm =
11.1890 + if is_pblnd pt
11.1891 + then (P, Pbl)::below
11.1892 + else if last_elem P = 1
11.1893 + then (P, Frm)::below
11.1894 + else (*Trans*) below
11.1895 + val levres = levfrm @ (if null below then [(P, Res)] else [])
11.1896 + in get_allps (cuts @ levres) (lev_on P) pts end;
11.1897 +
11.1898 +
11.1899 +(**.these 2 funs decide on how far cut_tree goes.**)
11.1900 +(*.shall the nodes _after_ the pos to be inserted at be deleted?.*)
11.1901 +fun test_trans (PrfObj{branch = Transitive,...}) = true
11.1902 + | test_trans (PrfObj{branch = NoBranch,...}) = true
11.1903 + | test_trans (PblObj{branch = Transitive,...}) = true
11.1904 + | test_trans (PblObj{branch = NoBranch,...}) = true
11.1905 + | test_trans _ = false;
11.1906 +(*.shall cutting be continued on the higher level(s)?
11.1907 + the Nd regarded will NOT be changed.*)
11.1908 +fun cutlevup (PblObj _) = false (*for tests of LK0502*)
11.1909 + | cutlevup _ = true;
11.1910 +val cutlevup = test_trans;(*WN060727 after summerterm tests.LK0502 withdrawn*)
11.1911 +
11.1912 +(*cut_bottom new sml603..608
11.1913 +cut the level at the bottom of the pos (used by cappend_...)
11.1914 +and handle the parent in order to avoid extra case for root
11.1915 +fn: ptree -> : the _whole_ ptree for cut_levup
11.1916 + pos * posel -> : the pos after split_last
11.1917 + ptree -> : the parent of the Nd to be cut
11.1918 +return
11.1919 + (ptree * : the updated ptree
11.1920 + pos' list) * : the pos's cut
11.1921 + bool : cutting shall be continued on the higher level(s)
11.1922 +*)
11.1923 +fun cut_bottom _ (pt' as Nd (b, [])) = ((pt', []), cutlevup b)
11.1924 + | cut_bottom (P:pos, p:posel) (Nd (b, bs)) =
11.1925 + let (*divide level into 3 parts...*)
11.1926 + val keep = take (p - 1, bs)
11.1927 + val pt' as Nd (_,bs') = nth p bs
11.1928 + (*^^^^^_here_ will be 'insert'ed by 'append_..'*)
11.1929 + val (tail, tp) = (takerest (p, bs),
11.1930 + if null (takerest (p, bs)) then 0 else p + 1)
11.1931 + val (children, cuts) =
11.1932 + if test_trans b
11.1933 + then (keep,
11.1934 + (if is_pblnd pt' then [(P @ [p], Pbl)] else [])
11.1935 + @ (get_allp [] (P @ [p], (P, Frm)) pt')
11.1936 + @ (get_allps [] (P @ [p+1]) tail))
11.1937 + else (keep @ [(*'insert'ed by 'append_..'*)] @ tail,
11.1938 + get_allp [] (P @ [p], (P, Frm)) pt')
11.1939 + val (pt'', cuts) =
11.1940 + if cutlevup b
11.1941 + then (Nd (del_res b, children),
11.1942 + cuts @ (if g_ostate b = Incomplete then [] else [(P,Res)]))
11.1943 + else (Nd (b, children), cuts)
11.1944 + (*val _= writeln("####cut_bottom (P, p)="^pos2str (P @ [p])^
11.1945 + ", Nd=.............................................")
11.1946 + val _= show_pt pt''
11.1947 + val _= writeln("####cut_bottom form='"^
11.1948 + term2str (get_obj g_form pt'' []))
11.1949 + val _= writeln("####cut_bottom cuts#="^string_of_int (length cuts)^
11.1950 + ", cuts="^pos's2str cuts)*)
11.1951 + in ((pt'', cuts:pos' list), cutlevup b) end;
11.1952 +
11.1953 +
11.1954 +(*.go all levels from the bottom of 'pos' up to the root,
11.1955 + on each level compose the children of a node and accumulate the cut Nds
11.1956 +args
11.1957 + pos' list -> : for accumulation
11.1958 + bool -> : cutting shall be continued on the higher level(s)
11.1959 + ptree -> : the whole ptree for 'get_nd pt P' on each level
11.1960 + ptree -> : the Nd from the lower level for insertion at path
11.1961 + pos * posel -> : pos=path split for convenience
11.1962 + ptree -> : Nd the children of are under consideration on this call
11.1963 +returns :
11.1964 + ptree * pos' list : the updated parent-Nd and the pos's of the Nds cut
11.1965 +.*)
11.1966 +fun cut_levup (cuts:pos' list) clevup pt pt' (P:pos, p:posel) (Nd (b, bs)) =
11.1967 + let (*divide level into 3 parts...*)
11.1968 + val keep = take (p - 1, bs)
11.1969 + (*val pt' comes as argument from below*)
11.1970 + val (tail, tp) = (takerest (p, bs),
11.1971 + if null (takerest (p, bs)) then 0 else p + 1)
11.1972 + val (children, cuts') =
11.1973 + if clevup
11.1974 + then (keep @ [pt'], get_allps [] (P @ [p+1]) tail)
11.1975 + else (keep @ [pt'] @ tail, [])
11.1976 + val clevup' = if clevup then cutlevup b else false
11.1977 + (*the first Nd with false stops cutting on all levels above*)
11.1978 + val (pt'', cuts') =
11.1979 + if clevup'
11.1980 + then (Nd (del_res b, children),
11.1981 + cuts' @ (if g_ostate b = Incomplete then [] else [(P,Res)]))
11.1982 + else (Nd (b, children), cuts')
11.1983 + (*val _= writeln("#####cut_levup clevup= "^bool2str clevup)
11.1984 + val _= writeln("#####cut_levup cutlevup b= "^bool2str (cutlevup b))
11.1985 + val _= writeln("#####cut_levup (P, p)="^pos2str (P @ [p])^
11.1986 + ", Nd=.............................................")
11.1987 + val _= show_pt pt''
11.1988 + val _= writeln("#####cut_levup form='"^
11.1989 + term2str (get_obj g_form pt'' []))
11.1990 + val _= writeln("#####cut_levup cuts#="^string_of_int (length cuts)^
11.1991 + ", cuts="^pos's2str cuts)*)
11.1992 + in if null P then (pt'', (cuts @ cuts'):pos' list)
11.1993 + else let val (P, p) = split_last P
11.1994 + in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P)
11.1995 + end
11.1996 + end;
11.1997 +
11.1998 +(*.cut nodes after and below an inserted node in the ctree;
11.1999 + the cuts range is limited by the predicate 'fun cutlevup'.*)
11.2000 +fun cut_tree pt (pos,_) =
11.2001 + if not (existpt pos pt)
11.2002 + then (pt,[]) (*appending a formula never cuts anything*)
11.2003 + else let val (P, p) = split_last pos
11.2004 + val ((pt', cuts), clevup) = cut_bottom (P, p) (get_nd pt P)
11.2005 + (* pt' is the updated parent of the Nd to cappend_..*)
11.2006 + in if null P then (pt', cuts)
11.2007 + else let val (P, p) = split_last P
11.2008 + in cut_levup cuts clevup pt pt' (P, p) (get_nd pt P)
11.2009 + end
11.2010 + end;
11.2011 +
11.2012 +fun append_atomic p l f r f' s pt =
11.2013 + let (**val _= writeln("#@append_atomic: pos ="^pos2str p)**)
11.2014 + val (iss, f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
11.2015 + then (*after Take*)
11.2016 + ((fst (get_obj g_loc pt p), SOME l),
11.2017 + get_obj g_form pt p)
11.2018 + else ((NONE, SOME l), f)
11.2019 + in insert (PrfObj {cell = NONE,
11.2020 + form = f,
11.2021 + tac = r,
11.2022 + loc = iss,
11.2023 + branch= NoBranch,
11.2024 + result= f',
11.2025 + ostate= s}) pt p end;
11.2026 +
11.2027 +
11.2028 +(*20.8.02: cappend_* FIXXXXME cut branches below cannot be decided here:
11.2029 + detail - generate - cappend: inserted, not appended !!!
11.2030 +
11.2031 + cut decided in applicable_in !?!
11.2032 +*)
11.2033 +fun cappend_atomic pt p loc f r f' s =
11.2034 +(* val (pt, p, loc, f, r, f', s) =
11.2035 + (pt,p,l,f,Rewrite_Set_Inst (subst2subs subs',id_rls rls'),
11.2036 + (f',asm),Complete);
11.2037 + *)
11.2038 +((*writeln("##@cappend_atomic: pos ="^pos2str p);*)
11.2039 + apfst (append_atomic p loc f r f' s) (cut_tree pt (p,Frm))
11.2040 +);
11.2041 +(*TODO.WN050305 redesign the handling of istates*)
11.2042 +fun cappend_atomic pt p ist_res f r f' s =
11.2043 + if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
11.2044 + then (*after Take: transfer Frm and respective istate*)
11.2045 + let val (ist_form, f) = (get_loc pt (p,Frm),
11.2046 + get_obj g_form pt p)
11.2047 + val (pt, cs) = cut_tree pt (p,Frm)
11.2048 + val pt = append_atomic p e_istate f r f' s pt
11.2049 + val pt = update_loc' pt p (SOME ist_form, SOME ist_res)
11.2050 + in (pt, cs) end
11.2051 + else apfst (append_atomic p ist_res f r f' s) (cut_tree pt (p,Frm));
11.2052 +
11.2053 +
11.2054 +(* called by Take *)
11.2055 +fun append_form p l f pt =
11.2056 +((*writeln("##@append_form: pos ="^pos2str p);*)
11.2057 + insert (PrfObj {cell = NONE,
11.2058 + form = (*if existpt p pt
11.2059 + andalso get_obj g_tac pt p = Empty_Tac
11.2060 + (*distinction from 'old' (+complete!) pobjs*)
11.2061 + then get_obj g_form pt p else*) f,
11.2062 + tac = Empty_Tac,
11.2063 + loc = (SOME l, NONE),
11.2064 + branch= NoBranch,
11.2065 + result= (e_term,[]),
11.2066 + ostate= Incomplete}) pt p
11.2067 +);
11.2068 +(* val (p,loc,f) = ([1], e_istate, str2term "x + 1 = 2");
11.2069 + val (p,loc,f) = (fst p, e_istate, str2term "-1 + x = 0");
11.2070 + *)
11.2071 +fun cappend_form pt p loc f =
11.2072 +((*writeln("##@cappend_form: pos ="^pos2str p);*)
11.2073 + apfst (append_form p loc f) (cut_tree pt (p,Frm))
11.2074 +);
11.2075 +fun cappend_form pt p loc f =
11.2076 +let (*val _= writeln("##@cappend_form: pos ="^pos2str p)
11.2077 + val _= writeln("##@cappend_form before cut_tree: loc ="^istate2str loc)*)
11.2078 + val (pt', cs) = cut_tree pt (p,Frm)
11.2079 + val pt'' = append_form p loc f pt'
11.2080 + (*val _= writeln("##@cappend_form after append: loc ="^
11.2081 + istates2str (get_obj g_loc pt'' p))*)
11.2082 +in (pt'', cs) end;
11.2083 +
11.2084 +
11.2085 +
11.2086 +fun append_result pt p l f s =
11.2087 +((*writeln("##@append_result: pos ="^pos2str p);*)
11.2088 + (appl_obj (repl_result (fst (get_obj g_loc pt p),
11.2089 + SOME l) f s) pt p, [])
11.2090 +);
11.2091 +
11.2092 +
11.2093 +(*WN041022 deprecated, still for kbtest/diffapp.sml, /systest/root-equ.sml*)
11.2094 +fun append_parent p l f r b pt =
11.2095 + let (*val _= writeln("###append_parent: pos ="^pos2str p);*)
11.2096 + val (ll,f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
11.2097 + then ((fst (get_obj g_loc pt p), SOME l),
11.2098 + get_obj g_form pt p)
11.2099 + else ((SOME l, NONE), f)
11.2100 + in insert (PrfObj
11.2101 + {cell = NONE,
11.2102 + form = f,
11.2103 + tac = r,
11.2104 + loc = ll,
11.2105 + branch= b,
11.2106 + result= (e_term,[]),
11.2107 + ostate= Incomplete}) pt p end;
11.2108 +fun cappend_parent pt p loc f r b =
11.2109 +((*writeln("###cappend_parent: pos ="^pos2str p);*)
11.2110 + apfst (append_parent p loc f r b) (cut_tree pt (p,Und))
11.2111 +);
11.2112 +
11.2113 +
11.2114 +fun append_problem [] l fmz (strs,spec,hdf) _ =
11.2115 +((*writeln("###append_problem: pos = []");*)
11.2116 + (Nd (PblObj
11.2117 + {cell = NONE,
11.2118 + origin= (strs,spec,hdf),
11.2119 + fmz = fmz,
11.2120 + spec = empty_spec,
11.2121 + probl = []:itm list,
11.2122 + meth = []:itm list,
11.2123 + env = NONE,
11.2124 + loc = (SOME l, NONE),
11.2125 + branch= TransitiveB,(*FIXXXXXME.27.8.03: for equations only*)
11.2126 + result= (e_term,[]),
11.2127 + ostate= Incomplete},[]))
11.2128 +)
11.2129 + | append_problem p l fmz (strs,spec,hdf) pt =
11.2130 +((*writeln("###append_problem: pos ="^pos2str p);*)
11.2131 + insert (PblObj
11.2132 + {cell = NONE,
11.2133 + origin= (strs,spec,hdf),
11.2134 + fmz = fmz,
11.2135 + spec = empty_spec,
11.2136 + probl = []:itm list,
11.2137 + meth = []:itm list,
11.2138 + env = NONE,
11.2139 + loc = (SOME l, NONE),
11.2140 + branch= TransitiveB,
11.2141 + result= (e_term,[]),
11.2142 + ostate= Incomplete}) pt p
11.2143 +);
11.2144 +fun cappend_problem _ [] loc fmz ori =
11.2145 +((*writeln("###cappend_problem: pos = []");*)
11.2146 + (append_problem [] loc fmz ori EmptyPtree,[])
11.2147 +)
11.2148 + | cappend_problem pt p loc fmz ori =
11.2149 +((*writeln("###cappend_problem: pos ="^pos2str p);*)
11.2150 + apfst (append_problem p (loc:istate) fmz ori) (cut_tree pt (p,Frm))
11.2151 +);
11.2152 +
11.2153 +(*.get the theory explicitly specified for the rootpbl;
11.2154 + thus use this function _after_ finishing specification.*)
11.2155 +fun rootthy (Nd (PblObj {spec=(thyID, _, _),...}, _)) = assoc_thy thyID
11.2156 + | rootthy _ = raise error "rootthy";
11.2157 +
12.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2 +++ b/src/Tools/isac/Interpret/generate.sml Wed Aug 25 16:20:07 2010 +0200
12.3 @@ -0,0 +1,586 @@
12.4 +(* use"ME/generate.sml";
12.5 + use"generate.sml";
12.6 + *)
12.7 +
12.8 +(*.initialize istate for Detail_Set.*)
12.9 +(*
12.10 +fun init_istate (Rewrite_Set rls) =
12.11 +(* val (Rewrite_Set rls) = (get_obj g_tac pt p);
12.12 + *)
12.13 + (case assoc_rls rls of
12.14 + Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t))
12.15 +(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls;
12.16 + *)
12.17 + | Rls {scr=EmptyScr,...} =>
12.18 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.19 + ^"use prep_rls for storing rule-sets !")
12.20 + | Rls {scr=Script s,...} =>
12.21 +(* val Rls {scr=Script s,...} = assoc_rls rls;
12.22 + *)
12.23 + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))
12.24 + | Seq {scr=EmptyScr,...} =>
12.25 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.26 + ^"use prep_rls for storing rule-sets !")
12.27 + | Seq {srls=srls,scr=Script s,...} =>
12.28 + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)))
12.29 + | init_istate (Rewrite_Set_Inst (subs, rls)) =
12.30 +(* val (Rewrite_Set_Inst (subs, rls)) = (get_obj g_tac pt p);
12.31 + *)
12.32 + let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs
12.33 + in case assoc_rls rls of
12.34 + Rls {scr=EmptyScr,...} =>
12.35 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.36 + ^"use prep_rls for storing rule-sets !")
12.37 + | Rls {scr=Script s,...} =>
12.38 + let val (a1, a2) = two_scr_arg s
12.39 + in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end
12.40 + | Seq {scr=EmptyScr,...} =>
12.41 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.42 + ^"use prep_rls for storing rule-sets !")
12.43 +(* val Seq {scr=Script s,...} = assoc_rls rls;
12.44 + *)
12.45 + | Seq {scr=Script s,...} =>
12.46 + let val (a1, a2) = two_scr_arg s
12.47 + in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end
12.48 + end;
12.49 +*)
12.50 +(*~~~~~~~~~~~~~~~~~~~~~~copy for dev. until del.~~~~~~~~~~~~~~~~~~~~~~~~~*)
12.51 +fun init_istate (Rewrite_Set rls) t =
12.52 +(* val (Rewrite_Set rls) = (get_obj g_tac pt p);
12.53 + *)
12.54 + (case assoc_rls rls of
12.55 + Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t))
12.56 +(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls;
12.57 + *)
12.58 + | Rls {scr=EmptyScr,...} =>
12.59 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.60 + ^"use prep_rls for storing rule-sets !")
12.61 + | Rls {scr=Script s,...} =>
12.62 +(* val Rls {scr=Script s,...} = assoc_rls rls;
12.63 + *)
12.64 + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))
12.65 + | Seq {scr=EmptyScr,...} =>
12.66 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.67 + ^"use prep_rls for storing rule-sets !")
12.68 + | Seq {srls=srls,scr=Script s,...} =>
12.69 + (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)))
12.70 +(* val ((Rewrite_Set_Inst (subs, rls)), t) = ((get_obj g_tac pt p), t);
12.71 + *)
12.72 + | init_istate (Rewrite_Set_Inst (subs, rls)) t =
12.73 + let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs
12.74 + (*...we suppose the substitution of only _one_ bound variable*)
12.75 + in case assoc_rls rls of
12.76 + Rls {scr=EmptyScr,...} =>
12.77 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.78 + ^"use prep_rls for storing rule-sets !")
12.79 + | Rls {scr=Script s,...} =>
12.80 + let val (form, bdv) = two_scr_arg s
12.81 + in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true))
12.82 + end
12.83 + | Seq {scr=EmptyScr,...} =>
12.84 + raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
12.85 + ^"use prep_rls for storing rule-sets !")
12.86 +(* val Seq {scr=Script s,...} = assoc_rls rls;
12.87 + *)
12.88 + | Seq {scr=Script s,...} =>
12.89 + let val (form, bdv) = two_scr_arg s
12.90 + in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true))
12.91 + end
12.92 + end;
12.93 +
12.94 +
12.95 +(*.a taci holds alle information required to build a node in the calc-tree;
12.96 + a taci is assumed to be used efficiently such that the calc-tree
12.97 + resulting from applying a taci need not be stored separately;
12.98 + see "type calcstate".*)
12.99 +(*TODO.WN0504 redesign ??? or redesign generate ?? see "fun generate"
12.100 + TODO.WN0512 ? redesign this _list_:
12.101 + # only used for [Apply_Method + (Take or Subproblem)], i.e. for initacs
12.102 + # the latter problem may be resolved automatically if "fun autocalc" is
12.103 + not any more used for the specify-phase and for changing the phases*)
12.104 +type taci =
12.105 + (tac * (*for comparison with input tac*)
12.106 + tac_ * (*for ptree generation*)
12.107 + (pos' * (*after applying tac_, for ptree generation*)
12.108 + istate)); (*after applying tac_, for ptree generation*)
12.109 +val e_taci = (Empty_Tac, Empty_Tac_, (e_pos', e_istate)): taci;
12.110 +(* val (tac, tac_, (pos', istate))::_ = tacis';
12.111 + *)
12.112 +fun taci2str ((tac, tac_, (pos', istate)):taci) =
12.113 + "( "^tac2str tac^", "^tac_2str tac_^", ( "^pos'2str pos'
12.114 + ^", "^istate2str istate^" ))";
12.115 +fun tacis2str tacis = (strs2str o (map (linefeed o taci2str))) tacis;
12.116 +
12.117 +datatype pblmet = (*%^%*)
12.118 + Upblmet (*undefined*)
12.119 + | Problem of pblID (*%^%*)
12.120 + | Method of metID; (*%^%*)
12.121 +fun pblmet2str (Problem pblID) = "Problem "^(strs2str pblID)(*%^%*)
12.122 + | pblmet2str (Method metID) = "Method "^(metID2str metID);(*%^%*)
12.123 + (*%^%*) (*26.6. moved to sequent.sml: fun ~~~~~~~~~; was here below*)
12.124 +
12.125 +
12.126 +(* copy from 03.60.usecases.sml 15.11.99 *)
12.127 +datatype user_cmd =
12.128 + Accept | NotAccept | Example
12.129 +| YourTurn | MyTurn (* internal use only 7.6.02 java-sml*)
12.130 +| Rules
12.131 +| DontKnow (*| HowComes | WhatFor 7.6.02 java-sml*)
12.132 +| Undo (*| Back | Forward 7.6.02 java-sml*)
12.133 +| EndProof | EndSession
12.134 +| ActivePlus | ActiveMinus | SpeedPlus | SpeedMinus
12.135 + (*Stepwidth...7.6.02 java-sml*)
12.136 +| Auto | NotAuto | Details;
12.137 +(* for test-print-outs *)
12.138 +fun user_cmd2str Accept ="Accept"
12.139 + | user_cmd2str NotAccept ="NotAccept"
12.140 + | user_cmd2str Example ="Example"
12.141 + | user_cmd2str MyTurn ="MyTurn"
12.142 + | user_cmd2str YourTurn ="YourTurn"
12.143 + | user_cmd2str Rules ="Rules"
12.144 +(*| user_cmd2str HowComes ="HowComes"*)
12.145 + | user_cmd2str DontKnow ="DontKnow"
12.146 +(*| user_cmd2str WhatFor ="WhatFor"
12.147 + | user_cmd2str Back ="Back"*)
12.148 + | user_cmd2str Undo ="Undo"
12.149 +(*| user_cmd2str Forward ="Forward"*)
12.150 + | user_cmd2str EndProof ="EndProof"
12.151 + | user_cmd2str EndSession ="EndSession"
12.152 + | user_cmd2str ActivePlus = "ActivePlus"
12.153 + | user_cmd2str ActiveMinus = "ActiveMinus"
12.154 + | user_cmd2str SpeedPlus = "SpeedPlus"
12.155 + | user_cmd2str SpeedMinus = "SpeedMinus"
12.156 + | user_cmd2str Auto = "Auto"
12.157 + | user_cmd2str NotAuto = "NotAuto"
12.158 + | user_cmd2str Details = "Details";
12.159 +
12.160 +
12.161 +
12.162 +(*3.5.00: TODO: foppFK eliminated in interface FE-KE !!!*)
12.163 +datatype foppFK = (* in DG cases div 2 *)
12.164 + EmptyFoppFK (*DG internal*)
12.165 +| FormFK of cterm'
12.166 +| PpcFK of cterm' ppc;
12.167 +fun foppFK2str (FormFK ct') ="FormFK "^ct'
12.168 + | foppFK2str (PpcFK ppc) ="PpcFK "^(ppc2str ppc)
12.169 + | foppFK2str EmptyFoppFK ="EmptyFoppFK";
12.170 +
12.171 +
12.172 +datatype nest = Open | Closed | Nundef;
12.173 +fun nest2str Open = "Open"
12.174 + | nest2str Closed = "Closed"
12.175 + | nest2str Nundef = "Nundef";
12.176 +
12.177 +type indent = int;
12.178 +datatype edit = EdUndef | Write | Protect;
12.179 + (* bridge --> kernel *)
12.180 + (* bridge <-> kernel *)
12.181 +(* needed in dialog.sml *) (* bridge <-- kernel *)
12.182 +fun edit2str EdUndef = "EdUndef"
12.183 + | edit2str Write = "Write"
12.184 + | edit2str Protect = "Protect";
12.185 +
12.186 +
12.187 +datatype inout =
12.188 + New_User | End_User (*<->*)
12.189 +| New_Proof | End_Proof (*<->*)
12.190 +| Command of user_cmd (*-->*)
12.191 +| Request of string | Message of string (*<--*)
12.192 +| Error_ of string | System of string (*<--*)
12.193 +| FoPpcFK of foppFK (*-->*)
12.194 +| FormKF of cellID * edit * indent * nest * cterm' (*<--*)
12.195 +| PpcKF of cellID * edit * indent * nest * (pblmet * item ppc) (*<--*)
12.196 +| RuleFK of tac (*-->*)
12.197 +| RuleKF of edit * tac (*<--*)
12.198 +| RefinedKF of (pblID * ((itm list) * ((bool * term) list))) (*<--*)
12.199 +| Select of tac list (*<--*)
12.200 +| RefineKF of match list (*<--*)
12.201 +| Speed of int (*<--*)
12.202 +| Active of int (*<--*)
12.203 +| Domain of domID; (*<--*)
12.204 +
12.205 +fun inout2str End_Proof = "End_Proof"
12.206 + | inout2str (Command user_cmd) = "Command "^(user_cmd2str user_cmd)
12.207 + | inout2str (Request s) = "Request "^s
12.208 + | inout2str (Message s) = "Message "^s
12.209 + | inout2str (Error_ s) = "Error_ "^s
12.210 + | inout2str (System s) = "System "^s
12.211 + | inout2str (FoPpcFK foppFK) = "FoPpcFK "^(foppFK2str foppFK)
12.212 + | inout2str (FormKF (cellID, edit, indent, nest, ct')) =
12.213 + "FormKF ("^(string_of_int cellID)^","
12.214 + ^(edit2str edit)^","^(string_of_int indent)^","
12.215 + ^(nest2str nest)^",("
12.216 + ^ct' ^")"
12.217 + | inout2str (PpcKF (cellID, edit, indent, nest, (pm,itemppc))) =
12.218 + "PpcKF ("^(string_of_int cellID)^","
12.219 + ^(edit2str edit)^","^(string_of_int indent)^","
12.220 + ^(nest2str nest)^",("
12.221 + ^(pblmet2str pm)^","^(itemppc2str itemppc)^"))"
12.222 + | inout2str (RuleKF (edit,tac)) = "RuleKF "^
12.223 + pair2str(edit2str edit,tac2str tac)
12.224 + | inout2str (RuleFK tac) = "RuleFK "^(tac2str tac)
12.225 + | inout2str (Select tacs)=
12.226 + "Select "^((strs2str' o (map tac2str)) tacs)
12.227 + | inout2str (RefineKF ms) = "RefineKF "^(matchs2str ms)
12.228 + | inout2str (Speed i) = "Speed "^(string_of_int i)
12.229 + | inout2str (Active i) = "Active "^(string_of_int i)
12.230 + | inout2str (Domain dI) = "Domain "^dI;
12.231 +fun inouts2str ios = (strs2str' o (map inout2str)) ios;
12.232 +
12.233 +datatype mout =
12.234 + Form' of inout (* packing cterm' | cterm' ppc *)
12.235 +| Problems of inout (* passes specify (and solve) *)
12.236 +| Error' of inout
12.237 +| EmptyMout;
12.238 +
12.239 +fun mout2str (Form' inout) ="Form' "^(inout2str inout)
12.240 + | mout2str (Error' inout) ="Error' "^(inout2str inout)
12.241 + | mout2str (EmptyMout ) ="EmptyMout";
12.242 +
12.243 +(*fun Form'2str (Form' )*)
12.244 +
12.245 +
12.246 +
12.247 +
12.248 +
12.249 +(* init pbl with ...,dsc,empty | [] *)
12.250 +fun init_pbl pbt =
12.251 + let
12.252 + fun pbt2itm (f,(d,t)) =
12.253 + ((0,[],false,f,Inc((d,[]),(e_term,[]))):itm);
12.254 + in map pbt2itm pbt end;
12.255 +(*take formal parameters from pbt, for transfer from pbl/met-hierarchy*)
12.256 +fun init_pbl' pbt =
12.257 + let
12.258 + fun pbt2itm (f,(d,t)) =
12.259 + ((0,[],false,f,Inc((d,[t]),(e_term,[]))):itm);
12.260 + in map pbt2itm pbt end;
12.261 +
12.262 +
12.263 +(*generate 1 ppobj in ptree*)
12.264 +(*TODO.WN0501: take calcstate as an argument (see embed_derive etc.)?specify?*)
12.265 +fun generate1 thy (Add_Given' (_, itmlist)) Uistate (pos as (p,p_)) pt =
12.266 + (pos:pos',[],Form' (PpcKF (0,EdUndef,0,Nundef,
12.267 + (Upblmet,itms2itemppc thy [][]))),
12.268 + case p_ of Pbl => update_pbl pt p itmlist
12.269 + | Met => update_met pt p itmlist)
12.270 + | generate1 thy (Add_Find' (_, itmlist)) Uistate (pos as (p,p_)) pt =
12.271 + (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
12.272 + case p_ of Pbl => update_pbl pt p itmlist
12.273 + | Met => update_met pt p itmlist)
12.274 + | generate1 thy (Add_Relation' (_, itmlist)) Uistate (pos as (p,p_)) pt =
12.275 + (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
12.276 + case p_ of Pbl => update_pbl pt p itmlist
12.277 + | Met => update_met pt p itmlist)
12.278 +
12.279 + | generate1 thy (Specify_Theory' domID) Uistate (pos as (p,_)) pt =
12.280 + (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
12.281 + update_domID pt p domID)
12.282 +
12.283 + | generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate
12.284 + (pos as (p,_)) pt =
12.285 + let val pt = update_pbl pt p itms
12.286 + val pt = update_pblID pt p pI
12.287 + in ((p,Pbl),[],
12.288 + Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
12.289 + pt) end
12.290 +
12.291 + | generate1 thy (Specify_Method' (mID, oris, itms)) Uistate
12.292 + (pos as (p,_)) pt =
12.293 + let val pt = update_oris pt p oris
12.294 + val pt = update_met pt p itms
12.295 + val pt = update_metID pt p mID
12.296 + in ((p,Met),[],
12.297 + Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
12.298 + pt) end
12.299 +
12.300 + | generate1 thy (Model_Problem' (_, itms, met)) Uistate (pos as (p,_)) pt =
12.301 +(* val (itms,pos as (p,_)) = (pbl, pos);
12.302 + *)
12.303 + let val pt = update_pbl pt p itms
12.304 + val pt = update_met pt p met
12.305 + in (pos,[],Form'(PpcKF(0,EdUndef,0,Nundef,
12.306 + (Upblmet,itms2itemppc thy [][]))), pt) end
12.307 +
12.308 + | generate1 thy (Refine_Tacitly' (pI,pIre,domID,metID,pbl))
12.309 + Uistate (pos as (p,_)) pt =
12.310 + let val pt = update_pbl pt p pbl
12.311 + val pt = update_orispec pt p (domID,pIre,metID)
12.312 + in (pos,[],
12.313 + Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
12.314 + pt) end
12.315 +
12.316 + | generate1 thy (Refine_Problem' (pI,_)) Uistate (pos as (p,_)) pt =
12.317 + let val (dI,_,mI) = get_obj g_spec pt p
12.318 + val pt = update_spec pt p (dI, pI, mI)
12.319 + in (pos,[],
12.320 + Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),pt)
12.321 + end
12.322 +
12.323 + | generate1 thy (Apply_Method' (_,topt, is)) _ (pos as (p,p_)) pt =
12.324 + ((*writeln("###generate1 Apply_Method': pos = "^pos'2str (p,p_));
12.325 + writeln("###generate1 Apply_Method': topt= "^termopt2str topt);
12.326 + writeln("###generate1 Apply_Method': is = "^istate2str is);*)
12.327 + case topt of
12.328 + SOME t =>
12.329 + let val (pt,c) = cappend_form pt p is t
12.330 + (*val _= writeln("###generate1 Apply_Method: after cappend")*)
12.331 + in (pos,c, EmptyMout,pt)
12.332 + end
12.333 + | NONE =>
12.334 + (pos,[],EmptyMout,update_env pt p (SOME is)))
12.335 +(* val (thy, (Take' t), l, (p,p_), pt) =
12.336 + ((assoc_thy "Isac.thy"), tac_, is, pos, pt);
12.337 + *)
12.338 + | generate1 thy (Take' t) l (p,p_) pt = (* val (Take' t) = m; *)
12.339 + let (*val _=writeln("### generate1: Take' pos="^pos'2str (p,p_));*)
12.340 + val p = let val (ps,p') = split_last p(*no connex to prev.ppobj*)
12.341 + in if p'=0 then ps@[1] else p end;
12.342 + val (pt,c) = cappend_form pt p l t;
12.343 + in ((p,Frm):pos', c,
12.344 + Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)), pt) end
12.345 +
12.346 +(* val (l, (p,p_)) = (RrlsState is, p);
12.347 +
12.348 + val (thy, Begin_Trans' t, l, (p,Frm), pt) =
12.349 + (assoc_thy "Isac.thy", tac_, is, p, pt);
12.350 + *)
12.351 + | generate1 thy (Begin_Trans' t) l (p,Frm) pt =
12.352 + let (* print_depth 99;
12.353 + map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3;
12.354 + *)
12.355 + val (pt,c) = cappend_form pt p l t
12.356 + (* print_depth 99;
12.357 + map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3;
12.358 + *)
12.359 + val pt = update_branch pt p TransitiveB (*040312*)
12.360 + (*replace the old PrfOjb ~~~~~*)
12.361 + val p = (lev_on o lev_dn(*starts with [...,0]*)) p;
12.362 + val (pt,c') = cappend_form pt p l t(*FIXME.0402 same istate ???*);
12.363 + in ((p,Frm), c @ c', Form' (FormKF (~1,EdUndef,(length p), Nundef,
12.364 + term2str t)), pt) end
12.365 +
12.366 + (* val (thy, Begin_Trans' t, l, (p,Res), pt) =
12.367 + (assoc_thy "Isac.thy", tac_, is, p, pt);
12.368 + *)
12.369 + | generate1 thy (Begin_Trans' t) l (p ,Res) pt =
12.370 + (*append after existing PrfObj _________*)
12.371 + generate1 thy (Begin_Trans' t) l (lev_on p,Frm) pt
12.372 +
12.373 + | generate1 thy (End_Trans' tasm) l (p,p_) pt =
12.374 + let val p' = lev_up p
12.375 + val (pt,c) = append_result pt p' l tasm Complete;
12.376 + in ((p',Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)),
12.377 + pt) end
12.378 +
12.379 + | generate1 thy (Rewrite_Inst' (_,_,_,_,subs',thm',f,(f',asm))) l (p,p_) pt =
12.380 + let (*val _= writeln("###generate1 Rewrite_Inst': pos= "^pos'2str (p,p_));*)
12.381 + val (pt,c) = cappend_atomic pt p l f
12.382 + (Rewrite_Inst (subst2subs subs',thm')) (f',asm) Complete;
12.383 + val pt = update_branch pt p TransitiveB (*040312*)
12.384 + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*)
12.385 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
12.386 + pt) end
12.387 +
12.388 + | generate1 thy (Rewrite' (thy',ord',rls',pa,thm',f,(f',asm))) l (p,p_) pt =
12.389 + let (*val _= writeln("###generate1 Rewrite': pos= "^pos'2str (p,p_))*)
12.390 + val (pt,c) = cappend_atomic pt p l f (Rewrite thm') (f',asm) Complete
12.391 + val pt = update_branch pt p TransitiveB (*040312*)
12.392 + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*)
12.393 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
12.394 + pt)end
12.395 +
12.396 + | generate1 thy (Rewrite_Asm' all) l p pt =
12.397 + generate1 thy (Rewrite' all) l p pt
12.398 +
12.399 + | generate1 thy (Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm))) l (p,p_) pt =
12.400 +(* val (thy, Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm)), l, (p,p_), pt) =
12.401 + (assoc_thy "Isac.thy", tac_, is, pos, pt);
12.402 + *)
12.403 + let (*val _=writeln("###generate1 Rewrite_Set_Inst': pos= "^pos'2str(p,p_))*)
12.404 + val (pt,c) = cappend_atomic pt p l f
12.405 + (Rewrite_Set_Inst (subst2subs subs',id_rls rls')) (f',asm) Complete
12.406 + val pt = update_branch pt p TransitiveB (*040312*)
12.407 + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*)
12.408 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
12.409 + pt) end
12.410 +
12.411 + | generate1 thy (Detail_Set_Inst' (_,_,subs,rls,f,(f',asm))) l (p,p_) pt =
12.412 + let val (pt,c) = cappend_form pt p l f
12.413 + val pt = update_branch pt p TransitiveB (*040312*)
12.414 +
12.415 + val is = init_istate (Rewrite_Set_Inst (subst2subs subs, id_rls rls)) f
12.416 + val tac_ = Apply_Method' (e_metID, SOME t, is)
12.417 + val pos' = ((lev_on o lev_dn) p, Frm)
12.418 + in (*implicit Take*) generate1 thy tac_ is pos' pt end
12.419 +
12.420 + | generate1 thy (Rewrite_Set' (_,_,rls',f,(f',asm))) l (p,p_) pt =
12.421 + let (*val _= writeln("###generate1 Rewrite_Set': pos= "^pos'2str (p,p_))*)
12.422 + val (pt,c) = cappend_atomic pt p l f
12.423 + (Rewrite_Set (id_rls rls')) (f',asm) Complete
12.424 + val pt = update_branch pt p TransitiveB (*040312*)
12.425 + (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*)
12.426 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
12.427 + pt) end
12.428 +
12.429 + | generate1 thy (Detail_Set' (_,_,rls,f,(f',asm))) l (p,p_) pt =
12.430 + let val (pt,c) = cappend_form pt p l f
12.431 + val pt = update_branch pt p TransitiveB (*040312*)
12.432 +
12.433 + val is = init_istate (Rewrite_Set (id_rls rls)) f
12.434 + val tac_ = Apply_Method' (e_metID, SOME t, is)
12.435 + val pos' = ((lev_on o lev_dn) p, Frm)
12.436 + in (*implicit Take*) generate1 thy tac_ is pos' pt end
12.437 +
12.438 + | generate1 thy (Check_Postcond' (pI,(scval,asm))) l (p,p_) pt =
12.439 + let (*val _=writeln("###generate1 Check_Postcond': pos= "^pos'2str(p,p_))*)
12.440 + (*val (l',_) = get_obj g_loc pt p..don't overwrite with l from subpbl*)
12.441 + val (pt,c) = append_result pt p l (scval,map str2term asm) Complete
12.442 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p),
12.443 + Nundef, term2str scval)), pt) end
12.444 +
12.445 + | generate1 thy (Calculate' (thy',op_,f,(f',thm'))) l (p,p_) pt =
12.446 + let val (pt,c) = cappend_atomic pt p l f (Calculate op_) (f',[]) Complete;
12.447 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
12.448 + pt) end
12.449 +
12.450 + | generate1 thy (Check_elementwise' (consts,pred,(f',asm))) l (p,p_) pt =
12.451 + let(*val _=writeln("###generate1 Check_elementwise': p= "^pos'2str(p,p_))*)
12.452 + val (pt,c) = cappend_atomic pt p l consts
12.453 + (Check_elementwise pred) (f',asm) Complete;
12.454 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
12.455 + pt) end
12.456 +
12.457 + | generate1 thy (Or_to_List' (ors,list)) l (p,p_) pt =
12.458 + let val (pt,c) = cappend_atomic pt p l ors
12.459 + Or_to_List (list,[]) Complete;
12.460 + in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef, term2str list)),
12.461 + pt) end
12.462 +
12.463 + | generate1 thy (Substitute' (subte, t, t')) l (p,p_) pt =
12.464 + let val (pt,c) = cappend_atomic pt p l t (Substitute (subte2sube subte))
12.465 + (t',[]) Complete;
12.466 + in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef,
12.467 + term2str t')), pt)
12.468 + end
12.469 +
12.470 + | generate1 thy (Tac_ (_,f,id,f')) l (p,p_) pt =
12.471 + let val (pt,c) = cappend_atomic pt p l (str2term f)
12.472 + (Tac id) (str2term f',[]) Complete;
12.473 + in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f')), pt)end
12.474 +
12.475 + | generate1 thy (Subproblem' ((domID, pblID, metID), oris, hdl, fmz_, f))
12.476 + l (p,p_) pt =
12.477 + let (*val _=writeln("###generate1 Subproblem': pos= "^pos'2str (p,p_))*)
12.478 + val (pt,c) = cappend_problem pt p l (fmz_, (domID, pblID, metID))
12.479 + (oris, (domID, pblID, metID), hdl);
12.480 + (*val pbl = init_pbl ((#ppc o get_pbt) pblID);
12.481 + val pt = update_pblppc pt p pbl;--------4.9.03->Model_Problem*)
12.482 + (*val _= writeln("### generate1: is([3],Frm)= "^
12.483 + (istate2str (get_istate pt ([3],Frm))));*)
12.484 + val f = Syntax.string_of_term (thy2ctxt thy) f;
12.485 + in ((p,Pbl), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f)), pt) end
12.486 +
12.487 + | generate1 thy m' _ _ _ =
12.488 + raise error ("generate1: not impl.for "^(tac_2str m'))
12.489 +;
12.490 +
12.491 +
12.492 +fun generate_hard thy m' (p,p_) pt =
12.493 + let
12.494 + val p = case p_ of Frm => p | Res => lev_on p
12.495 + | _ => raise error ("generate_hard: call by "^(pos'2str (p,p_)));
12.496 + in generate1 thy m' e_istate (p,p_) pt end;
12.497 +
12.498 +
12.499 +
12.500 +(*tacis are in reverse order from nxt_solve_/specify_: last = fst to insert*)
12.501 +(* val (tacis, (pt, _)) = (tacis, ptp);
12.502 +
12.503 + val (tacis, (pt, c, _)) = (rev tacis, (pt, [], (p, Res)));
12.504 + *)
12.505 +fun generate ([]: taci list) ptp = ptp
12.506 + | generate tacis (pt, c, _:pos'(*!dropped!WN0504redesign generate/tacis?*))=
12.507 + let val (tacis', (_, tac_, (p, is))) = split_last tacis
12.508 + (* for recursion ...
12.509 + (tacis', (_, tac_, (p, is))) = split_last tacis';
12.510 + *)
12.511 + val (p',c',_,pt') = generate1 (assoc_thy "Isac.thy") tac_ is p pt
12.512 + in generate tacis' (pt', c@c', p') end;
12.513 +
12.514 +
12.515 +
12.516 +(*. a '_deriv'ation is constructed during 'reverse rewring' by an Rrls *
12.517 + * of for connecting a user-input formula with the current calc-state. *
12.518 + *# It is somewhat incompatible with the rest of the math-engine: *
12.519 + * (1) it is not created by a script *
12.520 + * (2) thus there cannot be another user-input within a derivation *
12.521 + *# It suffers particularily from the not-well-foundedness of the math-engine*
12.522 + * (1) FIXME other branchtyptes than Transitive will change 'embed_deriv' *
12.523 + * (2) FIXME and eventually 'compare_step' (ie. the script interpreter) *
12.524 + * (3) FIXME and eventually 'lev_back' *
12.525 + *# SOME improvements are evident FIXME.040215 '_deriv'ation: *
12.526 + * (1) FIXME nest Rls_ in 'make_deriv' *
12.527 + * (2) FIXME do the not-reversed part in 'make_deriv' by scripts -- thus *
12.528 + * user-input will become possible in this part of a derivation *
12.529 + * (3) FIXME do (2) only if a derivation has been found -- for efficiency, *
12.530 + * while a non-derivable inform requires to step until End_Proof' *
12.531 + * (4) FIXME find criteria on when _not_ to step until End_Proof' *
12.532 + * (5) FIXME
12.533 +.*)
12.534 +(*.update pos in tacis for embedding by generate.*)
12.535 +(* val
12.536 + *)
12.537 +fun insert_pos _ [] = []
12.538 + | insert_pos (p:pos) (((tac,tac_,(_, ist))::tacis):taci list) =
12.539 + ((tac,tac_,((p, Res), ist)):taci)
12.540 + ::((insert_pos (lev_on p) tacis):taci list);
12.541 +
12.542 +fun res_from_taci (_, Rewrite'(_,_,_,_,_,_,(res, asm)), _) = (res, asm)
12.543 + | res_from_taci (_, Rewrite_Set'(_,_,_,_,(res, asm)), _) = (res, asm)
12.544 + | res_from_taci (_, tac_, _) =
12.545 + raise error ("res_from_taci: called with" ^ tac_2str tac_);
12.546 +
12.547 +(*.embed the tacis created by a '_deriv'ation; sys.form <> input.form
12.548 + tacis are in order, thus are reverted for generate.*)
12.549 +(* val (tacis, (pt, pos as (p, Frm))) = (tacis', ptp);
12.550 + *)
12.551 +fun embed_deriv (tacis:taci list) (pt, pos as (p, Frm):pos') =
12.552 + (*inform at Frm: replace the whole PrfObj by a Transitive-ProfObj FIXME?0402
12.553 + and transfer the istate (from _after_ compare_deriv) from Frm to Res*)
12.554 + let val (res, asm) = (res_from_taci o last_elem) tacis
12.555 + val (SOME ist,_) = get_obj g_loc pt p
12.556 + val form = get_obj g_form pt p
12.557 + (*val p = lev_on p; ---------------only difference to (..,Res) below*)
12.558 + val tacis = (Begin_Trans, Begin_Trans' form, (pos, Uistate))
12.559 + ::(insert_pos ((lev_on o lev_dn) p) tacis)
12.560 + @ [(End_Trans, End_Trans' (res, asm),
12.561 + (pos_plus (length tacis) (lev_dn p, Res),
12.562 + new_val res ist))]
12.563 + val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p))
12.564 + val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res))
12.565 + val pt = update_tac pt p (Derive (id_rls nrls))
12.566 + (*FIXME.040216 struct.ctree*)
12.567 + val pt = update_branch pt p TransitiveB
12.568 + in (c, (pt, pos:pos')) end
12.569 +
12.570 +(* val (tacis, (pt, (p, Res))) = (tacis', ptp);
12.571 + *)
12.572 + | embed_deriv tacis (pt, (p, Res)) =
12.573 + (*inform at Res: append a Transitive-PrfObj FIXME?0402 other branch-types ?
12.574 + and transfer the istate (from _after_ compare_deriv) from Res to new Res*)
12.575 + let val (res, asm) = (res_from_taci o last_elem) tacis
12.576 + val (_, SOME ist) = get_obj g_loc pt p
12.577 + val (f,a) = get_obj g_result pt p
12.578 + val p = lev_on p(*---------------only difference to (..,Frm) above*);
12.579 + val tacis = (Begin_Trans, Begin_Trans' f, ((p, Frm), Uistate))
12.580 + ::(insert_pos ((lev_on o lev_dn) p) tacis)
12.581 + @ [(End_Trans, End_Trans' (res, asm),
12.582 + (pos_plus (length tacis) (lev_dn p, Res),
12.583 + new_val res ist))];
12.584 + val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p))
12.585 + val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res))
12.586 + val pt = update_tac pt p (Derive (id_rls nrls))
12.587 + (*FIXME.040216 struct.ctree*)
12.588 + val pt = update_branch pt p TransitiveB
12.589 + in (c, (pt, pos)) end;
13.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2 +++ b/src/Tools/isac/Interpret/inform.sml Wed Aug 25 16:20:07 2010 +0200
13.3 @@ -0,0 +1,734 @@
13.4 +(* Handle user-input during the specify- and the solve-phase.
13.5 + author: Walther Neuper
13.6 + 0603
13.7 + (c) due to copyright terms
13.8 +
13.9 +use"ME/inform.sml";
13.10 +use"inform.sml";
13.11 +*)
13.12 +
13.13 +signature INFORM =
13.14 + sig
13.15 +
13.16 + type castab
13.17 + type icalhd
13.18 +
13.19 + (* type iitem *)
13.20 + datatype
13.21 + iitem =
13.22 + Find of cterm' list
13.23 + | Given of cterm' list
13.24 + | Relate of cterm' list
13.25 + type imodel
13.26 + val imodel2fstr : iitem list -> (string * cterm') list
13.27 +
13.28 +
13.29 + val Isac : 'a -> theory
13.30 + val appl_add' :
13.31 + theory' ->
13.32 + SpecifyTools.ori list ->
13.33 + SpecifyTools.itm list ->
13.34 + ('a * (Term.term * Term.term)) list ->
13.35 + string * cterm' -> SpecifyTools.itm
13.36 + (* val appl_adds :
13.37 + theory' ->
13.38 + SpecifyTools.ori list ->
13.39 + SpecifyTools.itm list ->
13.40 + (string * (Term.term * Term.term)) list ->
13.41 + (string * string) list -> SpecifyTools.itm list *)
13.42 + (* val cas_input : string -> ptree * ocalhd *)
13.43 + (* val cas_input_ :
13.44 + spec ->
13.45 + (Term.term * Term.term list) list ->
13.46 + pblID * SpecifyTools.itm list * metID * SpecifyTools.itm list *
13.47 + (bool * Term.term) list *)
13.48 + val castab : castab ref
13.49 + val compare_step :
13.50 + calcstate' -> Term.term -> string * calcstate'
13.51 + (* val concat_deriv :
13.52 + 'a * ((Term.term * Term.term) list -> Term.term * Term.term -> bool)
13.53 + ->
13.54 + rls ->
13.55 + rule list ->
13.56 + Term.term ->
13.57 + Term.term ->
13.58 + bool * (Term.term * rule * (Term.term * Term.term list)) list *)
13.59 + val dropwhile' : (* systest/auto-inform.sml *)
13.60 + ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
13.61 + (* val dtss2itm_ :
13.62 + pbt_ list ->
13.63 + Term.term * Term.term list ->
13.64 + int list * bool * string * SpecifyTools.itm_ *)
13.65 + (* val e_icalhd : icalhd *)
13.66 + val eq7 : ''a * ''b -> ''a * (''b * 'c) -> bool
13.67 + val equal : ''a -> ''a -> bool
13.68 + (* val filter_dsc :
13.69 + SpecifyTools.ori list -> SpecifyTools.itm -> SpecifyTools.ori list *)
13.70 + (* val filter_sep : ('a -> bool) -> 'a list -> 'a list * 'a list *)
13.71 + (* val flattup2 : 'a * ('b * 'c * 'd * 'e) -> 'a * 'b * 'c * 'd * 'e *)
13.72 + (* val fstr2itm_ :
13.73 + theory ->
13.74 + (''a * (Term.term * Term.term)) list ->
13.75 + ''a * string -> int list * bool * ''a * SpecifyTools.itm_ *)
13.76 + val inform :
13.77 + calcstate' -> cterm' -> string * calcstate'
13.78 + val input_icalhd : ptree -> icalhd -> ptree * ocalhd
13.79 + (* val is_Par : SpecifyTools.itm -> bool *)
13.80 + (* val is_casinput : cterm' -> fmz -> bool *)
13.81 + (* val is_e_ts : Term.term list -> bool *)
13.82 + (* val itms2fstr : SpecifyTools.itm -> string * string *)
13.83 + (* val mk_tacis :
13.84 + rew_ord' * 'a ->
13.85 + rls ->
13.86 + Term.term * rule * (Term.term * Term.term list) ->
13.87 + tac * tac_ * (pos' * istate) *)
13.88 + val oris2itms :
13.89 + 'a -> int -> SpecifyTools.ori list -> SpecifyTools.itm list
13.90 + (* val par2fstr : SpecifyTools.itm -> string * cterm' *)
13.91 + (* val parsitm : theory -> SpecifyTools.itm -> SpecifyTools.itm *)
13.92 + val rev_deriv' : 'a * rule * ('b * 'c) -> 'b * rule * ('a * 'c)
13.93 + (* val unknown_expl :
13.94 + theory' ->
13.95 + (string * (Term.term * Term.term)) list ->
13.96 + (string * string) list -> SpecifyTools.itm list *)
13.97 + end
13.98 +
13.99 +
13.100 +
13.101 +
13.102 +
13.103 +
13.104 +(***. handle an input calc-head .***)
13.105 +
13.106 +(*------------------------------------------------------------------(**)
13.107 +structure inform :INFORM =
13.108 +struct
13.109 +(**)------------------------------------------------------------------*)
13.110 +
13.111 +datatype iitem =
13.112 + Given of cterm' list
13.113 +(*Where is never input*)
13.114 +| Find of cterm' list
13.115 +| Relate of cterm' list;
13.116 +
13.117 +type imodel = iitem list;
13.118 +
13.119 +(*calc-head as input*)
13.120 +type icalhd =
13.121 + pos' * (*the position of the calc-head in the calc-tree
13.122 + pos' as (p,p_) where p_ is neglected due to pos_ below*)
13.123 + cterm' * (*the headline*)
13.124 + imodel * (*the model (without Find) of the calc-head*)
13.125 + pos_ * (*model belongs to Pbl or Met*)
13.126 + spec; (*specification: domID, pblID, metID*)
13.127 +val e_icalhd = (e_pos', "", [Given [""]], Pbl, e_spec): icalhd;
13.128 +
13.129 +fun is_casinput (hdf: cterm') ((fmz_, spec): fmz) =
13.130 + hdf <> "" andalso fmz_ = [] andalso spec = e_spec;
13.131 +
13.132 +(*.handle an input as into an algebra system.*)
13.133 +fun dtss2itm_ ppc (d, ts) =
13.134 + let val (f, (d, id)) = the (find_first ((curry op= d) o
13.135 + (#1: (term * term) -> term) o
13.136 + (#2: pbt_ -> (term * term))) ppc)
13.137 + in ([1], true, f, Cor ((d, ts), (id, ts))) end;
13.138 +
13.139 +fun flattup2 (a,(b,c,d,e)) = (a,b,c,d,e);
13.140 +
13.141 +
13.142 +
13.143 +(*.association list with cas-commands, for generating a complete calc-head.*)
13.144 +type castab =
13.145 + (term * (*cas-command, eg. 'solve'*)
13.146 + (spec * (*theory, problem, method*)
13.147 +
13.148 + (*the function generating a kind of formalization*)
13.149 + (term list -> (*the arguments of the cas-command, eg. (x+1=2, x)*)
13.150 + (term * (*description of an element*)
13.151 + term list) (*value of the element (always put into a list)*)
13.152 + list))) (*of elements in the formalization*)
13.153 + list; (*of cas-entries in the association list*)
13.154 +
13.155 +val castab = ref ([]: castab);
13.156 +
13.157 +
13.158 +(*..*)
13.159 +(* val (dI,pI,mI) = spec;
13.160 + *)
13.161 +(*fun cas_input_ ((dI,pI,mI): spec) dtss =
13.162 + let val thy = assoc_thy dI
13.163 + val {ppc,...} = get_pbt pI
13.164 + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
13.165 + val its = add_id its_
13.166 + val pits = map flattup2 its
13.167 + val (pI, mI) = if mI <> ["no_met"] then (pI, mI)
13.168 + else let val SOME (pI,_) = refine_pbl thy pI pits
13.169 + in (pI, (hd o #met o get_pbt) pI) end
13.170 + val {ppc,pre,prls,...} = get_met mI
13.171 + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
13.172 + val its = add_id its_
13.173 + val mits = map flattup2 its
13.174 + val pre = check_preconds thy prls pre mits
13.175 +in (pI, pits: itm list, mI, mits: itm list, pre) end;*)
13.176 +
13.177 +(* val (dI,pI,mI) = spec;
13.178 + *)
13.179 +fun cas_input_ ((dI,pI,mI): spec) dtss =
13.180 + let val thy = assoc_thy dI
13.181 + val {ppc,...} = get_pbt pI
13.182 + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
13.183 + val its = add_id its_
13.184 + val pits = map flattup2 its
13.185 + val (pI, mI) = if mI <> ["no_met"] then (pI, mI)
13.186 + else case refine_pbl thy pI pits of
13.187 + SOME (pI,_) => (pI, (hd o #met o get_pbt) pI)
13.188 + | NONE => (pI, (hd o #met o get_pbt) pI)
13.189 + val {ppc,pre,prls,...} = get_met mI
13.190 + val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
13.191 + val its = add_id its_
13.192 + val mits = map flattup2 its
13.193 + val pre = check_preconds thy prls pre mits
13.194 +in (pI, pits: itm list, mI, mits: itm list, pre) end;
13.195 +
13.196 +
13.197 +(*.check if the input term is a CAScmd and return a ptree with
13.198 + a _complete_ calchead.*)
13.199 +(* val hdt = ifo;
13.200 + *)
13.201 +fun cas_input hdt =
13.202 + let val (h,argl) = strip_comb hdt
13.203 + in case assoc (!castab, h) of
13.204 + NONE => NONE
13.205 + (*let val (pt,_) =
13.206 + cappend_problem e_ptree [] e_istate
13.207 + ([], e_spec) ([], e_spec, e_term)
13.208 + in (pt, (false, Pbl, e_term(*FIXXME031:'not found'*),
13.209 + [], [], e_spec)) end*)
13.210 + | SOME (spec as (dI,_,_), argl2dtss) =>
13.211 + (* val SOME (spec as (dI,_,_), argl2dtss ) = assoc (!castab, h);
13.212 + *)
13.213 + let val dtss = argl2dtss argl
13.214 + val (pI, pits, mI, mits, pre) = cas_input_ spec dtss
13.215 + val spec = (dI, pI, mI)
13.216 + val (pt,_) =
13.217 + cappend_problem e_ptree [] e_istate ([], e_spec)
13.218 + ([], e_spec, hdt)
13.219 + val pt = update_spec pt [] spec
13.220 + val pt = update_pbl pt [] pits
13.221 + val pt = update_met pt [] mits
13.222 + in SOME (pt, (true, Met, hdt, mits, pre, spec):ocalhd) end
13.223 + end;
13.224 +
13.225 +(*lazy evaluation for Isac.thy*)
13.226 +fun Isac _ = assoc_thy "Isac.thy";
13.227 +
13.228 +(*re-parse itms with a new thy and prepare for checking with ori list*)
13.229 +fun parsitm dI (itm as (i,v,b,f, Cor ((d,ts),_)):itm) =
13.230 +(* val itm as (i,v,b,f, Cor ((d,ts),_)) = hd probl;
13.231 + *)
13.232 + (let val t = (comp_dts (Isac "delay")) (d,ts);
13.233 + val s = Syntax.string_of_term (thy2ctxt dI) t;
13.234 + (*this ^ should raise the exn on unability of re-parsing dts*)
13.235 + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
13.236 + | parsitm dI (itm as (i,v,b,f, Syn str)) =
13.237 + (let val t = (term_of o the o (parse dI)) str
13.238 + in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str))
13.239 + | parsitm dI (itm as (i,v,b,f, Typ str)) =
13.240 + (let val t = (term_of o the o (parse dI)) str
13.241 + in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str))
13.242 + | parsitm dI (itm as (i,v,_,f, Inc ((d,ts),_))) =
13.243 + (let val t = (comp_dts (Isac "delay")) (d,ts);
13.244 + val s = Syntax.string_of_term (thy2ctxt dI) t;
13.245 + (*this ^ should raise the exn on unability of re-parsing dts*)
13.246 + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
13.247 + | parsitm dI (itm as (i,v,_,f, Sup (d,ts))) =
13.248 + (let val t = (comp_dts (Isac"delay" )) (d,ts);
13.249 + val s = Syntax.string_of_term (thy2ctxt dI) t;
13.250 + (*this ^ should raise the exn on unability of re-parsing dts*)
13.251 + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
13.252 + | parsitm dI (itm as (i,v,_,f, Mis (d,t'))) =
13.253 + (let val t = d $ t';
13.254 + val s = Syntax.string_of_term (thy2ctxt dI) t;
13.255 + (*this ^ should raise the exn on unability of re-parsing dts*)
13.256 + in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
13.257 + | parsitm dI (itm as (i,v,_,f, Par _)) =
13.258 + raise error ("parsitm (" ^ itm2str_ (thy2ctxt dI) itm^
13.259 + "): Par should be internal");
13.260 +
13.261 +(*separate a list to a pair of elements that do NOT satisfy the predicate,
13.262 + and of elements that satisfy the predicate, i.e. (false, true)*)
13.263 +fun filter_sep pred xs =
13.264 + let fun filt ab [] = ab
13.265 + | filt (a,b) (x :: xs) = if pred x
13.266 + then filt (a,b@[x]) xs
13.267 + else filt (a@[x],b) xs
13.268 + in filt ([],[]) xs end;
13.269 +fun is_Par ((_,_,_,_,Par _):itm) = true
13.270 + | is_Par _ = false;
13.271 +
13.272 +fun is_e_ts [] = true
13.273 + | is_e_ts [Const ("List.list.Nil", _)] = true
13.274 + | is_e_ts _ = false;
13.275 +
13.276 +(*WN.9.11.03 copied from fun appl_add (in modspec.sml)*)
13.277 +(* val (sel,ct) = selct;
13.278 + val (dI, oris, ppc, pbt, (sel, ct))=
13.279 + (#1 (some_spec ospec spec), oris, []:itm list,
13.280 + ((#ppc o get_pbt) (#2 (some_spec ospec spec))),
13.281 + hd (imodel2fstr imodel));
13.282 + *)
13.283 +fun appl_add' dI oris ppc pbt (sel, ct) =
13.284 + let
13.285 + val thy = assoc_thy dI;
13.286 + in case parse thy ct of
13.287 + NONE => (0,[],false,sel, Syn ct):itm
13.288 + | SOME ct => (* val SOME ct = parse thy ct;
13.289 + *)
13.290 + (case is_known thy sel oris (term_of ct) of
13.291 + (* val ("",ori'(*ts='ct'*), all) = is_known thy sel oris (term_of ct);
13.292 + *)
13.293 + ("",ori'(*ts='ct'*), all) =>
13.294 + (case is_notyet_input thy ppc all ori' pbt of
13.295 + (* val ("",itm) = is_notyet_input thy ppc all ori' pbt;
13.296 + *)
13.297 + ("",itm) => itm
13.298 + (* val (msg,xx) = is_notyet_input thy ppc all ori' pbt;
13.299 + *)
13.300 + | (msg,_) => raise error ("appl_add': "^msg))
13.301 + (* val (msg,(_,_,_,d,ts),all) = is_known thy sel oris (term_of ct);
13.302 + *)
13.303 + | (msg,(i,v,_,d,ts),_) =>
13.304 + if is_e_ts ts then (i,v,false, sel, Inc ((d,ts),(e_term,[])))
13.305 + else (i,v,false,sel, Sup (d,ts)))
13.306 + end;
13.307 +
13.308 +(*.generate preliminary itm_ from a strin (with field "#Given" etc.).*)
13.309 +(* val (f, str) = hd selcts;
13.310 + *)
13.311 +fun eq7 (f, d) (f', (d', _)) = f=f' andalso d=d';
13.312 +fun fstr2itm_ thy pbt (f, str) =
13.313 + let val topt = parse thy str
13.314 + in case topt of
13.315 + NONE => ([], false, f, Syn str)
13.316 + | SOME ct =>
13.317 +(* val SOME ct = parse thy str;
13.318 + *)
13.319 + let val (d,ts) = ((split_dts thy) o term_of) ct
13.320 + val popt = find_first (eq7 (f,d)) pbt
13.321 + in case popt of
13.322 + NONE => ([1](*??*), true(*??*), f, Sup (d,ts))
13.323 + | SOME (f, (d, id)) => ([1], true, f, Cor ((d,ts), (id, ts)))
13.324 + end
13.325 + end;
13.326 +
13.327 +
13.328 +(*.input into empty PblObj, i.e. empty fmz+origin (unknown example).*)
13.329 +fun unknown_expl dI pbt selcts =
13.330 + let
13.331 + val thy = assoc_thy dI
13.332 + val its_ = map (fstr2itm_ thy pbt) selcts (*([1],true,"#Given",Cor (...))*)
13.333 + val its = add_id its_
13.334 +in (map flattup2 its): itm list end;
13.335 +
13.336 +
13.337 +
13.338 +
13.339 +(*WN.11.03 for input_icalhd, ~ specify_additem for Add_Given/_Find/_Relation
13.340 + appl_add': generate 1 item
13.341 + appl_add' . is_known: parse, get data from oris (vats, all (elems if list)..)
13.342 + appl_add' . is_notyet_input: compare with items in model already input
13.343 + insert_ppc': insert this 1 item*)
13.344 +(* val (dI,oris,ppc,pbt,selcts) =((#1 (some_spec ospec spec)),oris,[(*!!*)],
13.345 + ((#ppc o get_pbt) (#2 (some_spec ospec spec))),
13.346 + (imodel2fstr imodel));
13.347 + *)
13.348 +fun appl_adds dI [] _ pbt selcts = unknown_expl dI pbt selcts
13.349 + (*already present itms in model are being overwritten*)
13.350 + | appl_adds dI oris ppc pbt [] = ppc
13.351 + | appl_adds dI oris ppc pbt (selct::ss) =
13.352 + (* val selct = (sel, string_of_cterm ct);
13.353 + *)
13.354 + let val itm = appl_add' dI oris ppc pbt selct;
13.355 + in appl_adds dI oris (insert_ppc' itm ppc) pbt ss end;
13.356 +(* val (dI, oris, ppc, pbt, selct::ss) =
13.357 + (dI, pors, probl, ppc, map itms2fstr probl);
13.358 + ...vvv
13.359 + *)
13.360 +(* val (dI, oris, ppc, pbt, (selct::ss))=
13.361 + (#1 (some_spec ospec spec), oris, []:itm list,
13.362 + ((#ppc o get_pbt) (#2 (some_spec ospec spec))),(imodel2fstr imodel));
13.363 + val iii = appl_adds dI oris ppc pbt (selct::ss);
13.364 + writeln(itms2str_ thy iii);
13.365 +
13.366 + val itm = appl_add' dI oris ppc pbt selct;
13.367 + val ppc = insert_ppc' itm ppc;
13.368 +
13.369 + val _::selct::ss = (selct::ss);
13.370 + val itm = appl_add' dI oris ppc pbt selct;
13.371 + val ppc = insert_ppc' itm ppc;
13.372 +
13.373 + val _::selct::ss = (selct::ss);
13.374 + val itm = appl_add' dI oris ppc pbt selct;
13.375 + val ppc = insert_ppc' itm ppc;
13.376 + writeln(itms2str_ thy ppc);
13.377 +
13.378 + val _::selct::ss = (selct::ss);
13.379 + val itm = appl_add' dI oris ppc pbt selct;
13.380 + val ppc = insert_ppc' itm ppc;
13.381 + *)
13.382 +
13.383 +
13.384 +fun oris2itms _ _ ([]:ori list) = ([]:itm list)
13.385 + | oris2itms pbt vat ((i,v,f,d,ts)::(os: ori list)) =
13.386 + if member op = vat v
13.387 + then (i,v,true,f,Cor ((d,ts),(e_term,[])))::(oris2itms pbt vat os)
13.388 + else oris2itms pbt vat os;
13.389 +
13.390 +fun filter_dsc oris itm =
13.391 + filter_out ((curry op= ((d_in o #5) (itm:itm))) o
13.392 + (#4:ori -> term)) oris;
13.393 +
13.394 +
13.395 +
13.396 +
13.397 +fun par2fstr ((_,_,_,f, Par s):itm) = (f, s)
13.398 + | par2fstr itm = raise error ("par2fstr: called with " ^
13.399 + itm2str_ (thy2ctxt' "Isac") itm);
13.400 +fun itms2fstr ((_,_,_,f, Cor ((d,ts),_)):itm) = (f, comp_dts'' (d,ts))
13.401 + | itms2fstr (_,_,_,f, Syn str) = (f, str)
13.402 + | itms2fstr (_,_,_,f, Typ str) = (f, str)
13.403 + | itms2fstr (_,_,_,f, Inc ((d,ts),_)) = (f, comp_dts'' (d,ts))
13.404 + | itms2fstr (_,_,_,f, Sup (d,ts)) = (f, comp_dts'' (d,ts))
13.405 + | itms2fstr (_,_,_,f, Mis (d,t)) = (f, term2str (d $ t))
13.406 + | itms2fstr (itm as (_,_,_,f, Par _)) =
13.407 + raise error ("parsitm ("^itm2str_ (thy2ctxt' "Isac") itm ^
13.408 + "): Par should be internal");
13.409 +
13.410 +fun imodel2fstr iitems =
13.411 + let fun xxx is [] = is
13.412 + | xxx is ((Given strs)::iis) =
13.413 + xxx (is @ (map (pair "#Given") strs)) iis
13.414 + | xxx is ((Find strs)::iis) =
13.415 + xxx (is @ (map (pair "#Find") strs)) iis
13.416 + | xxx is ((Relate strs)::iis) =
13.417 + xxx (is @ (map (pair "#Relate") strs)) iis
13.418 + in xxx [] iitems end;
13.419 +
13.420 +(*.input a CAS-command via a whole calchead;
13.421 + dWN0602 ropped due to change of design in the front-end.*)
13.422 +(*since previous calc-head _only_ has changed:
13.423 + EITHER _1_ part of the specification OR some items in the model;
13.424 + the hdform is left as is except in cas_input .*)
13.425 +(*FIXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX___Met___XXXXXXXXXXXME.TODO.WN:11.03*)
13.426 +(* val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) =
13.427 + (p, "xxx", empty_model, Pbl, e_spec);
13.428 + val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) =
13.429 + (p,"", [Given ["fixedValues [r=Arbfix]"],
13.430 + Find ["maximum A", "valuesFor [a,b]"],
13.431 + Relate ["relations [A=a*b, a/2=r*sin alpha, \
13.432 + \b/2=r*cos alpha]"]], Pbl, e_spec);
13.433 + val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) =
13.434 + (([],Pbl), "not used here",
13.435 + [Given ["fixedValues [r=Arbfix]"],
13.436 + Find ["maximum A", "valuesFor [a,b]"(*new input*)],
13.437 + Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl,
13.438 + ("DiffApp.thy", ["e_pblID"], ["e_metID"]));
13.439 + val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = ichd;
13.440 + *)
13.441 +fun input_icalhd pt (((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)):icalhd) =
13.442 + let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'),
13.443 + spec = sspec as (sdI,spI,smI), probl, meth,...} =
13.444 + get_obj I pt p;
13.445 + in if is_casinput hdf fmz then the (cas_input (str2term hdf))
13.446 + else (*hacked WN0602 ~~~ ~~~~~~~~~, ..dropped !*)
13.447 + let val (pos_, pits, mits) =
13.448 + if dI <> sdI
13.449 + then let val its = map (parsitm (assoc_thy dI)) probl;
13.450 + val (its, trms) = filter_sep is_Par its;
13.451 + val pbt = (#ppc o get_pbt) (#2(some_spec ospec sspec));
13.452 + in (Pbl, appl_adds dI oris its pbt
13.453 + (map par2fstr trms), meth) end else
13.454 + if pI <> spI
13.455 + then if pI = snd3 ospec then (Pbl, probl, meth) else
13.456 + let val pbt = (#ppc o get_pbt) pI
13.457 + val dI' = #1 (some_spec ospec spec)
13.458 + val oris = if pI = #2 ospec then oris
13.459 + else prep_ori fmz_(assoc_thy"Isac.thy") pbt;
13.460 + in (Pbl, appl_adds dI' oris probl pbt
13.461 + (map itms2fstr probl), meth) end else
13.462 + if mI <> smI (*FIXME.WN0311: what if probl is incomplete?!*)
13.463 + then let val met = (#ppc o get_met) mI
13.464 + val mits = complete_metitms oris probl meth met
13.465 + in if foldl and_ (true, map #3 mits)
13.466 + then (Pbl, probl, mits) else (Met, probl, mits)
13.467 + end else
13.468 + (Pbl, appl_adds (#1 (some_spec ospec spec)) oris [(*!!!*)]
13.469 + ((#ppc o get_pbt) (#2 (some_spec ospec spec)))
13.470 + (imodel2fstr imodel), meth);
13.471 + val pt = update_spec pt p spec;
13.472 + in if pos_ = Pbl
13.473 + then let val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec))
13.474 + val pre =check_preconds(assoc_thy"Isac.thy")prls where_ pits
13.475 + in (update_pbl pt p pits,
13.476 + (ocalhd_complete pits pre spec,
13.477 + Pbl, hdf', pits, pre, spec):ocalhd) end
13.478 + else let val {prls,pre,...} = get_met (#3 (some_spec ospec spec))
13.479 + val pre = check_preconds (assoc_thy"Isac.thy") prls pre mits
13.480 + in (update_met pt p mits,
13.481 + (ocalhd_complete mits pre spec,
13.482 + Met, hdf', mits, pre, spec):ocalhd) end
13.483 + end end
13.484 + | input_icalhd pt ((p,_), hdf, imodel, _(*Met*), spec as (dI,pI,mI)) =
13.485 + raise error "input_icalhd Met not impl.";
13.486 +
13.487 +
13.488 +(***. handle an input formula .***)
13.489 +(*
13.490 +Untersuchung zur Formeleingabe (appendFormula, replaceFormla) zu einer Anregung von Alan Krempler:
13.491 +Welche RICHTIGEN Formeln koennen NICHT abgeleitet werden,
13.492 +wenn Abteilungen nur auf gleichem Level gesucht werden ?
13.493 +WN.040216
13.494 +
13.495 +Beispiele zum Equationsolver von Richard Lang aus /src/sml/kbtest/rlang.sml
13.496 +
13.497 +------------------------------------------------------------------------------
13.498 +"Schalk I s.87 Bsp 52a ((5*x)/(x - 2) - x/(x+2)=4)";
13.499 +------------------------------------------------------------------------------
13.500 +1. "5 * x / (x - 2) - x / (x + 2) = 4"
13.501 +...
13.502 +4. "12 * x + 4 * x ^^^ 2 = 4 * (-4 + x ^^^ 2)",Subproblem["normalize", "poly"..
13.503 +...
13.504 +4.3. "16 + 12 * x = 0", Subproblem["degree_1", "polynomial", "univariate"..
13.505 +...
13.506 +4.3.3. "[x = -4 / 3]")), Check_elementwise "Assumptions"
13.507 +...
13.508 +"[x = -4 / 3]"
13.509 +------------------------------------------------------------------------------
13.510 +(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n]
13.511 +
13.512 +(4.1)..(4.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n]
13.513 +------------------------------------------------------------------------------
13.514 +
13.515 +
13.516 +------------------------------------------------------------------------------
13.517 +"Schalk I s.87 Bsp 55b (x/(x^^^2 - 6*x+9) - 1/(x^^^2 - 3*x) =1/x)";
13.518 +------------------------------------------------------------------------------
13.519 +1. "x / (x ^^^ 2 - 6 * x + 9) - 1 / (x ^^^ 2 - 3 * x) = 1 / x"
13.520 +...
13.521 +4. "(3 + (-1 * x + x ^^^ 2)) * x = 1 * (9 * x + (x ^^^ 3 + -6 * x ^^^ 2))"
13.522 + Subproblem["normalize", "polynomial", "univariate"..
13.523 +...
13.524 +4.4. "-6 * x + 5 * x ^^^ 2 = 0", Subproblem["bdv_only", "degree_2", "poly"..
13.525 +...
13.526 +4.4.4. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions"
13.527 +4.4.5. "[x = 0, x = 6 / 5]"
13.528 +...
13.529 +5. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions"
13.530 + "[x = 6 / 5]"
13.531 +------------------------------------------------------------------------------
13.532 +(1)..(4): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite schiebt [Ableitung waere in 4.4.x]
13.533 +
13.534 +(4.1)..(4.4.5): keine 'richtige' Eingabe kann abgeleitet werden, die dem Ergebnis "[x = 6 / 5]" aequivalent ist [Ableitung waere in 5.]
13.535 +------------------------------------------------------------------------------
13.536 +
13.537 +
13.538 +------------------------------------------------------------------------------
13.539 +"Schalk II s.56 Bsp 73b (sqrt(x+1)+sqrt(4*x+4)=sqrt(9*x+9))";
13.540 +------------------------------------------------------------------------------
13.541 +1. "sqrt (x + 1) + sqrt (4 * x + 4) = sqrt (9 * x + 9)"
13.542 +...
13.543 +6. "13 + 13 * x + -2 * sqrt ((4 + 4 * x) * (9 + 9 * x)) = 1 + x"
13.544 + Subproblem["sq", "root", "univariate", "equation"]
13.545 +...
13.546 +6.6. "144 + 288 * x + 144 * x ^^^ 2 = 144 + x ^^^ 2 + 288 * x + 143 * x ^^^ 2"
13.547 + Subproblem["normalize", "polynomial", "univariate", "equation"]
13.548 +...
13.549 +6.6.3 "0 = 0" Subproblem["degree_0", "polynomial", "univariate", "equation"]
13.550 +... Or_to_List
13.551 +6.6.3.2 "UniversalList"
13.552 +------------------------------------------------------------------------------
13.553 +(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die eine der Wurzeln auf die andere Seite verschieb [Ableitung ware in 6.6.n]
13.554 +
13.555 +(6.1)..(6.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 6.6.n]
13.556 +------------------------------------------------------------------------------
13.557 +*)
13.558 +(*sh. comments auf 498*)
13.559 +
13.560 +fun equal a b = a=b;
13.561 +
13.562 +(*the lists contain eq-al elem-pairs at the beginning;
13.563 + return first list reverted (again) - ie. in order as required subsequently*)
13.564 +fun dropwhile' equal (f1::f2::fs) (i1::i2::is) =
13.565 + if equal f1 i1 then
13.566 + if equal f2 i2 then dropwhile' equal (f2::fs) (i2::is)
13.567 + else (rev (f1::f2::fs), i1::i2::is)
13.568 + else raise error "dropwhile': did not start with equal elements"
13.569 + | dropwhile' equal (f::fs) [i] =
13.570 + if equal f i then (rev (f::fs), [i])
13.571 + else raise error "dropwhile': did not start with equal elements"
13.572 + | dropwhile' equal [f] (i::is) =
13.573 + if equal f i then ([f], i::is)
13.574 + else raise error "dropwhile': did not start with equal elements";
13.575 +(*
13.576 + fun equal a b = a=b;
13.577 + val foder = [0,1,2,3,4,5]; val ifoder = [11,12,3,4,5];
13.578 + val r_foder = rev foder; val r_ifoder = rev ifoder;
13.579 + dropwhile' equal r_foder r_ifoder;
13.580 +> vval it = ([0, 1, 2, 3], [3, 12, 11]) : int list * int list
13.581 +
13.582 + val foder = [3,4,5]; val ifoder = [11,12,3,4,5];
13.583 + val r_foder = rev foder; val r_ifoder = rev ifoder;
13.584 + dropwhile' equal r_foder r_ifoder;
13.585 +> val it = ([3], [3, 12, 11]) : int list * int list
13.586 +
13.587 + val foder = [5]; val ifoder = [11,12,3,4,5];
13.588 + val r_foder = rev foder; val r_ifoder = rev ifoder;
13.589 + dropwhile' equal r_foder r_ifoder;
13.590 +> val it = ([5], [5, 4, 3, 12, 11]) : int list * int list
13.591 +
13.592 + val foder = [10,11,12,13,14,15]; val ifoder = [11,12,3,4,5];
13.593 + val r_foder = rev foder; val r_ifoder = rev ifoder;
13.594 + dropwhile' equal r_foder r_ifoder;
13.595 +> *** dropwhile': did not start with equal elements*)
13.596 +
13.597 +(*040214: version for concat_deriv*)
13.598 +fun rev_deriv' (t, r, (t', a)) = (t', sym_Thm r, (t, a));
13.599 +
13.600 +fun mk_tacis ro erls (t, r as Thm _, (t', a)) =
13.601 + (Rewrite (rule2thm' r),
13.602 + Rewrite' ("Isac.thy", fst ro, erls, false,
13.603 + rule2thm' r, t, (t', a)),
13.604 + (e_pos'(*to be updated before generate tacis!!!*), Uistate))
13.605 + | mk_tacis ro erls (t, r as Rls_ rls, (t', a)) =
13.606 + (Rewrite_Set (rule2rls' r),
13.607 + Rewrite_Set' ("Isac.thy", false, rls, t, (t', a)),
13.608 + (e_pos'(*to be updated before generate tacis!!!*), Uistate));
13.609 +
13.610 +(*fo = ifo excluded already in inform*)
13.611 +fun concat_deriv rew_ord erls rules fo ifo =
13.612 + let fun derivat ([]:(term * rule * (term * term list)) list) = e_term
13.613 + | derivat dt = (#1 o #3 o last_elem) dt
13.614 + fun equal (_,_,(t1, _)) (_,_,(t2, _)) = t1=t2
13.615 + val fod = make_deriv (Isac"") erls rules (snd rew_ord) NONE fo
13.616 + val ifod = make_deriv (Isac"") erls rules (snd rew_ord) NONE ifo
13.617 + in case (fod, ifod) of
13.618 + ([], []) => if fo = ifo then (true, [])
13.619 + else (false, [])
13.620 + | (fod, []) => if derivat fod = ifo
13.621 + then (true, fod) (*ifo is normal form*)
13.622 + else (false, [])
13.623 + | ([], ifod) => if fo = derivat ifod
13.624 + then (true, ((map rev_deriv') o rev) ifod)
13.625 + else (false, [])
13.626 + | (fod, ifod) =>
13.627 + if derivat fod = derivat ifod (*common normal form found*)
13.628 + then let val (fod', rifod') =
13.629 + dropwhile' equal (rev fod) (rev ifod)
13.630 + in (true, fod' @ (map rev_deriv' rifod')) end
13.631 + else (false, [])
13.632 + end;
13.633 +(*
13.634 + val ({rew_ord, erls, rules,...}, fo, ifo) =
13.635 + (rep_rls Test_simplify, str2term "x+1+ -1*2=0", str2term "-2*1+(x+1)=0");
13.636 + (writeln o trtas2str) fod';
13.637 +> ["
13.638 +(x + 1 + -1 * 2 = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (x + 1) = 0, []))","
13.639 +(-1 * 2 + (x + 1) = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (1 + x) = 0, []))","
13.640 +(-1 * 2 + (1 + x) = 0, Thm ("radd_left_commute","?x + (?y + ?z) = ?y + (?x + ?z)"), (1 + (-1 * 2 + x) = 0, []))","
13.641 +(1 + (-1 * 2 + x) = 0, Thm ("#mult_Float ((~1,0), (0,0)) __ ((2,0), (0,0))","-1 * 2 = -2"), (1 + (-2 + x) = 0, []))"]
13.642 +val it = () : unit
13.643 + (writeln o trtas2str) (map rev_deriv' rifod');
13.644 +> ["
13.645 +(1 + (-2 + x) = 0, Thm ("sym_#mult_Float ((~2,0), (0,0)) __ ((1,0), (0,0))","-2 = -2 * 1"), (1 + (-2 * 1 + x) = 0, []))","
13.646 +(1 + (-2 * 1 + x) = 0, Thm ("sym_radd_left_commute","?y + (?x + ?z) = ?x + (?y + ?z)"), (-2 * 1 + (1 + x) = 0, []))","
13.647 +(-2 * 1 + (1 + x) = 0, Thm ("sym_radd_commute","?n + ?m = ?m + ?n"), (-2 * 1 + (x + 1) = 0, []))"]
13.648 +val it = () : unit
13.649 +*)
13.650 +
13.651 +
13.652 +(*.compare inform with ctree.form at current pos by nrls;
13.653 + if found, embed the derivation generated during comparison
13.654 + if not, let the mat-engine compute the next ctree.form.*)
13.655 +(*structure copied from complete_solve
13.656 + CAUTION: tacis in returned calcstate' do NOT construct resulting ptp --
13.657 + all_modspec etc. has to be inserted at Subproblem'*)
13.658 +(* val (tacis, c, ptp as (pt, pos as (p,p_))) = (tacis, ptp);
13.659 + val (tacis, c, ptp as (pt, pos as (p,p_))) = cs';
13.660 +
13.661 + val (tacis, c, ptp as (pt, pos as (p,p_))) = ([],[],(pt, lev_back pos));
13.662 + -----rec.call:
13.663 + val (tacis, c, ptp as (pt, pos as (p,p_))) = cs';
13.664 + *)
13.665 +fun compare_step ((tacis, c, ptp as (pt, pos as (p,p_))): calcstate') ifo =
13.666 + let val fo = case p_ of Frm => get_obj g_form pt p
13.667 + | Res => (fst o (get_obj g_result pt)) p
13.668 + | _ => e_term (*on PblObj is fo <> ifo*);
13.669 + val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p))
13.670 + val {rew_ord, erls, rules,...} = rep_rls nrls
13.671 + val (found, der) = concat_deriv rew_ord erls rules fo ifo;
13.672 + in if found
13.673 + then let val tacis' = map (mk_tacis rew_ord erls) der;
13.674 + val (c', ptp) = embed_deriv tacis' ptp;
13.675 + in ("ok", (tacis (*@ tacis'?WN050408*), c @ c', ptp)) end
13.676 + else
13.677 + if pos = ([], Res)
13.678 + then ("no derivation found", (tacis, c, ptp): calcstate')
13.679 + else let val cs' as (tacis, c', ptp) = nxt_solve_ ptp;
13.680 + val cs' as (tacis, c'', ptp) =
13.681 + case tacis of
13.682 + ((Subproblem _, _, _)::_) =>
13.683 + let val ptp as (pt, (p,_)) = all_modspec ptp
13.684 + val mI = get_obj g_metID pt p
13.685 + in nxt_solv (Apply_Method' (mI, NONE, e_istate))
13.686 + e_istate ptp end
13.687 + | _ => cs';
13.688 + in compare_step (tacis, c @ c' @ c'', ptp) ifo end
13.689 + end;
13.690 +(* writeln (trtas2str der);
13.691 + *)
13.692 +
13.693 +(*.handle a user-input formula, which may be a CAS-command, too.
13.694 +CAS-command:
13.695 + create a calchead, and do 1 step
13.696 + TOOODO.WN0602 works only for the root-problem !!!
13.697 +formula, which is no CAS-command:
13.698 + compare iform with calc-tree.form at pos by equ_nrls and all subsequent pos;
13.699 + collect all the tacs applied by the way.*)
13.700 +(*structure copied from autocalc*)
13.701 +(* val (cs as (_, _, (pt, pos as (p, p_))): calcstate') = cs';
13.702 + val ifo = str2term ifo;
13.703 +
13.704 + val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) =
13.705 + (cs', encode ifo);
13.706 + val ((cs as (_, _, ptp as (pt, pos as (p, p_)))), istr)=(cs', (encode ifo));
13.707 + val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) =
13.708 + (([],[],(pt,p)), (encode ifo));
13.709 + *)
13.710 +fun inform (cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate') istr =
13.711 + case parse (assoc_thy "Isac.thy") istr of
13.712 +(* val SOME ifo = parse (assoc_thy "Isac.thy") istr;
13.713 + *)
13.714 + SOME ifo =>
13.715 + let val ifo = term_of ifo
13.716 + val fo = case p_ of Frm => get_obj g_form pt p
13.717 + | Res => (fst o (get_obj g_result pt)) p
13.718 + | _ => #3 (get_obj g_origin pt p)
13.719 + in if fo = ifo
13.720 + then ("same-formula", cs)
13.721 + (*thus ctree not cut with replaceFormula!*)
13.722 + else case cas_input ifo of
13.723 +(* val SOME (pt, _) = cas_input ifo;
13.724 + *)
13.725 + SOME (pt, _) => ("ok",([],[],(pt, (p, Met))))
13.726 + | NONE =>
13.727 + compare_step ([],[],(pt,
13.728 + (*last step re-calc in compare_step TODO*)
13.729 + lev_back pos)) ifo
13.730 + end
13.731 + | NONE => ("syntax error in '"^istr^"'", e_calcstate');
13.732 +
13.733 +
13.734 +(*------------------------------------------------------------------(**)
13.735 +end
13.736 +open inform;
13.737 +(**)------------------------------------------------------------------*)
14.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2 +++ b/src/Tools/isac/Interpret/mathengine.sml Wed Aug 25 16:20:07 2010 +0200
14.3 @@ -0,0 +1,506 @@
14.4 +(* The _functional_ mathematics engine, ie. without a state.
14.5 + Input and output are Isabelle's formulae as strings.
14.6 + authors: Walther Neuper 2000
14.7 + (c) due to copyright terms
14.8 +
14.9 +use"mathengine.sml";
14.10 +*)
14.11 +
14.12 +signature MATHENGINE =
14.13 + sig
14.14 + type nxt_
14.15 + (* datatype nxt_ = HElpless | Nexts of CalcHead.calcstate *)
14.16 + type NEW
14.17 + type lOc_
14.18 + (*datatype
14.19 + lOc_ =
14.20 + ERror of string
14.21 + | UNsafe of CalcHead.calcstate'
14.22 + | Updated of CalcHead.calcstate' *)
14.23 +
14.24 + val CalcTreeTEST :
14.25 + fmz list ->
14.26 + pos' * NEW * mout * (string * tac) * safe * ptree
14.27 +
14.28 + val TESTg_form : ptree * (int list * pos_) -> mout
14.29 + val autocalc :
14.30 + pos' list ->
14.31 + pos' ->
14.32 + (ptree * pos') * taci list ->
14.33 + auto -> string * pos' list * (ptree * pos')
14.34 + val detailstep : ptree -> pos' -> string * ptree * pos'
14.35 + (* val e_tac_ : tac_ *)
14.36 + val f2str : mout -> cterm'
14.37 + (* val get_pblID : ptree * pos' -> pblID option *)
14.38 + val initmatch : ptree -> pos' -> ptform
14.39 + (* val loc_solve_ :
14.40 + string * tac_ -> ptree * (int list * pos_) -> lOc_ *)
14.41 + (* val loc_specify_ : tac_ -> ptree * pos' -> lOc_ *)
14.42 + val locatetac : (*tests only*)
14.43 + tac ->
14.44 + ptree * (posel list * pos_) ->
14.45 + string * (taci list * pos' list * (ptree * (posel list * pos_)))
14.46 + val me :
14.47 + tac'_ ->
14.48 + pos' ->
14.49 + NEW ->
14.50 + ptree -> pos' * NEW * mout * tac'_ * safe * ptree
14.51 +
14.52 + val nxt_specify_ : ptree * (int list * pos_) -> calcstate'(*tests only*)
14.53 + val set_method : metID -> ptree * pos' -> ptree * ocalhd
14.54 + val set_problem : pblID -> ptree * pos' -> ptree * ocalhd
14.55 + val set_theory : thyID -> ptree * pos' -> ptree * ocalhd
14.56 + val step : pos' -> calcstate -> string * calcstate'
14.57 + val trymatch : pblID -> ptree -> pos' -> ptform
14.58 + val tryrefine : pblID -> ptree -> pos' -> ptform
14.59 + end
14.60 +
14.61 +
14.62 +
14.63 +(*------------------------------------------------------------------(**)
14.64 +structure MathEngine : MATHENGINE =
14.65 +struct
14.66 +(**)------------------------------------------------------------------*)
14.67 +
14.68 +fun get_pblID (pt, (p,_):pos') =
14.69 + let val p' = par_pblobj pt p
14.70 + val (_,pI,_) = get_obj g_spec pt p'
14.71 + val (_,(_,oI,_),_) = get_obj g_origin pt p'
14.72 + in if pI <> e_pblID then SOME pI
14.73 + else if oI <> e_pblID then SOME oI
14.74 + else NONE end;
14.75 +(*fun get_pblID (pt, (p,_):pos') =
14.76 + ((snd3 o (get_obj g_spec pt)) (par_pblobj pt p));*)
14.77 +
14.78 +
14.79 +(*--vvv--dummies for test*)
14.80 +val e_tac_ = Tac_ (Pure.thy,"","","");
14.81 +datatype lOc_ =
14.82 + ERror of string (*after loc_specify, loc_solve*)
14.83 +| UNsafe of calcstate' (*after loc_specify, loc_solve*)
14.84 +| Updated of calcstate'; (*after loc_specify, loc_solve*)
14.85 +fun loc_specify_ m (pt,pos) =
14.86 +(* val pos = ip;
14.87 + *)
14.88 + let val (p,_,f,_,s,pt) = specify m pos [] pt;
14.89 +(* val (_,_,_,_,_,pt')= specify m pos [] pt;
14.90 + *)
14.91 + in case f of
14.92 + (Error' (Error_ e)) => ERror e
14.93 + | _ => Updated ([], [], (pt,p)) end;
14.94 +
14.95 +(*. TODO push return-value cs' into solve and rename solve->loc_solve?_? .*)
14.96 +(* val (m, pos) = ((mI,m), ip);
14.97 + val (m,(pt,pos) ) = ((mI,m), ptp);
14.98 + *)
14.99 +fun loc_solve_ m (pt,pos) =
14.100 + let val (msg, cs') = solve m (pt, pos);
14.101 +(* val (tacis,dels,(pt',p')) = cs';
14.102 + (writeln o istate2str) (get_istate pt' p');
14.103 + (term2str o fst) (get_obj g_result pt' (fst p'));
14.104 + *)
14.105 + in case msg of
14.106 + "ok" => Updated cs'
14.107 + | msg => ERror msg
14.108 + end;
14.109 +
14.110 +datatype nxt_ =
14.111 + HElpless (**)
14.112 + | Nexts of calcstate; (**)
14.113 +
14.114 +(*. locate a tactic in a script and apply it if possible .*)
14.115 +(*report applicability of tac in tacis; pt is dropped in setNextTactic*)
14.116 +fun locatetac _ (ptp as (_,([],Res))) = ("end-of-calculation", ([], [], ptp))
14.117 +(* val ptp as (pt, p) = (pt, p);
14.118 + val ptp as (pt, p) = (pt, ip);
14.119 + *)
14.120 + | locatetac tac (ptp as (pt, p)) =
14.121 + let val (mI,m) = mk_tac'_ tac;
14.122 + in case applicable_in p pt m of
14.123 + Notappl e => ("not-applicable", ([],[], ptp):calcstate')
14.124 + | Appl m =>
14.125 +(* val Appl m = applicable_in p pt m;
14.126 + *)
14.127 + let val x = if member op = specsteps mI
14.128 + then loc_specify_ m ptp else loc_solve_ (mI,m) ptp
14.129 + in case x of
14.130 + ERror e => ("failure", ([], [], ptp))
14.131 + (*FIXXXXXME: loc_specify_, loc_solve_ TOGETHER with dropping meOLD+detail.sml*)
14.132 + | UNsafe cs' => ("unsafe-ok", cs')
14.133 + | Updated (cs' as (_,_,(_,p'))) =>
14.134 + (*ev.SEVER.tacs like Begin_Trans*)
14.135 + (if p' = ([],Res) then "end-of-calculation" else "ok",
14.136 + cs')(*for -"- user to ask ? *)
14.137 + end
14.138 + end;
14.139 +
14.140 +
14.141 +(*------------------------------------------------------------------
14.142 +fun init_detail ptp = e_calcstate;(*15.8.03.MISSING-->solve.sml!?*)
14.143 +(*----------------------------------------------------from solve.sml*)
14.144 + | nxt_solv (Detail_Set'(thy', rls, t)) (pt, p) =
14.145 + let (*val rls = the (assoc(!ruleset',rls'))
14.146 + handle _ => raise error ("solve: '"^rls'^"' not known");*)
14.147 + val thy = assoc_thy thy';
14.148 + val (srls, sc, is) =
14.149 + case rls of
14.150 + Rrls {scr=sc as Rfuns {init_state=ii,...},...} =>
14.151 + (e_rls, sc, RrlsState (ii t))
14.152 + | Rls {srls=srls,scr=sc as Script s,...} =>
14.153 + (srls, sc, ScrState ([(one_scr_arg s,t)], [],
14.154 + NONE, e_term, Sundef, true));
14.155 + val pt = update_tac pt (fst p) (Detail_Set (id_rls rls));
14.156 + val (p,cid,_,pt) = generate1 thy (Begin_Trans' t) is p pt;
14.157 + val nx = (tac_2tac o fst3) (next_tac (thy',srls) (pt,p) sc is);
14.158 + val aopt = applicable_in p pt nx;
14.159 + in case aopt of
14.160 + Notappl s => raise error ("solve Detail_Set: "^s)
14.161 + (* val Appl m = aopt;
14.162 + *)
14.163 + | Appl m => solve ("discardFIXME",m) p pt end
14.164 +------------------------------------------------------------------*)
14.165 +
14.166 +
14.167 +(*iterated by nxt_me; there (the resulting) ptp dropped
14.168 + may call nxt_solve Apply_Method --- thus evaluated here after solve.sml*)
14.169 +(* val (ptp as (pt, pos as (p,p_))) = ptp;
14.170 + val (ptp as (pt, pos as (p,p_))) = (pt,ip);
14.171 + *)
14.172 +fun nxt_specify_ (ptp as (pt, pos as (p,p_))) =
14.173 + let val pblobj as (PblObj{meth,origin=origin as (oris,(dI',pI',mI'),_),
14.174 + probl,spec=(dI,pI,mI),...}) = get_obj I pt p;
14.175 + in if just_created_ pblobj (*by Subproblem*) andalso origin <> e_origin
14.176 + then case mI' of
14.177 + ["no_met"] => nxt_specif (Refine_Tacitly pI') (pt, (p, Pbl))
14.178 + | _ => nxt_specif Model_Problem (pt, (p,Pbl))
14.179 + else let val cpI = if pI = e_pblID then pI' else pI;
14.180 + val cmI = if mI = e_metID then mI' else mI;
14.181 + val {ppc,prls,where_,...} = get_pbt cpI;
14.182 + val pre = check_preconds "thy 100820" prls where_ probl;
14.183 + val pb = foldl and_ (true, map fst pre);
14.184 + (*FIXME.WN0308: ~~~~~: just check true in itms of pbl/met?*)
14.185 + val (_,tac) =
14.186 + nxt_spec p_ pb oris (dI',pI',mI') (probl, meth)
14.187 + (ppc, (#ppc o get_met) cmI) (dI, pI, mI);
14.188 + in case tac of
14.189 + Apply_Method mI =>
14.190 +(* val Apply_Method mI = tac;
14.191 + *)
14.192 + nxt_solv (Apply_Method' (mI, NONE, e_istate)) e_istate ptp
14.193 + | _ => nxt_specif tac ptp end
14.194 + end;
14.195 +
14.196 +
14.197 +(*.specify a new method;
14.198 + WN0512 impl.incomplete, see 'nxt_specif (Specify_Method ' .*)
14.199 +fun set_method (mI:metID) ptp =
14.200 + let val ([(_, Specify_Method' (_, _, mits), _)], [], (pt, pos as (p,_))) =
14.201 + nxt_specif (Specify_Method mI) ptp
14.202 + val pre = [] (*...from Specify_Method'*)
14.203 + val complete = true (*...from Specify_Method'*)
14.204 + (*from Specify_Method' ? vvv, vvv ?*)
14.205 + val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p
14.206 + in (pt, (complete, Met, hdf, mits, pre, spec):ocalhd) end;
14.207 +
14.208 +(* val ([(_, Specify_Method' (_, _, mits), _)], [],_) =
14.209 + nxt_specif (Specify_Method mI) ptp;
14.210 + *)
14.211 +
14.212 +(*.specify a new problem;
14.213 + WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem ' .*)
14.214 +(* val (pI, ptp) = (pI, (pt, ip));
14.215 + *)
14.216 +fun set_problem pI (ptp: ptree * pos') =
14.217 + let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)],
14.218 + _, (pt, pos as (p,_))) = nxt_specif (Specify_Problem pI) ptp
14.219 + (*from Specify_Problem' ? vvv, vvv ?*)
14.220 + val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p
14.221 + in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end;
14.222 +
14.223 +fun set_theory (tI:thyID) (ptp: ptree * pos') =
14.224 + let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)],
14.225 + _, (pt, pos as (p,_))) = nxt_specif (Specify_Theory tI) ptp
14.226 + (*from Specify_Theory' ? vvv, vvv ?*)
14.227 + val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p
14.228 + in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end;
14.229 +
14.230 +(*.does a step forward; returns tactic used, ctree updated.
14.231 +TODO.WN0512 redesign after specify-phase became more separated from solve-phase
14.232 +arg ip:
14.233 + calcstate
14.234 +.*)
14.235 +(* val (ip as (_,p_), (ptp as (pt,p), tacis)) = (get_pos 1 1, get_calc 1);
14.236 + val (ip as (_,p_), (ptp as (pt,p), tacis)) = (pos, cs);
14.237 + val (ip as (_,p_), (ptp as (pt,p), tacis)) = (p, ((pt, e_pos'),[]));
14.238 + val (ip as (_,p_), (ptp as (pt,p), tacis)) = (ip,cs);
14.239 + *)
14.240 +fun step ((ip as (_,p_)):pos') ((ptp as (pt,p), tacis):calcstate) =
14.241 + let val pIopt = get_pblID (pt,ip);
14.242 + in if (*p = ([],Res) orelse*) ip = ([],Res)
14.243 + then ("end-of-calculation",(tacis, [], ptp):calcstate') else
14.244 + case tacis of
14.245 + (_::_) =>
14.246 +(* val((tac,_,_)::_) = tacis;
14.247 + *)
14.248 + if ip = p (*the request is done where ptp waits for*)
14.249 + then let val (pt',c',p') = generate tacis (pt,[],p)
14.250 + in ("ok", (tacis, c', (pt', p'))) end
14.251 + else (case (if member op = [Pbl,Met] p_
14.252 + then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip))
14.253 + handle _ => ([],[],ptp)(*e.g.by Add_Given "equality///"*)
14.254 + of cs as ([],_,_) => ("helpless", cs)
14.255 + | cs => ("ok", cs))
14.256 +(* val [] = tacis;
14.257 + *)
14.258 + | _ => (case pIopt of
14.259 + NONE => ("no-fmz-spec", ([], [], ptp))
14.260 + | SOME pI =>
14.261 +(* val SOME pI = pIopt;
14.262 + val cs=(if member op = [Pbl,Met] p_ andalso is_none(get_obj g_env pt (fst p))
14.263 + then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip))
14.264 + handle _ => ([], ptp);
14.265 + *)
14.266 + (case (if member op = [Pbl,Met] p_
14.267 + andalso is_none (get_obj g_env pt (fst p))
14.268 + (*^^^^^^^^: Apply_Method without init_form*)
14.269 + then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip) )
14.270 + handle _ => ([],[],ptp)(*e.g.by Add_Giv"equality/"*)
14.271 + of cs as ([],_,_) =>("helpless", cs)(*FIXXMEdel.handle*)
14.272 + | cs => ("ok", cs)))
14.273 + end;
14.274 +
14.275 +(* (nxt_solve_ (pt,ip)) handle e => print_exn e ;
14.276 +
14.277 + *)
14.278 +
14.279 +
14.280 +
14.281 +
14.282 +(*.does several steps within one calculation as given by "type auto";
14.283 + the steps may arbitrarily go into and leave different phases,
14.284 + i.e. specify-phase and solve-phase.*)
14.285 +(*TODO.WN0512 ? redesign after the phases have been more separated
14.286 + at the fron-end in 05:
14.287 + eg. CompleteCalcHead could be done by a separate fun !!!*)
14.288 +(* val (ip, cs as (ptp as (pt,p),tacis)) = (get_pos cI 1, get_calc cI);
14.289 + val (ip, cs as (ptp as (pt,p),tacis)) = (pold, get_calc cI);
14.290 + val (c, ip, cs as (ptp as (_,p),tacis), Step s) =
14.291 + ([]:pos' list, pold, get_calc cI, auto);
14.292 + *)
14.293 +fun autocalc c ip (cs as (ptp as (_,p),tacis)) (Step s) =
14.294 + if s <= 1
14.295 + then let val (str, (_, c', ptp)) = step ip cs;(*1*)
14.296 + (*at least does 1 step, ev.1 too much*)
14.297 + in (str, c@c', ptp) end
14.298 + else let val (str, (_, c', ptp as (_, p))) = step ip cs;
14.299 + in if str = "ok"
14.300 + then autocalc (c@c') p (ptp,[]) (Step (s-1))
14.301 + else (str, c@c', ptp) end
14.302 +(*handles autoord <= 3, autoord > 3 handled by all_/complete_solve*)
14.303 + | autocalc c (pos as (_,p_)) ((pt,_), _(*tacis would help 1x in solve*))auto=
14.304 +(* val (c:pos' list, (pos as (_,p_)),((pt,_),_),auto) =
14.305 + ([], pold, get_calc cI, auto);
14.306 + *)
14.307 + if autoord auto > 3 andalso just_created (pt, pos)
14.308 + then let val ptp = all_modspec (pt, pos);
14.309 + in all_solve auto c ptp end
14.310 + else
14.311 + if member op = [Pbl, Met] p_
14.312 + then if not (is_complete_mod (pt, pos))
14.313 + then let val ptp = complete_mod (pt, pos)
14.314 + in if autoord auto < 3 then ("ok", c, ptp)
14.315 + else
14.316 + if not (is_complete_spec ptp)
14.317 + then let val ptp = complete_spec ptp
14.318 + in if autoord auto = 3 then ("ok", c, ptp)
14.319 + else all_solve auto c ptp
14.320 + end
14.321 + else if autoord auto = 3 then ("ok", c, ptp)
14.322 + else all_solve auto c ptp
14.323 + end
14.324 + else
14.325 + if not (is_complete_spec (pt,pos))
14.326 + then let val ptp = complete_spec (pt, pos)
14.327 + in if autoord auto = 3 then ("ok", c, ptp)
14.328 + else all_solve auto c ptp
14.329 + end
14.330 + else if autoord auto = 3 then ("ok", c, (pt, pos))
14.331 + else all_solve auto c (pt, pos)
14.332 + else complete_solve auto c (pt, pos);
14.333 +(* val pbl = get_obj g_pbl (fst ptp) [];
14.334 + val (oris,_,_) = get_obj g_origin (fst ptp) [];
14.335 +*)
14.336 +
14.337 +
14.338 +
14.339 +
14.340 +
14.341 +(*.initialiye matching; before 'tryMatch' get the pblID to match with:
14.342 + if no pbl has been specified, take the init from origin.*)
14.343 +(*fun initmatch pt (pos as (p,_):pos') =
14.344 + let val PblObj {probl,origin=(os,(_,pI,_),_),spec=(dI',pI',mI'),...} =
14.345 + get_obj I pt p
14.346 + val pblID = if pI' = e_pblID
14.347 + then (*TODO.WN051125 (#init o get_pbt) pI <<<*)
14.348 + takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*)
14.349 + else pI'
14.350 + val spec = (dI',pblID,mI')
14.351 + val {ppc,where_,prls,...} = get_pbt pblID
14.352 + val (model_ok, (pbl, pre)) =
14.353 + match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os
14.354 + in ModSpec (ocalhd_complete pbl pre spec,
14.355 + Pbl, e_term, pbl, pre, spec) end;*)
14.356 +fun initcontext_pbl pt (pos as (p,_):pos') =
14.357 + let val PblObj {probl,origin=(os,(_,pI,_),hdl),spec=(dI',pI',mI'),...} =
14.358 + get_obj I pt p
14.359 + val pblID = if pI' = e_pblID
14.360 + then (*TODO.WN051125 (#init o get_pbt) pI <<<*)
14.361 + takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*)
14.362 + else pI'
14.363 + val {ppc,where_,prls,...} = get_pbt pblID
14.364 + val (model_ok, (pbl, pre)) =
14.365 + match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os
14.366 + in (model_ok, pblID, hdl, pbl, pre) end;
14.367 +
14.368 +fun initcontext_met pt (pos as (p,_):pos') =
14.369 + let val PblObj {meth,origin=(os,(_,_,mI), _),spec=(_, _, mI'),...} =
14.370 + get_obj I pt p
14.371 + val metID = if mI' = e_metID
14.372 + then (*TODO.WN051125 (#init o get_pbt) pI <<<*)
14.373 + takelast (2, mI) (*FIXME.WN051125 a hack, impl.^^^*)
14.374 + else mI'
14.375 + val {ppc,pre,prls,scr,...} = get_met metID
14.376 + val (model_ok, (pbl, pre)) =
14.377 + match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os
14.378 + in (model_ok, metID, scr, pbl, pre) end;
14.379 +
14.380 +(*.match the model of a problem at pos p
14.381 + with the model-pattern of the problem with pblID*)
14.382 +fun context_pbl pI pt (p:pos) =
14.383 + let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p
14.384 + val {ppc,where_,prls,...} = get_pbt pI
14.385 + val (model_ok, (pbl, pre)) =
14.386 + match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os
14.387 + in (model_ok, pI, hdl, pbl, pre) end;
14.388 +
14.389 +fun context_met mI pt (p:pos) =
14.390 + let val PblObj {meth,origin=(os,_,hdl),...} = get_obj I pt p
14.391 + val {ppc,pre,prls,scr,...} = get_met mI
14.392 + val (model_ok, (pbl, pre)) =
14.393 + match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os
14.394 + in (model_ok, mI, scr, pbl, pre) end
14.395 +
14.396 +
14.397 +(* val (pI, pt, pos as (p,_)) = (pblID, pt, p);
14.398 + *)
14.399 +fun tryrefine pI pt (pos as (p,_):pos') =
14.400 + let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p
14.401 + in case refine_pbl (assoc_thy "Isac.thy") pI probl of
14.402 + NONE => (*copy from context_pbl*)
14.403 + let val {ppc,where_,prls,...} = get_pbt pI
14.404 + val (_, (pbl, pre)) = match_itms_oris (assoc_thy "Isac.thy")
14.405 + probl (ppc,where_,prls) os
14.406 + in (false, pI, hdl, pbl, pre) end
14.407 + | SOME (pI, (pbl, pre)) =>
14.408 + (true, pI, hdl, pbl, pre)
14.409 + end;
14.410 +
14.411 +(* val (pt, (pos as (p,p_):pos')) = (pt, ip);
14.412 + *)
14.413 +fun detailstep pt (pos as (p,p_):pos') =
14.414 + let val nd = get_nd pt p
14.415 + val cn = children nd
14.416 + in if null cn
14.417 + then if (is_rewset o (get_obj g_tac nd)) [(*root of nd*)]
14.418 + then detailrls pt pos
14.419 + else ("no-Rewrite_Set...", EmptyPtree, e_pos')
14.420 + else ("donesteps", pt(*, get_formress [] ((lev_on o lev_dn) p) cn*),
14.421 + (p @ [length (children (get_nd pt p))], Res) )
14.422 + end;
14.423 +
14.424 +
14.425 +
14.426 +(***. for mathematics authoring on sml-toplevel; no XML .***)
14.427 +
14.428 +type NEW = int list;
14.429 +(* val sp = (dI',pI',mI');
14.430 + *)
14.431 +
14.432 +(*15.8.03 for me with loc_specify/solve, nxt_specify/solve
14.433 + delete as soon as TESTg_form -> _mout_ dropped*)
14.434 +fun TESTg_form ptp =
14.435 +(* val ptp = (pt,p);
14.436 + *)
14.437 + let val (form,_,_) = pt_extract ptp
14.438 + in case form of
14.439 + Form t => Form' (FormKF (~1,EdUndef,0,Nundef,term2str t))
14.440 + | ModSpec (_,p_, head, gfr, pre, _) =>
14.441 + Form' (PpcKF (0,EdUndef,0,Nundef,
14.442 + (case p_ of Pbl => Problem[] | Met => Method[],
14.443 + itms2itemppc (assoc_thy"Isac.thy") gfr pre)))
14.444 + end;
14.445 +
14.446 +(*.create a calc-tree; for use within sml: thus ^^^ NOT decoded to ^;
14.447 + compare "fun CalcTree" which DOES decode.*)
14.448 +fun CalcTreeTEST [(fmz, sp):fmz] =
14.449 +(* val [(fmz, sp):fmz] = [(fmz, (dI',pI',mI'))];
14.450 + val [(fmz, sp):fmz] = [([], ("e_domID", ["e_pblID"], ["e_metID"]))];
14.451 + *)
14.452 + let val cs as ((pt,p), tacis) = nxt_specify_init_calc (fmz, sp)
14.453 + val tac = case tacis of [] => Empty_Tac | _ => (#1 o hd) tacis
14.454 + val f = TESTg_form (pt,p)
14.455 + in (p, []:NEW, f, (tac2IDstr tac, tac), Sundef, pt) end;
14.456 +
14.457 +(*for tests > 15.8.03 after separation setnexttactic / nextTac:
14.458 + external view: me should be used by math-authors as done so far
14.459 + internal view: loc_specify/solve, nxt_specify/solve used
14.460 + i.e. same as in setnexttactic / nextTac*)
14.461 +(*ENDE TESTPHASE 08/10.03:
14.462 + NEW loeschen, eigene Version von locatetac, step
14.463 + meNEW, CalcTreeTEST: tac'_ -replace-> tac, remove [](cid) *)
14.464 +
14.465 +(* val ((_,tac), p, _, pt) = (nxt, p, c, pt);
14.466 + *)
14.467 +fun me ((_,tac):tac'_) (p:pos') (_:NEW(*remove*)) (pt:ptree) =
14.468 + let val (pt, p) =
14.469 +(* val (msg, (tacis, pos's, (pt',p'))) = locatetac tac (pt,p);
14.470 + p = ([1, 9], Res);
14.471 + (writeln o istate2str) (get_istate pt p);
14.472 + *)
14.473 + (*locatetac is here for testing by me; step would suffice in me*)
14.474 + case locatetac tac (pt,p) of
14.475 + ("ok", (_, _, ptp)) => ptp
14.476 + | ("unsafe-ok", (_, _, ptp)) => ptp
14.477 + | ("not-applicable",_) => (pt, p)
14.478 + | ("end-of-calculation", (_, _, ptp)) => ptp
14.479 + | ("failure",_) => raise error "sys-error";
14.480 + val (_, ts) =
14.481 +(* val (eee, (ts, _, (pt'',_))) = step p ((pt, e_pos'),[]);
14.482 + *)
14.483 + (case step p ((pt, e_pos'),[]) of
14.484 + ("ok", (ts as (tac,_,_)::_, _, _)) => ("",ts)
14.485 + | ("helpless",_) => ("helpless: cannot propose tac", [])
14.486 + | ("no-fmz-spec",_) => raise error "no-fmz-spec"
14.487 + | ("end-of-calculation", (ts, _, _)) => ("",ts))
14.488 + handle _ => raise error "sys-error";
14.489 + val tac = case ts of tacis as (_::_) =>
14.490 +(* val tacis as (_::_) = ts;
14.491 + *)
14.492 + let val (tac,_,_) = last_elem tacis
14.493 + in tac end
14.494 + | _ => if p = ([],Res) then End_Proof'
14.495 + else Empty_Tac;
14.496 + (*form output comes from locatetac*)
14.497 + in(p:pos',[]:NEW, TESTg_form (pt, p),
14.498 + (tac2IDstr tac, tac):tac'_, Sundef, pt) end;
14.499 +
14.500 +(*for quick test-print-out, until 'type inout' is removed*)
14.501 +fun f2str (Form' (FormKF (_, _, _, _, cterm'))) = cterm';
14.502 +
14.503 +
14.504 +
14.505 +(*------------------------------------------------------------------(**)
14.506 +end
14.507 +open MathEngine;
14.508 +(**)------------------------------------------------------------------*)
14.509 +
15.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2 +++ b/src/Tools/isac/Interpret/mstools.sml Wed Aug 25 16:20:07 2010 +0200
15.3 @@ -0,0 +1,969 @@
15.4 +(* Types and tools for 'modeling' und 'specifying' to be used in
15.5 + modspec.sml. The types are separated from calchead.sml into this file,
15.6 + because some of them are stored in the calc-tree, and thus are required
15.7 + _before_ ctree.sml.
15.8 + author: Walther Neuper
15.9 + (c) due to copyright terms
15.10 +
15.11 +use"ME/mstools.sml" (*re-evaluate sml/ from scratch!*);
15.12 +use"mstools.sml";
15.13 +12345678901234567890123456789012345678901234567890123456789012345678901234567890
15.14 + 10 20 30 40 50 60 70 80
15.15 +*)
15.16 +
15.17 +signature SPECIFY_TOOLS =
15.18 + sig
15.19 + type envv
15.20 + datatype
15.21 + item =
15.22 + Correct of cterm'
15.23 + | False of cterm'
15.24 + | Incompl of cterm'
15.25 + | Missing of cterm'
15.26 + | Superfl of string
15.27 + | SyntaxE of string
15.28 + | TypeE of string
15.29 + val item2str : item -> string
15.30 + type itm
15.31 + val itm2str_ : Proof.context -> itm -> string
15.32 + datatype
15.33 + itm_ =
15.34 + Cor of (term * term list) * (term * term list)
15.35 + | Inc of (term * term list) * (term * term list)
15.36 + | Mis of term * term
15.37 + | Par of cterm'
15.38 + | Sup of term * term list
15.39 + | Syn of cterm'
15.40 + | Typ of cterm'
15.41 + val itm_2str : itm_ -> string
15.42 + val itm_2str_ : Proof.context -> itm_ -> string
15.43 + val itms2str_ : Proof.context -> itm list -> string
15.44 + type 'a ppc
15.45 + val ppc2str :
15.46 + {Find: string list, With: string list, Given: string list,
15.47 + Where: string list, Relate: string list} -> string
15.48 + datatype
15.49 + match =
15.50 + Matches of pblID * item ppc
15.51 + | NoMatch of pblID * item ppc
15.52 + val match2str : match -> string
15.53 + datatype
15.54 + match_ =
15.55 + Match_ of pblID * (itm list * (bool * term) list)
15.56 + | NoMatch_
15.57 + val matchs2str : match list -> string
15.58 + type ori
15.59 + val ori2str : ori -> string
15.60 + val oris2str : ori list -> string
15.61 + type preori
15.62 + val preori2str : preori -> string
15.63 + val preoris2str : preori list -> string
15.64 + type penv
15.65 + (* val penv2str_ : Proof.context -> penv -> string *)
15.66 + type vats
15.67 + (*----------------------------------------------------------------------*)
15.68 + val all_ts_in : itm_ list -> term list
15.69 + val check_preconds :
15.70 + 'a ->
15.71 + rls ->
15.72 + term list -> itm list -> (bool * term) list
15.73 + val check_preconds' :
15.74 + rls ->
15.75 + term list ->
15.76 + itm list -> 'a -> (bool * term) list
15.77 + (* val chkpre2item : rls -> term -> bool * item *)
15.78 + val pres2str : (bool * term) list -> string
15.79 + (* val evalprecond : rls -> term -> bool * term *)
15.80 + (* val cnt : itm list -> int -> int * int *)
15.81 + val comp_dts : theory -> term * term list -> term
15.82 + val comp_dts' : term * term list -> term
15.83 + val comp_dts'' : term * term list -> string
15.84 + val comp_ts : term * term list -> term
15.85 + val d_in : itm_ -> term
15.86 + val de_item : item -> cterm'
15.87 + val dest_list : term * term list -> term list (* for testing *)
15.88 + val dest_list' : term -> term list
15.89 + val dts2str : term * term list -> string
15.90 + val e_itm : itm
15.91 + (* val e_listBool : term *)
15.92 + (* val e_listReal : term *)
15.93 + val e_ori : ori
15.94 + val e_ori_ : ori
15.95 + val empty_ppc : item ppc
15.96 + (* val empty_ppc_ct' : cterm' ppc *)
15.97 + (* val getval : term * term list -> term * term *)
15.98 + (*val head_precond :
15.99 + domID * pblID * 'a ->
15.100 + term option ->
15.101 + rls ->
15.102 + term list ->
15.103 + itm list -> 'b -> term * (bool * term) list*)
15.104 + (* val init_item : string -> item *)
15.105 + (* val is_matches : match -> bool *)
15.106 + (* val is_matches_ : match_ -> bool *)
15.107 + val is_var : term -> bool
15.108 + (* val item_ppc :
15.109 + string ppc -> item ppc *)
15.110 + val itemppc2str : item ppc -> string
15.111 + (* val matches_pblID : match -> pblID *)
15.112 + val max2 : ('a * int) list -> 'a * int
15.113 + val max_vt : itm list -> int
15.114 + val mk_e : itm_ -> (term * term) list
15.115 + val mk_en : int -> itm -> (term * term) list
15.116 + val mk_env : itm list -> (term * term) list
15.117 + val mkval : 'a -> term list -> term
15.118 + val mkval' : term list -> term
15.119 + (* val pblID_of_match : match -> pblID *)
15.120 + val pbl_ids : Proof.context -> term -> term -> term list
15.121 + val pbl_ids' : 'a -> term -> term list -> term list
15.122 + (* val pen2str : theory -> term * term list -> string *)
15.123 + val penvval_in : itm_ -> term list
15.124 + val refined : match list -> pblID
15.125 + val refined_ :
15.126 + match_ list -> match_ option
15.127 + (* val refined_IDitms :
15.128 + match list -> match option *)
15.129 + val split_dts : 'a -> term -> term * term list
15.130 + val split_dts' : term * term -> term list
15.131 + (* val take_apart : term -> term list *)
15.132 + (* val take_apart_inv : term list -> term *)
15.133 + val ts_in : itm_ -> term list
15.134 + (* val unique : term *)
15.135 + val untouched : itm list -> bool
15.136 + val upd :
15.137 + Proof.context ->
15.138 + (''a * (''b * term list) list) list ->
15.139 + term ->
15.140 + ''b * term -> ''a -> ''a * (''b * term list) list
15.141 + val upd_envv :
15.142 + Proof.context ->
15.143 + envv ->
15.144 + vats ->
15.145 + term -> term -> term -> envv
15.146 + val upd_penv :
15.147 + Proof.context ->
15.148 + (''a * term list) list ->
15.149 + term -> ''a * term -> (''a * term list) list
15.150 + (* val upds_envv :
15.151 + Proof.context ->
15.152 + envv ->
15.153 + (vats * term * term * term) list ->
15.154 + envv *)
15.155 + val vts_cnt : int list -> itm list -> (int * int) list
15.156 + val vts_in : itm list -> int list
15.157 + (* val w_itms2str_ : Proof.context -> itm list -> unit *)
15.158 + end
15.159 +
15.160 +(*----------------------------------------------------------*)
15.161 +structure SpecifyTools : SPECIFY_TOOLS =
15.162 +struct
15.163 +(*----------------------------------------------------------*)
15.164 +val e_listReal = (term_of o the o (parse (theory "Script"))) "[]::(real list)";
15.165 +val e_listBool = (term_of o the o (parse (theory "Script"))) "[]::(bool list)";
15.166 +
15.167 +(*.take list-term apart w.r.t. handling elementwise input.*)
15.168 +fun take_apart t =
15.169 + let val elems = isalist2list t
15.170 + in map ((list2isalist (type_of (hd elems))) o single) elems end;
15.171 +(*val t = str2term "[a, b]";
15.172 +> val ts = take_apart t; writeln (terms2str ts);
15.173 +["[a]","[b]"]
15.174 +
15.175 +> t = (take_apart_inv o take_apart) t;
15.176 +true*)
15.177 +fun take_apart_inv ts =
15.178 + let val elems = (flat o (map isalist2list)) ts;
15.179 + in list2isalist (type_of (hd elems)) elems end;
15.180 +(*val ts = [str2term "[a]", str2term "[b]"];
15.181 +> val t = take_apart_inv ts; term2str t;
15.182 +"[a, b]"
15.183 +
15.184 +ts = (take_apart o take_apart_inv) ts;
15.185 +true*)
15.186 +
15.187 +
15.188 +
15.189 +
15.190 +(*.revert split_dts only for ts; compare comp_dts.*)
15.191 +fun comp_ts (d, ts) =
15.192 + if is_list_dsc d
15.193 + then if is_list (hd ts)
15.194 + then if is_unl d
15.195 + then (hd ts) (*e.g. someList [1,3,2]*)
15.196 + else (take_apart_inv ts)
15.197 + (* SML[ [a], [b] ]SML --> [a,b] *)
15.198 + else (hd ts) (*a variable or metavariable for a list*)
15.199 + else (hd ts);
15.200 +(*.revert split_.
15.201 + WN050903 we do NOT know which is from subtheory, description or term;
15.202 + typecheck thus may lead to TYPE-error 'unknown constant';
15.203 + solution: typecheck with Isac.thy; i.e. arg 'thy' superfluous*)
15.204 +(*fun comp_dts thy (d,[]) =
15.205 + cterm_of (*(sign_of o assoc_thy) "Isac.thy"*)
15.206 + (theory "Isac")
15.207 + (*comp_dts:FIXXME stay with term for efficiency !!!*)
15.208 + (if is_reall_dsc d then (d $ e_listReal)
15.209 + else if is_booll_dsc d then (d $ e_listBool)
15.210 + else d)
15.211 + | comp_dts thy (d,ts) =
15.212 + (cterm_of (*(sign_of o assoc_thy) "Isac.thy"*)
15.213 + (theory "Isac")
15.214 + (*comp_dts:FIXXME stay with term for efficiency !!*)
15.215 + (d $ (comp_ts (d, ts)))
15.216 + handle _ => raise error ("comp_dts: "^(term2str d)^
15.217 + " $ "^(term2str (hd ts))));*)
15.218 +fun comp_dts thy (d,[]) =
15.219 + (if is_reall_dsc d then (d $ e_listReal)
15.220 + else if is_booll_dsc d then (d $ e_listBool)
15.221 + else d)
15.222 + | comp_dts thy (d,ts) =
15.223 + (d $ (comp_ts (d, ts)))
15.224 + handle _ => raise error ("comp_dts: "^(term2str d)^
15.225 + " $ "^(term2str (hd ts)));
15.226 +(*25.8.03*)
15.227 +fun comp_dts' (d,[]) =
15.228 + if is_reall_dsc d then (d $ e_listReal)
15.229 + else if is_booll_dsc d then (d $ e_listBool)
15.230 + else d
15.231 + | comp_dts' (d,ts) = (d $ (comp_ts (d, ts)))
15.232 + handle _ => raise error ("comp_dts': "^(term2str d)^
15.233 + " $ "^(term2str (hd ts)));
15.234 +(*val t = str2term "maximum A";
15.235 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.236 +val it = "maximum A" : cterm
15.237 +> val t = str2term "fixedValues [r=Arbfix]";
15.238 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.239 +"fixedValues [r = Arbfix]"
15.240 +> val t = str2term "valuesFor [a]";
15.241 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.242 +"valuesFor [a]"
15.243 +> val t = str2term "valuesFor [a,b]";
15.244 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.245 +"valuesFor [a, b]"
15.246 +> val t = str2term "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]";
15.247 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.248 +relations [A = a * b, (a / 2) ^^^ 2 + (b / 2) ^^^ 2 = r ^^^ 2]"
15.249 +> val t = str2term "boundVariable a";
15.250 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.251 +"boundVariable a"
15.252 +> val t = str2term "interval {x::real. 0 <= x & x <= 2*r}";
15.253 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.254 +"interval {x. 0 <= x & x <= 2 * r}"
15.255 +
15.256 +> val t = str2term "equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))";
15.257 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.258 +"equality (sqrt (9 + 4 * x) = sqrt x + sqrt (5 + x))"
15.259 +> val t = str2term "solveFor x";
15.260 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.261 +"solveFor x"
15.262 +> val t = str2term "errorBound (eps=0)";
15.263 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.264 +"errorBound (eps = 0)"
15.265 +> val t = str2term "solutions L";
15.266 +> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
15.267 +"solutions L"
15.268 +
15.269 +before 6.5.03:
15.270 +> val t = (term_of o the o (parse thy)) "testdscforlist [#1]";
15.271 +> val (d,ts) = split_dts t;
15.272 +> comp_dts thy (d,ts);
15.273 +val it = "testdscforlist [#1]" : cterm
15.274 +
15.275 +> val t = (term_of o the o (parse thy)) "(A::real)";
15.276 +> val (d,ts) = split_dts t;
15.277 +val d = Const ("empty","empty") : term
15.278 +val ts = [Free ("A","RealDef.real")] : term list
15.279 +> val t = (term_of o the o (parse thy)) "[R=(R::real)]";
15.280 +> val (d,ts) = split_dts t;
15.281 +val d = Const ("empty","empty") : term
15.282 +val ts = [Const # $ Free # $ Free (#,#)] : term list
15.283 +> val t = (term_of o the o (parse thy)) "[#1,#2]";
15.284 +> val (d,ts) = split_dts t;
15.285 +val ts = [Free ("#1","'a"),Free ("#2","'a")] : NOT WANTED
15.286 +*)
15.287 +
15.288 +(*for input_icalhd 11.03*)
15.289 +fun comp_dts'' (d,[]) =
15.290 + if is_reall_dsc d then term2str (d $ e_listReal)
15.291 + else if is_booll_dsc d then term2str (d $ e_listBool)
15.292 + else term2str d
15.293 + | comp_dts'' (d,ts) = term2str (d $ (comp_ts (d, ts)))
15.294 + handle _ => raise error ("comp_dts'': "^(term2str d)^
15.295 + " $ "^(term2str (hd ts)));
15.296 +
15.297 +
15.298 +
15.299 +
15.300 +
15.301 +
15.302 +(* this may decompose an object-language isa-list;
15.303 + use only, if description is not available, eg. not input ?WN:14.5.03 ??!?*)
15.304 +fun dest_list' t = if is_list t then isalist2list t else [t];
15.305 +
15.306 +(*fun is_metavar (Free (str, _)) =
15.307 + if (last_elem o explode) str = "_" then true else false
15.308 + | is_metavar _ = false;*)
15.309 +fun is_var (Free _) = true
15.310 + | is_var _ = false;
15.311 +
15.312 +(*.special handling for lists. ?WN:14.5.03 ??!?*)
15.313 +fun dest_list (d,ts) =
15.314 + let fun dest t =
15.315 + if is_list_dsc d andalso not (is_unl d)
15.316 + andalso not (is_var t) (*..for pbt*)
15.317 + then isalist2list t else [t]
15.318 + in (flat o (map dest)) ts end;
15.319 +
15.320 +
15.321 +(*.decompose an input into description, terms (ev. elems of lists),
15.322 + and the value for the problem-environment; inv to comp_dts .*)
15.323 +(*WN.8.6.03: corrected with minimal effort,
15.324 +fn : theory -> term ->
15.325 + term * description
15.326 + term list * lists decomposed for elementwise input
15.327 + term list pbl_ids not _HERE_: dont know which list-elems input*)
15.328 +fun split_dts thy (t as d $ arg) =
15.329 + if is_dsc d
15.330 + then if is_list_dsc d
15.331 + then if is_list arg
15.332 + then if is_unl d
15.333 + then (d, [arg]) (*e.g. someList [1,3,2]*)
15.334 + else (d, take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*)
15.335 + else (d, [arg]) (*a variable or metavariable for a list*)
15.336 + else (d, [arg])
15.337 + else (e_term, dest_list' t(*9.01 ???*))
15.338 + | split_dts thy t = (*either dsc or term*)
15.339 + let val (h,argl) = strip_comb t
15.340 + in if (not o is_dsc) h then (e_term, dest_list' t)
15.341 + else (h, dest_list (h,argl))
15.342 + end;
15.343 +(* tests see fun comp_dts
15.344 +
15.345 +> val t = str2term "someList []";
15.346 +> val (_,ts) = split_dts thy t; writeln (terms2str ts);
15.347 +["[]"]
15.348 +> val t = str2term "valuesFor []";
15.349 +> val (_,ts) = split_dts thy t; writeln (terms2str ts);
15.350 +["[]"]*)
15.351 +
15.352 +(*.version returning ts only.*)
15.353 +fun split_dts' (d, arg) =
15.354 + if is_dsc d
15.355 + then if is_list_dsc d
15.356 + then if is_list arg
15.357 + then if is_unl d
15.358 + then ([arg]) (*e.g. someList [1,3,2]*)
15.359 + else (take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*)
15.360 + else ([arg]) (*a variable or metavariable for a list*)
15.361 + else ([arg])
15.362 + else (dest_list' arg(*9.01 ???*))
15.363 + | split_dts' (d, t) = (*either dsc or term; 14.5.03 only copied*)
15.364 + let val (h,argl) = strip_comb t
15.365 + in if (not o is_dsc) h then (dest_list' t)
15.366 + else (dest_list (h,argl))
15.367 + end;
15.368 +
15.369 +
15.370 +
15.371 +
15.372 +
15.373 +(*27.8.01: problem-environment
15.374 +WN.6.5.03: FIXXME reconsider if penv is worth the effort --
15.375 + -- just rerun a whole expl with num/var may show the same ?!
15.376 +WN.9.5.03: penv-concept stalled, immediately generate script env !
15.377 + but [#0, epsilon] only outcommented for eventual reconsideration
15.378 +*)
15.379 +type penv = (term (*err_*)
15.380 + * (term list) (*[#0, epsilon] 9.5.03 outcommented*)
15.381 + ) list;
15.382 +fun pen2str ctxt (t, ts) =
15.383 + pair2str(Syntax.string_of_term ctxt t,
15.384 + (strs2str' o map (Syntax.string_of_term ctxt)) ts);
15.385 +fun penv2str_ thy (penv:penv) = (strs2str' o (map (pen2str thy))) penv;
15.386 +
15.387 +(*
15.388 + 9.5.03: still unused, but left for eventual future development*)
15.389 +type envv = (int * penv) list; (*over variants*)
15.390 +
15.391 +(*. 14.9.01: not used after putting penv-values into itm_
15.392 + make the result of split_* a value of problem-environment .*)
15.393 +fun mkval dsc [] = raise error "mkval called with []"
15.394 + | mkval dsc [t] = t
15.395 + | mkval dsc ts = list2isalist ((type_of o hd) ts) ts;
15.396 +(*WN.12.12.03*)
15.397 +fun mkval' x = mkval e_term x;
15.398 +
15.399 +
15.400 +
15.401 +(*. get the constant value from a penv .*)
15.402 +fun getval (id, values) =
15.403 + case values of
15.404 + [] => raise error ("penv_value: no values in '"^
15.405 + (Syntax.string_of_term (thy2ctxt' "Tools") id))
15.406 + | [v] => (id, v)
15.407 + | (v1::v2::_) => (case v1 of
15.408 + Const ("Script.Arbfix",_) => (id, v2)
15.409 + | _ => (id, v1));
15.410 +(*
15.411 + val e_ = (term_of o the o (parse thy)) "e_::bool";
15.412 + val ev = (term_of o the o (parse thy)) "#4 + #3 * x^^^#2 = #0";
15.413 + val v_ = (term_of o the o (parse thy)) "v_";
15.414 + val vv = (term_of o the o (parse thy)) "x";
15.415 + val r_ = (term_of o the o (parse thy)) "err_::bool";
15.416 + val rv1 = (term_of o the o (parse thy)) "#0";
15.417 + val rv2 = (term_of o the o (parse thy)) "eps";
15.418 +
15.419 + val penv = [(e_,[ev]),(v_,[vv]),(r_,[rv2,rv2])]:penv;
15.420 + map getval penv;
15.421 +[(Free ("e_","bool"),
15.422 + Const (#,#) $ (# $ # $ (# $ #)) $ Free ("#0","RealDef.real")),
15.423 + (Free ("v_","RealDef.real"),Free ("x","RealDef.real")),
15.424 + (Free ("err_","bool"),Free ("#0","RealDef.real"))] : (term * term) list
15.425 +*)
15.426 +
15.427 +
15.428 +(*23.3.02 TODO: ideas on redesign of type itm_,type item,type ori,type item ppc
15.429 +(1) kinds of itms:
15.430 + (1.1) untouched: for modeling only dsc displayed(impossible after match_itms)
15.431 + =(presently) Mis (? should be Inc initially, and Mis after match_itms?)
15.432 + (1.2) Syn,Typ,Sup: not related to oris
15.433 + Syn, Typ (presently) should be accepted in appl_add (instead Error')
15.434 + Sup (presently) should be accepted in appl_add (instead Error')
15.435 + _could_ be w.r.t current vat (and then _is_ related to vat
15.436 + Mis should _not_ be made Inc ((presently, by appl_add & match_itms)
15.437 +- dsc in itm_ is timeconsuming -- keep id for respective queries ?
15.438 +- order of items in ppc should be stable w.r.t order of itms
15.439 +
15.440 +- stepwise input of itms --- match_itms (in one go) ..not coordinated
15.441 + - unify code
15.442 + - match_itms / match_itms_oris ..2 versions ?!
15.443 + (fast, for refine / slow, for modeling)
15.444 +
15.445 +- clarify: efficiency <--> simplicity !!!
15.446 + ?: shift dsc itm_ -> itm | discard int in ori,itm | take int instead dsc
15.447 + | take int for perserving order of item ppc in itms
15.448 + | make all(!?) handling of itms stable against reordering(?)
15.449 + | field in ori ?? (not from fmz!) -- meant for efficiency (not doc!???)
15.450 + -"- "#undef" ?= not touched ?= (id,..)
15.451 +-----------------------------------------------------------------
15.452 +27.3.02:
15.453 +def: type pbt = (field, (dsc, pid))
15.454 +
15.455 +(1) fmz + pbt -> oris
15.456 +(2) input + oris -> itm
15.457 +(3) match_itms : schnell(?) f"ur refine
15.458 + match_itms_oris : r"uckmeldung f"ur item ppc
15.459 +
15.460 +(1.1) in oris fehlt daher pid: (i,v,f,d,ts,pid)
15.461 +---------- ^^^^^ --- dh. pbt meist als argument zu viel !!!
15.462 +
15.463 +(3.1) abwarten, wie das matchen mehr unterschiedlicher pbt's sich macht;
15.464 + wenn Problem pbt v"ollig neue, dann w"are eigentlich n"otig ????:
15.465 + (a) (_,_,d1,ts,_):ori + pbt -> (i,vt,d2,ts,pid) dh.vt neu ????
15.466 + (b)
15.467 +*)
15.468 +
15.469 +
15.470 +
15.471 +
15.472 +(*the internal representation of a models' item
15.473 +
15.474 + 4.9.01: not consistent:
15.475 + after Init_Proof 'Inc', but after copy_probl 'Mis' - for same situation
15.476 + (involves 'is_error');
15.477 + bool in itm really necessary ???*)
15.478 +datatype itm_ =
15.479 + Cor of (term * (* description *)
15.480 + (term list)) * (* for list: elem-wise input *)
15.481 + (*split_dts <-> comp_dts*)
15.482 + (term * (term list)) (* elem of penv *)
15.483 + (*9.5.03: ---- is already for script -- penv delayed to future*)
15.484 + | Syn of cterm'
15.485 + | Typ of cterm'
15.486 + | Inc of (term * (term list)) * (term * (term list)) (*lists,
15.487 + + init_pbl WN.11.03 FIXXME: empty penv .. bad
15.488 + init_pbl should return Mis !!!*)
15.489 + | Sup of (term * (term list)) (* user-input not found in pbt(+?oris?11.03)*)
15.490 + | Mis of (term * term) (* after re-specification pbt-item not found
15.491 + in pbl: only dsc, pid_*)
15.492 + | Par of cterm'; (*internal state from fun parsitm*)
15.493 +
15.494 +type vats = int list; (*variants in formalizations*)
15.495 +
15.496 +(*.data-type for working on pbl/met-ppc:
15.497 + in pbl initially holds descriptions (only) for user guidance.*)
15.498 +type itm =
15.499 + int * (* id =0 .. untouched - descript (only) from init
15.500 + 23.3.02: seems to correspond to ori (fun insert_ppc)
15.501 + <> maintain order in item ppc?*)
15.502 + vats * (* variants - copy from ori *)
15.503 + bool * (* input on this item is not/complete *)
15.504 + string * (* #Given | #Find | #Relate *)
15.505 + itm_; (* *)
15.506 +(* use"ME/sequent.sml";
15.507 + *)
15.508 +val e_itm = (0,[],false,"e_itm",Syn"e_itm"):itm;
15.509 +(*in CalcTree/Subproblem an 'untouched' model is created
15.510 + FIXME.WN.9.03 model should be filled to 'untouched' by Model/Refine_Problem*)
15.511 +fun untouched (itms: itm list) =
15.512 + foldl and_ (true ,map ((curry op= 0) o #1) itms);
15.513 +(*> untouched [];
15.514 +val it = true : bool
15.515 +> untouched [e_itm];
15.516 +val it = true : bool
15.517 +> untouched [e_itm, (1,[],false,"e_itm",Syn "e_itm")];
15.518 +val it = false : bool*)
15.519 +
15.520 +
15.521 +
15.522 +
15.523 +
15.524 +(* find most frequent variant v in itms *)
15.525 +
15.526 +fun vts_in itms = (distinct o flat o (map #2)) (itms:itm list);
15.527 +
15.528 +fun cnt itms v = (v,(length o (filter (curry op= v)) o
15.529 + flat o (map #2)) (itms:itm list));
15.530 +fun vts_cnt vts itms = map (cnt itms) vts;
15.531 +fun max2 [] = raise error "max2 of []"
15.532 + | max2 (y::ys) =
15.533 + let fun mx (a,x) [] = (a,x)
15.534 + | mx (a,x) ((b,y)::ys) =
15.535 + if x < y then mx (b,y) ys else mx (a,x) ys;
15.536 +in mx y ys end;
15.537 +
15.538 +(*. find the variant with most items already input .*)
15.539 +fun max_vt itms =
15.540 + let val vts = (vts_cnt (vts_in itms)) itms;
15.541 + in if vts = [] then 0 else (fst o max2) vts end;
15.542 +
15.543 +
15.544 +(* TODO ev. make more efficient by avoiding flat *)
15.545 +fun mk_e (Cor (_, iv)) = [getval iv]
15.546 + | mk_e (Syn _) = []
15.547 + | mk_e (Typ _) = []
15.548 + | mk_e (Inc (_, iv)) = [getval iv]
15.549 + | mk_e (Sup _) = []
15.550 + | mk_e (Mis _) = [];
15.551 +fun mk_en vt ((i,vts,b,f,itm_):itm) =
15.552 + if member op = vts vt then mk_e itm_ else [];
15.553 +(*. extract the environment from an item list;
15.554 + takes the variant with most items .*)
15.555 +fun mk_env itms =
15.556 + let val vt = max_vt itms
15.557 + in (flat o (map (mk_en vt))) itms end;
15.558 +
15.559 +
15.560 +
15.561 +(*. example as provided by an author, complete w.r.t. pbt specified
15.562 + not touched by any user action .*)
15.563 +type ori = (int * (* id: 10.3.00ff impl. only <>0 .. touched
15.564 + 21.3.02: insert_ppc needs it ! ?:purpose maintain
15.565 + order in item ppc ???*)
15.566 + vats * (* variants 21.3.02: related to pbt..discard ?*)
15.567 + string * (* #Given | #Find | #Relate 21.3.02: discard ?*)
15.568 + term * (* description *)
15.569 + term list (* isalist2list t | [t] *)
15.570 + );
15.571 +val e_ori_ = (0,[],"",e_term,[e_term]):ori;
15.572 +val e_ori = (0,[],"",e_term,[e_term]):ori;
15.573 +
15.574 +fun ori2str ((i,vs,fi,t,ts):ori) =
15.575 + "("^(string_of_int i)^", "^((strs2str o (map string_of_int)) vs)^", "^fi^","^
15.576 + (term2str t)^", "^((strs2str o (map term2str)) ts)^")";
15.577 +val oris2str =
15.578 + let val s = !show_types
15.579 + val _ = show_types:= true
15.580 + val str = (strs2str' o (map (linefeed o ori2str)))
15.581 + val _ = show_types:= s
15.582 + in str end;
15.583 +
15.584 +(*.an or without leading integer.*)
15.585 +type preori = (vats *
15.586 + string *
15.587 + term *
15.588 + term list);
15.589 +fun preori2str ((vs,fi,t,ts):preori) =
15.590 + "("^((strs2str o (map string_of_int)) vs)^", "^fi^", "^
15.591 + (term2str t)^", "^((strs2str o (map term2str)) ts)^")";
15.592 +val preoris2str = (strs2str' o (map (linefeed o preori2str)));
15.593 +
15.594 +(*. given the input value (from split_dts)
15.595 + make the value in a problem-env according to description-type .*)
15.596 +(*28.8.01: .nam and .una impl. properly, others copied .. TODO*)
15.597 +fun pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) v =
15.598 + if is_list v
15.599 + then [v] (*eg. [r=Arbfix]*)
15.600 + else (case v of (*eg. eps=#0*)
15.601 + (Const ("op =",_) $ l $ r) => [r,l]
15.602 + | _ => raise error ("pbl_ids Tools.nam: no equality "
15.603 + ^(Syntax.string_of_term ctxt v)))
15.604 + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.una",_)]))) v = [v]
15.605 + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) v = [v]
15.606 + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.str",_)]))) v = [v]
15.607 + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) v = [v]
15.608 + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))v = [v]
15.609 + | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))v = [v]
15.610 + | pbl_ids ctxt _ v = raise error ("pbl_ids: not implemented for "
15.611 + ^(Syntax.string_of_term ctxt v));
15.612 +(*
15.613 +val t as t1 $ t2 = str2term "antiDerivativeName M_b";
15.614 +pbl_ids ctxt t1 t2;
15.615 +
15.616 + val t = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
15.617 + val (d,argl) = strip_comb t;
15.618 + is_dsc d; (*see split_dts*)
15.619 + dest_list (d,argl);
15.620 + val (_ $ v) = t;
15.621 + is_list v;
15.622 + pbl_ids ctxt d v;
15.623 +[Const ("List.list.Cons","[bool, bool List.list] => bool List.list") $
15.624 + (Const # $ Free # $ Const (#,#)) $ Const ("List.list.Nil","bool List..
15.625 +
15.626 + val (dsc,vl) = (split_dts o term_of o the o (parse thy)) "solveFor x";
15.627 +val dsc = Const ("Descript.solveFor","RealDef.real => Tools.una") : term
15.628 +val vl = Free ("x","RealDef.real") : term
15.629 +
15.630 + val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_";
15.631 + pbl_ids ctxt dsc vl;
15.632 +val it = [Free ("x","RealDef.real")] : term list
15.633 +
15.634 + val (dsc,vl) = (split_dts o term_of o the o(parse thy))
15.635 + "errorBound (eps=#0)";
15.636 + val (dsc,id) = (split_did o term_of o the o(parse thy)) "errorBound err_";
15.637 + pbl_ids ctxt dsc vl;
15.638 +val it = [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")] : term list *)
15.639 +
15.640 +(*. given an already input itm, ((14.9.01: no difference to pbl_ids jet!!))
15.641 + make the value in a problem-env according to description-type .*)
15.642 +(*28.8.01: .nam and .una impl. properly, others copied .. TODO*)
15.643 +fun pbl_ids' (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) vs =
15.644 + (case vs of
15.645 + [] => raise error ("pbl_ids' Tools.nam called with []")
15.646 + | [t] => (case t of (*eg. eps=#0*)
15.647 + (Const ("op =",_) $ l $ r) => [r,l]
15.648 + | _ => raise error ("pbl_ids' Tools.nam: no equality "
15.649 + ^(Syntax.string_of_term (thy2ctxt' "Isac")t)))
15.650 + | vs' => vs (*14.9.01: ???TODO *))
15.651 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.una",_)]))) vs = vs
15.652 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) vs = vs
15.653 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.str",_)]))) vs = vs
15.654 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) vs = vs
15.655 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))vs = vs
15.656 + | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))vs = vs
15.657 + | pbl_ids' _ vs =
15.658 + raise error ("pbl_ids': not implemented for "
15.659 + ^(terms2str vs));
15.660 +(*9.5.03 penv postponed: pbl_ids'*)
15.661 +fun pbl_ids' thy d vs = [comp_ts (d, vs)];
15.662 +
15.663 +
15.664 +(*14.9.01: not used after putting values for penv into itm_
15.665 + WN.5.5.03: used in upd .. upd_envv*)
15.666 +fun upd_penv ctxt penv dsc (id, vl) =
15.667 +(writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!";
15.668 + writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!";
15.669 + writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!";
15.670 + overwrite (penv, (id, pbl_ids ctxt dsc vl))
15.671 +);
15.672 +(*
15.673 + val penv = [];
15.674 + val (dsc,vl) = (split_did o term_of o the o (parse thy)) "solveFor x";
15.675 + val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_";
15.676 + val penv = upd_penv thy penv dsc (id, vl);
15.677 +[(Free ("v_","RealDef.real"),
15.678 + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")])]
15.679 +: (term * term list) list
15.680 +
15.681 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"errorBound (eps=#0)";
15.682 + val (dsc,id) = (split_did o term_of o the o(parse thy))"errorBound err_";
15.683 + upd_penv thy penv dsc (id, vl);
15.684 +[(Free ("v_","RealDef.real"),
15.685 + [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")]),
15.686 + (Free ("err_","bool"),
15.687 + [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")])]
15.688 +: (term * term list) list ^.........!!!!
15.689 +*)
15.690 +
15.691 +(*WN.9.5.03: not reconsidered; looks strange !!!*)
15.692 +fun upd thy envv dsc (id, vl) i =
15.693 + let val penv = case assoc (envv, i) of
15.694 + SOME e => e
15.695 + | NONE => [];
15.696 + val penv' = upd_penv thy penv dsc (id, vl);
15.697 + in (i, penv') end;
15.698 +(*
15.699 + val i = 2;
15.700 + val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv;
15.701 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b";
15.702 + val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_";
15.703 + upd thy envv dsc (id, vl) i;
15.704 +val it = (2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])
15.705 + : int * (term * term list) list*)
15.706 +
15.707 +
15.708 +(*14.9.01: not used after putting pre-penv into itm_*)
15.709 +fun upd_envv thy (envv:envv) (vats:vats) dsc id vl =
15.710 + let val vats = if length vats = 0
15.711 + then (*unknown id to _all_ variants*)
15.712 + if length envv = 0 then [1]
15.713 + else (intsto o length) envv
15.714 + else vats
15.715 + fun isin vats (i,_) = member op = vats i;
15.716 + val envs_notin_vat = filter_out (isin vats) envv;
15.717 + in ((map (upd thy envv dsc (id, vl)) vats) @ envs_notin_vat):envv end;
15.718 +(*
15.719 + val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv;
15.720 +
15.721 + val vats = [2]
15.722 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b";
15.723 + val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_";
15.724 + val envv = upd_envv thy envv vats dsc id vl;
15.725 +val envv = [(2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])]
15.726 + : (int * (term * term list) list) list
15.727 +
15.728 + val vats = [1,2,3];
15.729 + val (dsc,vl) = (split_did o term_of o the o(parse thy))"maximum A";
15.730 + val (dsc,id) = (split_did o term_of o the o(parse thy))"maximum m_";
15.731 + upd_envv thy envv vats dsc id vl;
15.732 +[(1,[(Free ("m_","bool"),[Free ("A","bool")])]),
15.733 + (2,
15.734 + [(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")]),
15.735 + (Free ("m_","bool"),[Free ("A","bool")])]),
15.736 + (3,[(Free ("m_","bool"),[Free ("A","bool")])])]
15.737 +: (int * (term * term list) list) list
15.738 +
15.739 +
15.740 + val env = []:envv;
15.741 + val (d,ts) = (split_dts o term_of o the o (parse thy))
15.742 + "fixedValues [r=Arbfix]";
15.743 + val (_,id) = (split_did o term_of o the o (parse thy))"fixedValues fix_";
15.744 + val vats = [1,2,3];
15.745 + val env = upd_envv thy env vats d id (mkval ts);
15.746 +*)
15.747 +
15.748 +(*. update envv by folding from a list of arguments .*)
15.749 +fun upds_envv thy envv [] = envv
15.750 + | upds_envv thy envv ((vs, dsc, id, vl)::ps) =
15.751 + upds_envv thy (upd_envv thy envv vs dsc id vl) ps;
15.752 +(* eval test-maximum.sml until Specify_Method ...
15.753 + val PblObj{probl=(_,pbl),origin=(_,(_,_,mI),_),...} = get_obj I pt [];
15.754 + val met = (#ppc o get_met) mI;
15.755 +
15.756 + val envv = [];
15.757 + val eargs = flat eargs;
15.758 + val (vs, dsc, id, vl) = hd eargs;
15.759 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
15.760 +
15.761 + val (vs, dsc, id, vl) = hd (tl eargs);
15.762 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
15.763 +
15.764 + val (vs, dsc, id, vl) = hd (tl (tl eargs));
15.765 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
15.766 +
15.767 + val (vs, dsc, id, vl) = hd (tl (tl (tl eargs)));
15.768 + val envv = upds_envv thy envv [(vs, dsc, id, vl)];
15.769 +[(1,
15.770 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
15.771 + (Free ("m_","bool"),[Free (#,#)]),
15.772 + (Free ("vs_","bool List.list"),[# $ # $ Const #]),
15.773 + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
15.774 + (2,
15.775 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
15.776 + (Free ("m_","bool"),[Free (#,#)]),
15.777 + (Free ("vs_","bool List.list"),[# $ # $ Const #]),
15.778 + (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
15.779 + (3,
15.780 + [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
15.781 + (Free ("m_","bool"),[Free (#,#)]),
15.782 + (Free ("vs_","bool List.list"),[# $ # $ Const #])])] : envv *)
15.783 +
15.784 +(*for _output_ of the items of a Model*)
15.785 +datatype item =
15.786 + Correct of cterm' (*labels a correct formula (type cterm')*)
15.787 + | SyntaxE of string (**)
15.788 + | TypeE of string (**)
15.789 + | False of cterm' (*WN050618 notexistent in itm_: only used in Where*)
15.790 + | Incompl of cterm' (**)
15.791 + | Superfl of string (**)
15.792 + | Missing of cterm';
15.793 +fun item2str (Correct s) ="Correct " ^ s
15.794 + | item2str (SyntaxE s) ="SyntaxE " ^ s
15.795 + | item2str (TypeE s) ="TypeE " ^ s
15.796 + | item2str (False s) ="False " ^ s
15.797 + | item2str (Incompl s) ="Incompl " ^ s
15.798 + | item2str (Superfl s) ="Superfl " ^ s
15.799 + | item2str (Missing s) ="Missing " ^ s;
15.800 +(*make string for error-msgs*)
15.801 +fun itm_2str_ ctxt (Cor ((d,ts), penv)) =
15.802 + "Cor " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ,"
15.803 + ^ pen2str ctxt penv
15.804 + | itm_2str_ ctxt (Syn c) = "Syn " ^ c
15.805 + | itm_2str_ ctxt (Typ c) = "Typ " ^ c
15.806 + | itm_2str_ ctxt (Inc ((d,ts), penv)) =
15.807 + "Inc " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ,"
15.808 + ^ pen2str ctxt penv
15.809 + | itm_2str_ ctxt (Sup (d,ts)) =
15.810 + "Sup " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts))
15.811 + | itm_2str_ ctxt (Mis (d,pid))=
15.812 + "Mis "^ Syntax.string_of_term ctxt d ^
15.813 + " "^ Syntax.string_of_term ctxt pid
15.814 + | itm_2str_ ctxt (Par s) = "Trm "^s;
15.815 +fun itm_2str t = itm_2str_ (thy2ctxt' "Isac") t;
15.816 +fun itm2str_ ctxt ((i,is,b,s,itm_):itm) =
15.817 + "("^(string_of_int i)^" ,"^(ints2str' is)^" ,"^(bool2str b)^" ,"^
15.818 + s^" ,"^(itm_2str_ ctxt itm_)^")";
15.819 +fun itms2str_ ctxt itms = strs2str' (map (linefeed o (itm2str_ ctxt)) itms);
15.820 +fun w_itms2str_ ctxt itms = writeln (itms2str_ ctxt itms);
15.821 +
15.822 +fun init_item str = SyntaxE str;
15.823 +
15.824 +
15.825 +
15.826 +
15.827 +type 'a ppc =
15.828 + {Given : 'a list,
15.829 + Where: 'a list,
15.830 + Find : 'a list,
15.831 + With : 'a list,
15.832 + Relate: 'a list};
15.833 +fun ppc2str {Given=Given,Where=Where,Find=Find,With=With,Relate=Relate}=
15.834 + ("{Given =" ^ (strs2str Given ) ^
15.835 + ",Where=" ^ (strs2str Where) ^
15.836 + ",Find =" ^ (strs2str Find ) ^
15.837 + ",With =" ^ (strs2str With ) ^
15.838 + ",Relate=" ^ (strs2str Relate) ^ "}");
15.839 +
15.840 +
15.841 +
15.842 +
15.843 +fun item_ppc ({Given = gi,Where= wh,
15.844 + Find = fi,With = wi,Relate= re}: string ppc) =
15.845 + {Given = map init_item gi,Where= map init_item wh,
15.846 + Find = map init_item fi,With = map init_item wi,
15.847 + Relate= map init_item re}:item ppc;
15.848 +fun itemppc2str ({Given=Given,Where=Where,
15.849 + Find=Find,With=With,Relate=Relate}:item ppc)=
15.850 + ("{Given =" ^ ((strs2str' o (map item2str)) Given ) ^
15.851 + ",Where=" ^ ((strs2str' o (map item2str)) Where) ^
15.852 + ",Find =" ^ ((strs2str' o (map item2str)) Find ) ^
15.853 + ",With =" ^ ((strs2str' o (map item2str)) With ) ^
15.854 + ",Relate=" ^ ((strs2str' o (map item2str)) Relate) ^ "}");
15.855 +
15.856 +fun de_item (Correct x) = x
15.857 + | de_item (SyntaxE x) = x
15.858 + | de_item (TypeE x) = x
15.859 + | de_item (False x) = x
15.860 + | de_item (Incompl x) = x
15.861 + | de_item (Superfl x) = x
15.862 + | de_item (Missing x) = x;
15.863 +val empty_ppc ={Given = [],
15.864 + Where= [],
15.865 + Find = [],
15.866 + With = [],
15.867 + Relate= []}:item ppc;
15.868 +val empty_ppc_ct' ={Given = [],
15.869 + Where = [],
15.870 + Find = [],
15.871 + With = [],
15.872 + Relate= []}:cterm' ppc;
15.873 +
15.874 +
15.875 +datatype match =
15.876 + Matches of pblID * item ppc
15.877 +| NoMatch of pblID * item ppc;
15.878 +fun match2str (Matches (pI, ppc)) =
15.879 + "Matches ("^(strs2str pI)^", "^(itemppc2str ppc)^")"
15.880 + | match2str(NoMatch (pI, ppc)) =
15.881 + "NoMatch ("^(strs2str pI)^", "^(itemppc2str ppc)^")";
15.882 +fun matchs2str ms = (strs2str o (map match2str)) ms;
15.883 +fun pblID_of_match (Matches (pI,_)) = pI
15.884 + | pblID_of_match (NoMatch (pI,_)) = pI;
15.885 +
15.886 +(*10.03 for Refine_Problem*)
15.887 +datatype match_ =
15.888 + Match_ of pblID * ((itm list) * ((bool * term) list))
15.889 +| NoMatch_;
15.890 +
15.891 +(*. the refined pbt is the last_element Matches in the list .*)
15.892 +fun is_matches (Matches _) = true
15.893 + | is_matches _ = false;
15.894 +fun matches_pblID (Matches (pI,_)) = pI;
15.895 +fun refined ms = ((matches_pblID o the o (find_first is_matches) o rev) ms)
15.896 + handle _ => []:pblID;
15.897 +fun refined_IDitms ms = ((find_first is_matches) o rev) ms;
15.898 +
15.899 +(*. the refined pbt is the last_element Matches in the list,
15.900 + for Refine_Problem, tryrefine .*)
15.901 +fun is_matches_ (Match_ _) = true
15.902 + | is_matches_ _ = false;
15.903 +fun refined_ ms = ((find_first is_matches_) o rev) ms;
15.904 +
15.905 +
15.906 +fun ts_in (Cor ((_,ts),_)) = ts
15.907 + | ts_in (Syn (c)) = []
15.908 + | ts_in (Typ (c)) = []
15.909 + | ts_in (Inc ((_,ts),_)) = ts
15.910 + | ts_in (Sup (_,ts)) = ts
15.911 + | ts_in (Mis _) = [];
15.912 +(*WN050629 unused*)
15.913 +fun all_ts_in itm_s = (flat o (map ts_in)) itm_s;
15.914 +val unique = (term_of o the o (parse (theory "Real"))) "UnIqE_tErM";
15.915 +fun d_in (Cor ((d,_),_)) = d
15.916 + | d_in (Syn (c)) = (writeln("*** d_in: Syn ("^c^")"); unique)
15.917 + | d_in (Typ (c)) = (writeln("*** d_in: Typ ("^c^")"); unique)
15.918 + | d_in (Inc ((d,_),_)) = d
15.919 + | d_in (Sup (d,_)) = d
15.920 + | d_in (Mis (d,_)) = d;
15.921 +
15.922 +fun dts2str (d,ts) = pair2str (term2str d, terms2str ts);
15.923 +fun penvval_in (Cor ((d,_),(_,ts))) = [comp_ts (d,ts)]
15.924 + | penvval_in (Syn (c)) = (writeln("*** penvval_in: Syn ("^c^")"); [])
15.925 + | penvval_in (Typ (c)) = (writeln("*** penvval_in: Typ ("^c^")"); [])
15.926 + | penvval_in (Inc (_,(_,ts))) = ts
15.927 + | penvval_in (Sup dts) = (writeln("*** penvval_in: Sup "^(dts2str dts)); [])
15.928 + | penvval_in (Mis (d,t)) = (writeln("*** penvval_in: Mis "^
15.929 + (pair2str(term2str d, term2str t))); []);
15.930 +
15.931 +
15.932 +(*. check a predicate labelled with indication of incomplete substitution;
15.933 +rls -> (*for eval_true*)
15.934 +bool * (*have _all_ variables(Free) from the model-pattern
15.935 + been substituted by a value from the pattern's environment ?*)
15.936 +term (*the precondition*)
15.937 +->
15.938 +bool * (*has the precondition evaluated to true*)
15.939 +term (*the precondition (for map)*)
15.940 +.*)
15.941 +fun evalprecond prls (false, pre) =
15.942 + (*NOT ALL Free's have been substituted, eg. because of incomplete model*)
15.943 + (false, pre)
15.944 + | evalprecond prls (true, pre) =
15.945 +(* val (prls, pre) = (prls, hd pres');
15.946 + val (prls, pre) = (prls, hd (tl pres'));
15.947 + *)
15.948 + if eval_true (assoc_thy "Isac.thy") (*for Pattern.match *)
15.949 + [pre] prls (*pre parsed, prls.thy*)
15.950 + then (true , pre)
15.951 + else (false , pre);
15.952 +
15.953 +fun pre2str (b, t) = pair2str(bool2str b, term2str t);
15.954 +fun pres2str pres = strs2str' (map (linefeed o pre2str) pres);
15.955 +
15.956 +(*. check preconditions, return true if all true .*)
15.957 +fun check_preconds' _ [] _ _ = [] (*empty preconditions are true*)
15.958 + | check_preconds' prls pres pbl _(*FIXME.WN0308 mvat re-introduce*) =
15.959 +(* val (prls, pres, pbl, _) = (prls, where_, probl, 0);
15.960 + val (prls, pres, pbl, _) = (prls, pre, itms, mvat);
15.961 + *)
15.962 + let val env = mk_env pbl;
15.963 + val pres' = map (subst_atomic_all env) pres;
15.964 + in map (evalprecond prls) pres' end;
15.965 +
15.966 +fun check_preconds thy prls pres pbl =
15.967 + check_preconds' prls pres pbl (max_vt pbl);
15.968 +
15.969 +(*----------------------------------------------------------*)
15.970 +end
15.971 +open SpecifyTools;
15.972 +(*----------------------------------------------------------*)
16.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2 +++ b/src/Tools/isac/Interpret/ptyps.sml Wed Aug 25 16:20:07 2010 +0200
16.3 @@ -0,0 +1,1279 @@
16.4 +(* the problems and methods as stored in hierarchies
16.5 + author Walther Neuper 1998
16.6 + (c) due to copyright terms
16.7 +
16.8 +use"ME/ptyps.sml";
16.9 +use"ptyps.sml";
16.10 +*)
16.11 +
16.12 +(*-----------------------------------------vvv-(1) aus modspec.sml 23.3.02*)
16.13 +val dsc_unknown = (term_of o the o (parseold @{theory Script}))
16.14 + "unknown::'a => unknow";
16.15 +(*-----------------------------------------^^^-(1) aus modspec.sml 23.3.02*)
16.16 +
16.17 +
16.18 +(*-----------------------------------------vvv-(2) aus modspec.sml 23.3.02*)
16.19 +
16.20 +fun itm_2item thy (Cor ((d,ts),_)) =
16.21 + Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts)))
16.22 + | itm_2item _ (Syn c) = SyntaxE c
16.23 + | itm_2item _ (Typ c) = TypeE c
16.24 + | itm_2item thy (Inc ((d,ts),_)) =
16.25 + Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts)))
16.26 + | itm_2item thy (Sup (d,ts)) =
16.27 + Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts)))
16.28 + | itm_2item _ (Mis (d,pid)) =
16.29 + Missing (Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^
16.30 + Syntax.string_of_term (thy2ctxt' "Isac") pid);
16.31 +
16.32 +
16.33 +(* --- 8.3.00
16.34 +fun get_dsc_in dscppc sel = ((the (assoc (dscppc, sel))):term list)
16.35 + handle _ => error ("get_dsc_in not for "^sel);
16.36 +
16.37 +fun dscs_in dscppc =
16.38 + ((get_dsc_in dscppc "#Given") @
16.39 + (get_dsc_in dscppc "#Find") @
16.40 + (get_dsc_in dscppc "#Relate")):term list;
16.41 +
16.42 + --- 26.1.88
16.43 +fun get_dsc_of pblID sel = (the (assoc((snd o get_pbt) pblID, sel)));
16.44 +fun get_dsc pblID =
16.45 + (get_dsc_of pblID "#Given") @
16.46 + (get_dsc_of pblID "#Find") @
16.47 + (get_dsc_of pblID "#Relate");
16.48 + --- *)
16.49 +
16.50 +fun mappc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) =
16.51 + {Given=map f gi, Where=map f wh,
16.52 + Find=map f fi, With=map f wi, Relate=map f re}:'b ppc;
16.53 +fun appc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) =
16.54 + {Given=f gi, Where=f wh,
16.55 + Find=f fi, With=f wi, Relate=f re}:'b ppc;
16.56 +
16.57 +(*for ppc of changing type*)
16.58 +fun sel_ppc sel ppc =
16.59 + case sel of
16.60 + "#Given" => #Given (ppc:'a ppc)
16.61 + | "#Where" => #Where (ppc:'a ppc)
16.62 + | "#Find" => #Find (ppc:'a ppc)
16.63 + | "#With" => #With (ppc:'a ppc)
16.64 + | "#Relate" => #Relate (ppc:'a ppc)
16.65 + | _ => raise error ("sel_ppc tried to select by '"^sel^"'");
16.66 +
16.67 +fun repl_sel_ppc sel
16.68 + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x =
16.69 + case sel of
16.70 + "#Given" => ({Given= x,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc)
16.71 + | "#Where" => {Given=gi,Where= x,Find=fi,With=wi,Relate=re}
16.72 + | "#Find" => {Given=gi,Where=wh,Find= x,With=wi,Relate=re}
16.73 + | "#With" => {Given=gi,Where=wh,Find=fi,With= x,Relate=re}
16.74 + | "#Relate" => {Given=gi,Where=wh,Find=fi,With=wi,Relate= x}
16.75 + | _ => raise error ("repl_sel_ppc tried to select by '"^sel^"'");
16.76 +
16.77 +fun add_sel_ppc thy sel
16.78 + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x =
16.79 + case sel of
16.80 + "#Given" => ({Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}:'a ppc)
16.81 + | "#Where" => {Given=gi,Where=wh@[x],Find=fi,With=wi,Relate=re}
16.82 + | "#Find" => {Given=gi,Where=wh,Find=fi@[x],With=wi,Relate=re}
16.83 + | "#Relate"=> {Given=gi,Where=wh,Find=fi,With=wi,Relate=re@[x]}
16.84 + | "#undef" => {Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}(*ori2itmSup*)
16.85 + | _ => raise error ("add_sel_ppc tried to select by '"^sel^"'");
16.86 +fun add_where ({Given=gi,Find=fi,With=wi,Relate=re,...}:'a ppc) wh =
16.87 + ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc);
16.88 +
16.89 +(*-----------------------------------------^^^-(2) aus modspec.sml 23.3.02*)
16.90 +
16.91 +
16.92 +(*-----------------------------------------vvv-(3) aus modspec.sml 23.3.02*)
16.93 +
16.94 +
16.95 +
16.96 +(*decompose a problem-type into description and identifier
16.97 + FIXME split_dsc: no term list !!! (just for quick redoing prep_ori) *)
16.98 +fun split_dsc thy t =
16.99 + (let val (hd,args) = strip_comb t
16.100 + in if is_dsc hd
16.101 + then (hd, args)
16.102 + else (e_term, [t]) (*??? 9.01 just copied*)
16.103 + end)
16.104 + handle _ => raise error ("split_dsc: called with "^
16.105 + (Syntax.string_of_term (thy2ctxt' "Isac") t));
16.106 +(*
16.107 +> val t1 = (term_of o the o (parse thy)) "errorBound err_";
16.108 +> split_dsc t1;
16.109 +(Const ("Descript.errorBound","bool => Tools.nam"),Free ("err_","bool"))
16.110 + : term * term
16.111 +> val t3 = (term_of o the o (parse thy)) "valuesFor vs_";
16.112 +> split_dsc t3;
16.113 +(Const ("Descript.valuesFor","bool List.list => Tools.toreall"),
16.114 + Free ("vs_","bool List.list")) : term * term*)
16.115 +
16.116 +
16.117 +
16.118 +(*. take the first two return-values; for prep_ori .*)
16.119 +(*WN.13.5.03fun split_dts' thy t =
16.120 + let val (d, ts, _) = split_dts thy t
16.121 + in (d, ts) end;*)
16.122 +(*WN.8.12.03 quick for prep_ori'*)
16.123 +fun split_dsc' t =
16.124 + (let val dsc $ var = t
16.125 + in var end)
16.126 + handle _ => raise error ("split_dsc': called with "^term2str t);
16.127 +
16.128 +(*9.3.00*)
16.129 +(* split a term into description and (id | structured variable)
16.130 + for pbt, met.ppc *)
16.131 +fun split_did t =
16.132 + (let val (hd,[arg]) = strip_comb t
16.133 + in (hd,arg) end)
16.134 + handle _ => raise error ("split_did: doesn't match (hd,[arg]) for t = "
16.135 + ^(Syntax.string_of_term (thy2ctxt' "Script") t));
16.136 +
16.137 +
16.138 +
16.139 +(*create output-string for itm_*)
16.140 +fun itm_out thy (Cor ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
16.141 + | itm_out thy (Syn c) = c
16.142 + | itm_out thy (Typ c) = c
16.143 + | itm_out thy (Inc ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
16.144 + | itm_out thy (Sup (d,ts)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
16.145 + | itm_out thy (Mis (d,pid)) =
16.146 + Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^
16.147 + Syntax.string_of_term (thy2ctxt' "Isac") pid;
16.148 +
16.149 +(*22.11.00 unused
16.150 +fun itm_ppc2str thy ipc = (ppc2str o (mappc (itm__2str thy))) ipc;*)
16.151 +
16.152 +
16.153 +(*--3.3.
16.154 +fun itms2dts itms =
16.155 + let
16.156 + fun coll itms' [] = itms'
16.157 + | coll itms' (i::itms) =
16.158 + case i of
16.159 + (Cor (d,ts)) => coll (itms' @ [(d,ts)]) itms
16.160 + | (Syn c) => coll (itms' ) itms
16.161 + | (Typ c) => coll (itms' ) itms
16.162 + | (Fal (d,ts)) => coll (itms' @ [(d,ts)]) itms
16.163 + | (Inc (d,ts)) => coll (itms' @ [(d,ts)]) itms
16.164 + | (Sup (d,ts)) => coll (itms' @ [(d,ts)]) itms
16.165 + in coll [] itms end;
16.166 +*)
16.167 +(*--3.3.00
16.168 +fun itm2item ((_,_,_,_,Cor (d,ts)):itm) =
16.169 + Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
16.170 + | itm2item (_,_,_,_,Syn (c)) = SyntaxE c
16.171 + | itm2item (_,_,_,_,Typ (c)) = TypeE c
16.172 + | itm2item (_,_,_,_,Fal (d,ts)) =
16.173 + False (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
16.174 + | itm2item (_,_,_,_,Inc (d,ts)) =
16.175 + Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
16.176 + | itm2item (_,_,_,_,Sup (d,ts)) =
16.177 + Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)));
16.178 +*)
16.179 +
16.180 +fun boolterm2item (true, term) = Correct (term2str term)
16.181 + | boolterm2item (false, term) = False (term2str term);
16.182 +
16.183 +(* use"ME/modspec.sml";
16.184 + *)
16.185 +fun itms2itemppc thy (itms:itm list) (pre:(bool * term) list) =
16.186 + let
16.187 + fun coll ppc [] = ppc
16.188 + | coll ppc ((_,_,_,field,itm_)::itms) =
16.189 + coll (add_sel_ppc thy field ppc (itm_2item thy itm_)) itms;
16.190 + val gfr = coll empty_ppc itms;
16.191 + in add_where gfr (map boolterm2item pre) end;
16.192 +(*-----------------------------------------^^^-(3) aus modspec.sml 23.3.02*)
16.193 +
16.194 +(*-----------------------------------------vvv-(4) aus modspec.sml 23.3.02*)
16.195 +
16.196 +(* --- 9.3.fun add_field dscs (d,ts) =
16.197 + if d mem (get_dsc_in dscs "#Given")
16.198 + then ("#Given",d,ts:term list)
16.199 + else if d mem (get_dsc_in dscs "#Find")
16.200 + then ("#Find",d,ts)
16.201 + else if d mem (get_dsc_in dscs "#Relate")
16.202 + then ("#Relate",d,ts)
16.203 + else ("#undef",d,ts);
16.204 +(* 28.1.00 raise error ("add_field: '"^
16.205 + (Syntax.string_of_term (thy2ctxt' "Isac") d)^
16.206 + "' not in ppc-description "); *)
16.207 + ------9.3. *)
16.208 +
16.209 +(* 9.3.00
16.210 + compare d and dsc in pbt and transfer field to pre-ori *)
16.211 +fun add_field thy pbt (d,ts) =
16.212 + let fun eq d pt = (d = (fst o snd) pt);
16.213 + in case filter (eq d) pbt of
16.214 + [(fi,(dsc,_))] => (fi,d,ts)
16.215 + | [] => ("#undef",d,ts) (*may come with met.ppc*)
16.216 + | _ => raise error ("add_field: "^
16.217 + (Syntax.string_of_term (thy2ctxt' "Isac") d)^
16.218 + " more than once in pbt")
16.219 + end;
16.220 +
16.221 +(*. take over field from met.ppc at 'Specify_Method' into ori,
16.222 + i.e. also removes "#undef" fields .*)
16.223 +(* val (mpc, ori) = ((#ppc o get_met) mID, oris);
16.224 + *)
16.225 +fun add_field' thy mpc (ori:ori list) =
16.226 + let fun eq d pt = (d = (fst o snd) pt);
16.227 + fun repl mpc (i,v,_,d,ts) =
16.228 + case filter (eq d) mpc of
16.229 + [(fi,(dsc,_))] => [(i,v,fi,d,ts)]
16.230 + | [] => [] (*25.2.02: dsc in ori, but not in met -> superfluous*)
16.231 + (*raise error ("add_field': "^
16.232 + (Syntax.string_of_term (thy2ctxt' "Isac") d)^
16.233 + " not in met"*)
16.234 + | _ => raise error ("add_field': "^
16.235 + (Syntax.string_of_term (thy2ctxt' "Isac") d)^
16.236 + " more than once in met");
16.237 + in (flat ((map (repl mpc)) ori)):ori list end;
16.238 +
16.239 +
16.240 +(*.mark an element with the position within a plateau;
16.241 + a plateau with length 1 is marked with 0 .*)
16.242 +fun mark eq [] = raise error "mark []"
16.243 + | mark eq xs =
16.244 + let
16.245 + fun mar xx eq [x] n = xx @ [(if n=1 then 0 else n,x)]
16.246 + | mar xx eq (x::x'::xs) n =
16.247 + if eq(x,x') then mar (xx @ [(n,x)]) eq (x'::xs) (n+1)
16.248 + else mar (xx @ [(if n=1 then 0 else n,x)]) eq (x'::xs) 1;
16.249 + in mar [] eq xs 1 end;
16.250 +(*
16.251 +> val xs = [1,1,1,2,4,4,5];
16.252 +> mark (op=) xs;
16.253 +val it = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)]
16.254 +*)
16.255 +
16.256 +(*.assumes equal descriptions to be in adjacent 'plateaus',
16.257 + items at a certain position within the plateaus form a variant;
16.258 + length = 1 ... marked with 0: covers all variants .*)
16.259 +fun add_variants fdts =
16.260 + let
16.261 + fun eq (a,b) = curry op= (snd3 a) (snd3 b);
16.262 + in mark eq fdts end;
16.263 +
16.264 +(* collect equal elements: the model for coll_variants *)
16.265 +fun coll eq xs =
16.266 + let
16.267 + fun col xs eq x [] = xs @ [x]
16.268 + | col xs eq x (y::ys) =
16.269 + if eq(x,y) then col xs eq x ys
16.270 + else col (xs @ [x]) eq y ys;
16.271 + in col [] eq (hd xs) xs end;
16.272 +(*
16.273 +> val xs = [1,1,1,2,4,4,4];
16.274 +> coll (op=) xs;
16.275 +val it = [1,2,4] : int list
16.276 +*)
16.277 +
16.278 +fun max [] = raise error "max of []"
16.279 + | max (y::ys) =
16.280 + let fun mx x [] = x
16.281 + | mx x (y::ys) = if x < y then mx y ys else mx x ys;
16.282 +in mx y ys end;
16.283 +fun gen_max _ [] = raise error "gen_max of []"
16.284 + | gen_max ord (y::ys) =
16.285 + let fun mx x [] = x
16.286 + | mx x (y::ys) = if ord (x, y) then mx y ys else mx x ys;
16.287 +in mx y ys end;
16.288 +
16.289 +
16.290 +
16.291 +(* assumes *)
16.292 +fun coll_variants (((v,x)::vxs)) =
16.293 + let
16.294 + fun col xs (vs,x) [] = xs @ [(vs,x)]
16.295 + | col xs (vs,x) ((v',x')::vxs') =
16.296 + if x=x' then col xs (vs @ [v'], x') vxs'
16.297 + else col (xs @ [(vs,x)]) ([v'], x') vxs';
16.298 + in col [] ([v],x) vxs end;
16.299 +(* val xs = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)];
16.300 +> col [] ([(fst o hd) xs],(snd o hd) xs) (tl xs);
16.301 +val it = [([1,2,3],1),([0],2),([1,2],4),([0],5)] *)
16.302 +
16.303 +
16.304 +fun replace_0 vm [0] = intsto vm
16.305 + | replace_0 vm vs = vs;
16.306 +
16.307 +fun add_id [] = raise error "add_id []"
16.308 + | add_id xs =
16.309 + let fun add n [] = []
16.310 + | add n (x::xs) = (n,x) :: add (n+1) xs;
16.311 +in add 1 xs end;
16.312 +(*
16.313 +> val xs = [([1,2,3],1),([0],2),([1,2],4),([0],5)];
16.314 +> add_id xs;
16.315 +val it = [(1,([#,#,#],1)),(2,([#],2)),(3,([#,#],4)),(4,([#],5))]
16.316 + *)
16.317 +
16.318 +fun flattup (a,(b,(c,d,e))) = (a,b,c,d,e);
16.319 +fun flattup' (a,(b,((c,d),e))) = (a,b,c,d,e);
16.320 +fun flat3 (a,(b,c)) = (a,b,c);
16.321 +(*
16.322 + val pI = pI';
16.323 + !pbts;
16.324 +*)
16.325 +(* in root (only!) fmz may be empty: fill with ..,dsc,[]
16.326 +fun init_ori fmz thy pI =
16.327 + if fmz <> [] then prep_ori fmz thy pI (*fmz assumed complete*)
16.328 + else
16.329 + let
16.330 + val fds = map (cons2 (fst, fst o snd)) (get_pbt pI);
16.331 + val vfds = map ((pair [1]) o (rpair [])) fds;
16.332 + val ivfds = add_id vfds
16.333 + in (map flattup' ivfds):ori list end; 10.3.00---*)
16.334 +(* val fmz = ctl; val pI=["sqroot-test","univariate","equation"];
16.335 + val (thy,pbt) = (assoc_thy dI',(#ppc o get_pbt) pI');
16.336 + val (fmz, thy, pbt) = (fmz, thy, ((#ppc o get_pbt) pI));
16.337 + *)
16.338 +fun prep_ori [] _ _ = []
16.339 + | prep_ori fmz thy pbt =
16.340 + let
16.341 + val ctopts = map (parse thy) fmz
16.342 + val _= (*FIXME.WN060916 improve error report*)
16.343 + if null (filter is_none ctopts) then ()
16.344 + else raise error ("prep_ori: SYNTAX ERROR in " ^ strs2str' fmz)
16.345 + val dts = map ((split_dts thy) o term_of o the) ctopts
16.346 + val ori = map (add_field thy pbt) dts;
16.347 +(* val ori = map (flat3 o (pair "#undef")) dts; *)
16.348 + val ori' = add_variants ori;
16.349 + val maxv = max (map fst ori');
16.350 + val maxv = if maxv = 0 then 1(*only 1 variant*) else maxv;
16.351 + val ori'' = coll_variants ori';
16.352 + val ori''' = map (apfst (replace_0 maxv)) ori'';
16.353 + val ori'''' = add_id ori'''
16.354 + in (map flattup ori''''):ori list end;
16.355 +
16.356 +
16.357 +(*-----------------------------------------^^^-(4) aus modspec.sml 23.3.02*)
16.358 +
16.359 +(*.the pattern for an item of a problems model or a methods guard.*)
16.360 +type pat = (string * (*field*)
16.361 + (term * (*description*)
16.362 + term)) (*id | struct-var*);
16.363 +fun pat2str ((field, (dsc, id)):pat) =
16.364 + pair2str (field, pair2str (term2str dsc, term2str id));
16.365 +fun pats2str pats = (strs2str o (map pat2str)) pats;
16.366 +
16.367 +(* data for methods stored in 'methods'-database *)
16.368 +type met =
16.369 + {guh : guh, (*unique within this isac-knowledge *)
16.370 + mathauthors: string list,(*copyright *)
16.371 + init : pblID, (*WN060721 introduced mistakenly--TODO.REMOVE!*)
16.372 + rew_ord' : rew_ord', (*for rules in Detail
16.373 + TODO.WN0509 store fun itself, see 'type pbt'*)
16.374 + erls : rls, (*the eval_rls for cond. in rules FIXME "rls'
16.375 + instead erls in "fun prep_met" *)
16.376 + srls : rls, (*for evaluating list expressions in scr *)
16.377 + prls : rls, (*for evaluating predicates in modelpattern *)
16.378 + crls : rls, (*for check_elementwise, ie. formulae in calc.*)
16.379 + nrls : rls, (*canonical simplifier specific for this met *)
16.380 + calc : calc list, (*040207: <--- calclist' in fun prep_met *)
16.381 + (*branch : TransitiveB set in append_problem at generation ob pblobj
16.382 + FIXXXME.8.03: set branch from met in Apply_Method *)
16.383 +
16.384 + (* compare type pbt:*)
16.385 + ppc: pat list,
16.386 + (*.items in given, find, relate;
16.387 + items (in "#Find") which need not occur in the arg-list of a SubProblem
16.388 + are 'copy-named' with an identifier "*_!_".
16.389 + copy-named items are 'generating' if they are NOT "*___"
16.390 + see ME/calchead.sml 'fun is_copy_named'.*)
16.391 + pre: term list, (*preconditions in where*)
16.392 + (*script*)
16.393 + scr: scr (*prep_met requires either script or string "empty_script"*)
16.394 + };
16.395 +(* ------- template ------------------------------------------------------
16.396 +store_met
16.397 + (prep_met *.thy
16.398 + ([(*"EqSystem","normalize"*)],
16.399 + [("#Given" ,[ (*"equalities es_", "solveForVars vs_"*)]),
16.400 + ("#Find" ,[ (*dont forget typing non-reals *)]),
16.401 + ("#Relate",[])(*may be omitted *) ],
16.402 + {calc = [], (*filled autom. in prep_met *)
16.403 + crls = Erls, (*for check_elementwise *)
16.404 + prls = Erls, (*for evaluating preds in guard *)
16.405 + nrls = Erls, (*can.simplifier for all formulae*)
16.406 + rew_ord'="tless_true", (*for rules in Detail *)
16.407 + rls' = Erls, (*erls, the eval_rls for cond. in rules*)
16.408 + srls = Erls}, (*for evaluating list expr in scr*)
16.409 + "empty_script"
16.410 + ));
16.411 +---------- template ----------------------------------------------------*)
16.412 +val e_met = {guh="met_empty",mathauthors=[],init=e_metID,
16.413 + rew_ord' = "e_rew_ord'": rew_ord',
16.414 + erls = e_rls, srls = e_rls, prls = e_rls,
16.415 + calc = [], crls = e_rls, nrls = e_rls,
16.416 + (*asm_thm = []: thm' list,
16.417 + asm_rls = []: rls' list,*)
16.418 + ppc = []: (string * (term * term)) list,
16.419 + pre = []: term list,
16.420 + scr = EmptyScr: scr}:met;
16.421 +
16.422 +
16.423 +(** problem-types stored in format for usage in specify **)
16.424 +(*25.8.01 ----
16.425 +val pbltypes = ref ([(e_pblID,[])]:(pblID * ((string * (* field "#Given",..*)
16.426 + (term * (* description *)
16.427 + term)) (* id | struct-var *)
16.428 + list)
16.429 + ) list);*)
16.430 +
16.431 +(*deprecated due to 'type pat'*)
16.432 +type pbt_ = (string * (* field "#Given",..*)
16.433 + (term * (* description *)
16.434 + term)); (* id | struct-var *)
16.435 +val e_pbt_ = ("#Undef", (e_term, e_term)):pbt_;
16.436 +type pbt =
16.437 + {guh : guh, (*unique within this isac-knowledge*)
16.438 + mathauthors: string list, (*copyright*)
16.439 + init : pblID, (*to start refinement with*)
16.440 + thy : theory, (* which allows to compile that pbt
16.441 + TODO: search generalized for subthy (ref.p.69*)
16.442 + (*^^^ WN050912 NOT used during application of the problem,
16.443 + because applied terms may be from 'subthy' as well as from super;
16.444 + thus we take 'maxthy'; see match_ags !*)
16.445 + cas : term option,(*'CAS-command'*)
16.446 + prls : rls, (* for preds in where_*)
16.447 + where_: term list, (* where - predicates*)
16.448 + ppc : pat list,
16.449 + (*this is the model-pattern;
16.450 + it contains "#Given","#Where","#Find","#Relate"-patterns*)
16.451 + met : metID list}; (* methods solving the pbt*)
16.452 +val e_pbt = {guh="pbl_empty",mathauthors=[],init=e_pblID,thy=theory "Pure",
16.453 + cas=NONE,prls=Erls,where_=[],ppc=[],met=[]}:pbt;
16.454 +fun pbt2 (str, (t1, t2)) =
16.455 + pair2str (str, pair2str (term2str t1, term2str t2));
16.456 +fun pbt2str pbt = (strs2str o (map (linefeed o pbt2))) pbt;
16.457 +
16.458 +
16.459 +val e_Ptyp = Ptyp ("e_pblID",[e_pbt],[]);
16.460 +val e_Mets = Ptyp ("e_metID",[e_met],[]);
16.461 +
16.462 +type ptyps = (pbt ptyp) list;
16.463 +val ptyps = ref ([e_Ptyp]:ptyps);
16.464 +
16.465 +type mets = (met ptyp) list;
16.466 +val mets = ref ([e_Mets]:mets);
16.467 +
16.468 +
16.469 +(**+ breadth-first search on hierarchy of problem-types +**)
16.470 +
16.471 +type pblRD = pblID;(*pblID are Reverted _on calling_ the retrieve-funs*)
16.472 + (* eg. ["equations","univariate","normalize"] while
16.473 + ["normalize","univariate","equations"] is the related pblID
16.474 + WN.24.4.03: also used for metID*)
16.475 +
16.476 +fun get_py thy d _ [] =
16.477 + error ("get_pbt not found: "^(strs2str d))
16.478 + | get_py thy d [k] ((Ptyp (k',[py],_))::pys) =
16.479 + if k=k' then py
16.480 + else get_py thy d ([k]:pblRD) pys
16.481 + | get_py thy d (k::ks) ((Ptyp (k',_,pys))::pys') =
16.482 + if k=k' then get_py thy d ks pys
16.483 + else get_py thy d (k::ks) pys';
16.484 +(*> ptyps:=
16.485 +[Ptyp ("1",[("ptyp 1",([],[]))],
16.486 + [Ptyp ("11",[("ptyp 11",([],[]))],
16.487 + [])
16.488 + ]),
16.489 + Ptyp ("2",[("ptyp 2",([],[]))],
16.490 + [Ptyp ("21",[("ptyp 21",([],[]))],
16.491 + [])
16.492 + ])
16.493 + ];
16.494 +> get_py SqRoot.thy ["1"] ["1"] (!ptyps);
16.495 +> get_py SqRoot.thy ["2","21"] ["2","21"] (!ptyps);
16.496 + _REVERSE_ .......... !!!!!!!!!!*)
16.497 +
16.498 +(*TODO: search generalized for subthy*)
16.499 +fun get_pbt (pblID:pblID) =
16.500 + let val pblRD = rev pblID;
16.501 + in get_py (theory "Pure") pblID pblRD (!ptyps) end;
16.502 +(* get_pbt thy ["1"];
16.503 + get_pbt thy ["21","2"];
16.504 + *)
16.505 +
16.506 +(*TODO: throws exn 'get_pbt not found: ' ... confusing !!
16.507 + take 'ketype' as an argument !!!!!*)
16.508 +fun get_met (metID:metID) = get_py (theory "Pure") metID metID (!mets);
16.509 +fun get_the (theID:theID) = get_py (theory "Pure") theID theID (!thehier);
16.510 +
16.511 +
16.512 +
16.513 +fun del_eq k ptyps =
16.514 +let fun del k ptyps [] = ptyps
16.515 + | del k ptyps ((Ptyp (k', [p], ps))::pys) =
16.516 + if k=k' then del k ptyps pys
16.517 + else del k (ptyps @ [Ptyp (k', [p], ps)]) pys;
16.518 +in del k [] ptyps end;
16.519 +
16.520 +fun insrt d pbt [k] [] = [Ptyp (k, [pbt],[])]
16.521 +
16.522 + | insrt d pbt [k] ((Ptyp (k', [p], ps))::pys) =
16.523 +((*writeln("### insert 1: ks = "^(strs2str [k])^" k'= "^k');*)
16.524 + if k=k'
16.525 + then ((Ptyp (k', [pbt], ps))::pys)
16.526 + else (*ev.newly added pbt is free _only_ with 'last_elem pblID'*)
16.527 + ((Ptyp (k', [p], ps))::(insrt d pbt [k] pys))
16.528 +)
16.529 + | insrt d pbt (k::ks) ((Ptyp (k', [p], ps))::pys) =
16.530 +((*writeln("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*)
16.531 + if k=k'
16.532 + then ((Ptyp (k', [p], insrt d pbt ks ps))::pys)
16.533 + else
16.534 + if length pys = 0
16.535 + then error ("insert: not found "^(strs2str (d:pblID)))
16.536 + else ((Ptyp (k', [p], ps))::(insrt d pbt (k::ks) pys))
16.537 +);
16.538 +
16.539 +
16.540 +fun coll_pblguhs pbls =
16.541 + let fun node coll (Ptyp (_,[n],ns)) =
16.542 + [(#guh : pbt -> guh) n] @ (nodes coll ns)
16.543 + and nodes coll [] = coll
16.544 + | nodes coll (n::ns) = (node coll n) @ (nodes coll ns);
16.545 + in nodes [] pbls end;
16.546 +fun coll_metguhs mets =
16.547 + let fun node coll (Ptyp (_,[n],ns)) =
16.548 + [(#guh : met -> guh) n]
16.549 + and nodes coll [] = coll
16.550 + | nodes coll (n::ns) = (node coll n) @ (nodes coll ns);
16.551 + in nodes [] mets end;
16.552 +
16.553 +(*.lookup a guh in hierarchy or methods depending on fst chars in guh.*)
16.554 +fun guh2kestoreID (guh:guh) =
16.555 + case (implode o (take_fromto 1 4) o explode) guh of
16.556 + "pbl_" =>
16.557 + let fun node ids gu (Ptyp (id,[n as {guh,...} : pbt], ns)) =
16.558 + if gu = guh
16.559 + then SOME ((ids@[id]) : kestoreID)
16.560 + else nodes (ids@[id]) gu ns
16.561 + and nodes _ _ [] = NONE
16.562 + | nodes ids gu (n::ns) =
16.563 + case node ids gu n of SOME id => SOME id
16.564 + | NONE => nodes ids gu ns
16.565 + in case nodes [] guh (!ptyps) of
16.566 + SOME id => rev id
16.567 + | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^
16.568 + "not found in (!ptyps)")
16.569 + end
16.570 + | "met_" =>
16.571 + let fun node ids gu (Ptyp (id,[n as {guh,...} : met], ns)) =
16.572 + if gu = guh
16.573 + then SOME ((ids@[id]) : kestoreID)
16.574 + else nodes (ids@[id]) gu ns
16.575 + and nodes _ _ [] = NONE
16.576 + | nodes ids gu (n::ns) =
16.577 + case node ids gu n of SOME id => SOME id
16.578 + | NONE => nodes ids gu ns
16.579 + in case nodes [] guh (!mets) of
16.580 + SOME id => id
16.581 + | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^
16.582 + "not found in (!mets)") end
16.583 + | _ => error ("guh2kestoreID called with '" ^ guh ^ "'");
16.584 +(*> guh2kestoreID "pbl_equ_univ_lin";
16.585 +val it = ["linear", "univariate", "equation"] : string list*)
16.586 +
16.587 +
16.588 +fun check_pblguh_unique (guh:guh) (pbls: (pbt ptyp) list) =
16.589 + if member op = (coll_pblguhs pbls) guh
16.590 + then error ("check_guh_unique failed with '"^guh^"';\n"^
16.591 + "use 'sort_pblguhs()' for a list of guhs;\n"^
16.592 + "consider setting 'check_guhs_unique := false'")
16.593 + else ();
16.594 +(* val (guh, mets) = ("met_test", !mets);
16.595 + *)
16.596 +fun check_metguh_unique (guh:guh) (mets: (met ptyp) list) =
16.597 + if member op = (coll_metguhs mets) guh
16.598 + then error ("check_guh_unique failed with '"^guh^"';\n"^
16.599 + "use 'sort_metguhs()' for a list of guhs;\n"^
16.600 + "consider setting 'check_guhs_unique := false'")
16.601 + else ();
16.602 +
16.603 +
16.604 +
16.605 +(*.the pblID has the leaf-element as first; better readability achieved;.*)
16.606 +fun store_pbt (pbt as {guh,...}, pblID) =
16.607 + (if (!check_guhs_unique) then check_pblguh_unique guh (!ptyps) else ();
16.608 + ptyps:= insrt pblID pbt (rev pblID) (!ptyps));
16.609 +
16.610 +(*.the metID has the root-element as first; compare 'fun store_pbt'.*)
16.611 +(* val (met as {guh,...}, metID) =
16.612 + ((prep_met EqSystem.thy "met_eqsys" [] e_metID
16.613 + (["EqSystem"],
16.614 + [],
16.615 + {rew_ord'="tless_true", rls' = Erls, calc = [],
16.616 + srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
16.617 + "empty_script"
16.618 + )));
16.619 + *)
16.620 +fun store_met (met as {guh,...}, metID) =
16.621 + (if (!check_guhs_unique) then check_metguh_unique guh (!mets) else ();
16.622 + mets:= insrt metID met metID (!mets));
16.623 +
16.624 +
16.625 +(*. prepare problem-types before storing in pbltypes;
16.626 + dont forget to 'check_guh_unique' before ins.*)
16.627 +fun prep_pbt thy guh maa init
16.628 + (pblID, dsc_dats: (string * (string list)) list,
16.629 + ev:rls, ca: string option, metIDs:metID list) =
16.630 +(* val (thy, (pblID, dsc_dats: (string * (string list)) list,
16.631 + ev:rls, ca: string option, metIDs:metID list)) =
16.632 + ((EqSystem.thy, (["system"],
16.633 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
16.634 + ("#Find" ,["solution ss___"](*___ is copy-named*))
16.635 + ],
16.636 + append_rls "e_rls" e_rls [(*for preds in where_*)],
16.637 + SOME "solveSystem es_ vs_",
16.638 + [])));
16.639 + *)
16.640 + let fun eq f (f', _) = f = f';
16.641 + val gi = filter (eq "#Given") dsc_dats;
16.642 +(*val gi = [("#Given",["equality e_","solveFor v_"])]
16.643 + : (string * string list) list*)
16.644 + val gi = (case gi of
16.645 + [] => []
16.646 + | ((_,gi')::[]) =>
16.647 + ((map (split_did o term_of o the o (parse thy)) gi')
16.648 + handle _ => error
16.649 + ("prep_pbt: syntax error in '#Given' of "^
16.650 + (strs2str pblID)))
16.651 + | _ =>
16.652 + (error ("prep_pbt: more than one '#Given' in "^
16.653 + (strs2str pblID))));
16.654 +(*val gi =
16.655 + [(Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool")),
16.656 + (Const ("Descript.solveFor","RealDef.real => Tools.una"),
16.657 + Free ("v_","RealDef.real"))] : (term * term) list *)
16.658 + val gi = map (pair "#Given") gi;
16.659 +(*val gi =
16.660 + [("#Given",
16.661 + (Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool"))),
16.662 + ("#Given",
16.663 + (Const ("Descript.solveFor","RealDef.real => Tools.una"),
16.664 + Free ("v_","RealDef.real")))] : (string * (term * term)) list*)
16.665 +
16.666 + val fi = filter (eq "#Find") dsc_dats;
16.667 + val fi = (case fi of
16.668 + [] => [](*28.8.01: ["tool"] ...// raise error
16.669 + ("prep_pbt: no '#Find' in "^(strs2str pblID))*)
16.670 +(* val ((_,fi')::[]) = fi;
16.671 + *)
16.672 + | ((_,fi')::[]) =>
16.673 + ((map (split_did o term_of o the o (parse thy)) fi')
16.674 + handle _ => raise error
16.675 + ("prep_pbt: syntax error in '#Find' of "^
16.676 + (strs2str pblID)))
16.677 + | _ =>
16.678 + (raise error ("prep_pbt: more than one '#Find' in "^
16.679 + (strs2str pblID))));
16.680 + val fi = map (pair "#Find") fi;
16.681 +
16.682 + val re = filter (eq "#Relate") dsc_dats;
16.683 + val re = (case re of
16.684 + [] => []
16.685 + | ((_,re')::[]) =>
16.686 + ((map (split_did o term_of o the o (parse thy)) re')
16.687 + handle _ => raise error
16.688 + ("prep_pbt: syntax error in '#Relate' of "^
16.689 + (strs2str pblID)))
16.690 + | _ =>
16.691 + (raise error ("prep_pbt: more than one '#Relate' in "^
16.692 + (strs2str pblID))));
16.693 + val re = map (pair "#Relate") re;
16.694 +
16.695 + val wh = filter (eq "#Where") dsc_dats;
16.696 + val wh = (case wh of
16.697 + [] => []
16.698 + | ((_,wh')::[]) =>
16.699 + ((map (term_of o the o (parse thy)) wh')
16.700 + handle _ => raise error
16.701 + ("prep_pbt: syntax error in '#Where' of "^
16.702 + (strs2str pblID)))
16.703 + | _ =>
16.704 + (raise error ("prep_pbt: more than one '#Where' in "^
16.705 + (strs2str pblID))));
16.706 + in ({guh=guh,mathauthors=maa,init=init,
16.707 + thy=thy,cas= case ca of NONE => NONE
16.708 + | SOME s =>
16.709 + SOME ((term_of o the o (parse thy)) s),
16.710 + prls=ev,where_=wh,ppc= gi @ fi @ re,
16.711 + met=metIDs}, pblID):pbt * pblID end;
16.712 +(* prep_pbt thy (pblID, dsc_dats, metIDs);
16.713 + val it =
16.714 + ({met=[],
16.715 + ppc=[("#Given",(Const (#,#),Free (#,#))),
16.716 + ("#Given",(Const (#,#),Free (#,#))),
16.717 + ("#Find",(Const (#,#),Free (#,#)))],
16.718 + thy={ProtoPure, ..., Atools, RatArith},
16.719 + where_=[Const ("Descript.solutions","bool List.list => Tools.toreall") $
16.720 + Free ("v_i_","bool List.list")]},["equation"]) : pbt * pblID *)
16.721 +
16.722 +
16.723 +
16.724 +
16.725 +(*. prepare met for storage analogous to pbt .*)
16.726 +fun prep_met thy guh maa init
16.727 + (metID, ppc: (string * string list) list (*'#Where' -> #pre*),
16.728 + {rew_ord'=ro, rls'=rls, srls=srls, prls=prls,
16.729 + calc = scr_isa_fns(*FIXME.040207: del - auto-done*),
16.730 + crls=cr, nrls=nr}, scr) =
16.731 + let fun eq f (f', _) = f = f';
16.732 + (*val thy = (assoc_thy o fst) metID*)
16.733 + val gi = filter (eq "#Given") ppc;
16.734 + val gi = (case gi of
16.735 + [] => []
16.736 + | ((_,gi')::[]) =>
16.737 + ((map (split_did o term_of o the o (parse thy)) gi')
16.738 + handle _ => raise error
16.739 + ("prep_pbt: syntax error in '#Given' of "^
16.740 + (strs2str metID)))
16.741 + | _ =>
16.742 + (raise error ("prep_pbt: more than one '#Given' in "^
16.743 + (strs2str metID))));
16.744 + val gi = map (pair "#Given") gi;
16.745 +
16.746 + val fi = filter (eq "#Find") ppc;
16.747 + val fi = (case fi of
16.748 + [] => [](*28.8.01: ["tool"] ...// raise error
16.749 + ("prep_pbt: no '#Find' in "^(strs2str metID))*)
16.750 + | ((_,fi')::[]) =>
16.751 + ((map (split_did o term_of o the o (parse thy)) fi')
16.752 + handle _ => raise error
16.753 + ("prep_pbt: syntax error in '#Find' of "^
16.754 + (strs2str metID)))
16.755 + | _ =>
16.756 + (raise error ("prep_pbt: more than one '#Find' in "^
16.757 + (strs2str metID))));
16.758 + val fi = map (pair "#Find") fi;
16.759 +
16.760 + val re = filter (eq "#Relate") ppc;
16.761 + val re = (case re of
16.762 + [] => []
16.763 + | ((_,re')::[]) =>
16.764 + ((map (split_did o term_of o the o (parse thy)) re')
16.765 + handle _ => raise error
16.766 + ("prep_pbt: syntax error in '#Relate' of "^
16.767 + (strs2str metID)))
16.768 + | _ =>
16.769 + (raise error ("prep_pbt: more than one '#Relate' in "^
16.770 + (strs2str metID))));
16.771 + val re = map (pair "#Relate") re;
16.772 +
16.773 + val wh = filter (eq "#Where") ppc;
16.774 + val wh = (case wh of
16.775 + [] => []
16.776 + | ((_,wh')::[]) =>
16.777 + ((map (term_of o the o (parse thy)) wh')
16.778 + handle _ => raise error
16.779 + ("prep_pbt: syntax error in '#Where' of "^
16.780 + (strs2str metID)))
16.781 + | _ =>
16.782 + (raise error ("prep_pbt: more than one '#Where' in "^
16.783 + (strs2str metID))));
16.784 + val sc = (((inst_abs thy) o term_of o the o (parse thy)) scr)
16.785 + in ({guh=guh,mathauthors=maa,init=init,
16.786 + ppc=gi@fi@re, pre=wh, rew_ord'=ro, erls=rls, srls=srls, prls=prls,
16.787 + calc = if scr = "empty_script" then []
16.788 + else ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
16.789 + (filter is_calc) o stacpbls) sc,
16.790 + crls=cr, nrls=nr, scr=Script sc}:met,
16.791 + metID:metID)
16.792 + end;
16.793 +
16.794 +
16.795 +(**. get pblIDs of all entries in mat3D .**)
16.796 +
16.797 +
16.798 +fun format_pblID strl = enclose " [" "]" (commas_quote strl);
16.799 +fun format_pblIDl strll = enclose "[\n" "\n]\n"
16.800 + (space_implode ",\n" (map format_pblID strll));
16.801 +
16.802 +fun scan _ [] = [] (* no base case, for empty doms only *)
16.803 + | scan id ((Ptyp ((i,_,[])))::[]) = [id@[i]]
16.804 + | scan id ((Ptyp ((i,_,pl)))::[]) = scan (id@[i]) pl
16.805 + | scan id ((Ptyp ((i,_,[])))::ps) = [id@[i]] @(scan id ps)
16.806 + | scan id ((Ptyp ((i,_,pl)))::ps) =(scan (id@[i]) pl)@(scan id ps);
16.807 +
16.808 +fun show_ptyps () = (writeln o format_pblIDl o (scan [])) (!ptyps);
16.809 +(* ptyps:=[];
16.810 + show_ptyps();
16.811 + *)
16.812 +fun show_mets () = (writeln o format_pblIDl o (scan [])) (!mets);
16.813 +
16.814 +
16.815 +
16.816 +(*vvvvv---------- preparational work 8.01. UNUSED *)
16.817 +(**+ instantiate a problem-type +**)
16.818 +
16.819 +(*+ transform oris +*)
16.820 +
16.821 +fun coll_vats (vats, ((_,vs,_,_,_):ori)) = union op = vats vs;
16.822 +(*> coll_vats [11,22] (hd oris);
16.823 +val it = [22,11,1,2,3] : int list
16.824 +
16.825 +> foldl coll_vats ([],oris);
16.826 +val it = [1,2,3] : int list
16.827 +
16.828 +> val i=1;
16.829 +> filter ((curry (op mem) i) o #2) oris;
16.830 +val it =
16.831 + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
16.832 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
16.833 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
16.834 + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
16.835 + (6,[1],"#undef",Const (#,#),[Free #]),
16.836 + (9,[1,2],"#undef",Const (#,#),[# $ #]),
16.837 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])] : ori list *)
16.838 +
16.839 +local infix mem; (*from Isabelle2002*)
16.840 +fun x mem [] = false
16.841 + | x mem (y :: ys) = x = y orelse x mem ys;
16.842 +in
16.843 +fun filter_vat oris i =
16.844 + filter ((curry (op mem) i) o (#2 : ori -> int list)) oris;
16.845 +end;
16.846 +(*> map (filter_vat oris) [1,2,3];
16.847 +val it =
16.848 + [[(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
16.849 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
16.850 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
16.851 + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
16.852 + (6,[1],"#undef",Const (#,#),[Free #]),
16.853 + (9,[1,2],"#undef",Const (#,#),[# $ #]),
16.854 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])],
16.855 + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
16.856 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
16.857 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
16.858 + (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
16.859 + (7,[2],"#undef",Const (#,#),[Free #]),
16.860 + (9,[1,2],"#undef",Const (#,#),[# $ #]),
16.861 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])],
16.862 + [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
16.863 + (2,[1,2,3],"#Find",Const (#,#),[Free #]),
16.864 + (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
16.865 + (5,[3],"#Relate",Const (#,#),[# $ #,# $ #,# $ #]),
16.866 + (8,[3],"#undef",Const (#,#),[Free #]),
16.867 + (10,[3],"#undef",Const (#,#),[# $ #]),
16.868 + (11,[1,2,3],"#undef",Const (#,#),[# $ #])]] : ori list list*)
16.869 +
16.870 +fun separate_vats oris =
16.871 + let val vats = foldl coll_vats ([] : int list, oris);
16.872 + in map (filter_vat oris) vats end;
16.873 +(*^^^ end preparational work 8.01.*)
16.874 +
16.875 +
16.876 +
16.877 +(**. check a problem (ie. itm list) for matching a problemtype .**)
16.878 +
16.879 +fun eq1 d (_,(d',_)) = (d = d');
16.880 +fun itm_id ((i,_,_,_,_):itm) = i;
16.881 +fun ori_id ((i,_,_,_,_):ori) = i;
16.882 +fun ori2itmSup ((i,v,_,d,ts):ori) = ((i,v,true,"#Given",Sup(d,ts)):itm);
16.883 +(*see + add_sel_ppc ~~~~~~~*)
16.884 +fun field_eq f ((_,_,f',_,_):ori) = f = f';
16.885 +
16.886 +(*. check an item (with arbitrary itm_ from previous matchings)
16.887 + for matching a problemtype; returns true only for itms found in pbt .*)
16.888 +fun chk_ thy pbt ((i,vats,b,f,Cor ((d,vs),_)):itm) =
16.889 + (case find_first (eq1 d) pbt of
16.890 + SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
16.891 + (id, pbl_ids' thy d vs))):itm)
16.892 + | NONE => (i,vats,false,f,Sup (d,vs)))
16.893 + | chk_ thy pbt ((i,vats,b,f,Inc ((d,vs),_)):itm) =
16.894 + (case find_first (eq1 d) pbt of
16.895 + SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
16.896 + (id, pbl_ids' thy d vs))):itm)
16.897 + | NONE => (i,vats,false,f,Sup (d,vs)))
16.898 +
16.899 + | chk_ thy pbt (itm as (i,vats,b,f,Syn ct):itm) = itm
16.900 + | chk_ thy pbt (itm as (i,vats,b,f,Typ ct):itm) = itm
16.901 +
16.902 + | chk_ thy pbt ((i,vats,b,f,Sup (d,vs)):itm) =
16.903 + (case find_first (eq1 d) pbt of
16.904 + SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
16.905 + (id, pbl_ids' thy d vs))):itm)
16.906 + | NONE => (i,vats,false,f,Sup (d,vs)))
16.907 +(* val (i,vats,b,f,Mis (d,vs)) = i4;
16.908 + *)
16.909 + | chk_ thy pbt ((i,vats,b,f,Mis (d,vs)):itm) =
16.910 + (case find_first (eq1 d) pbt of
16.911 +(* val SOME (_,(_,id)) = find_first (eq1 d) pbt;
16.912 + *)
16.913 + SOME (_,(_,id)) => raise error "chk_: ((i,vats,b,f,Cor ((d,vs),\
16.914 + \(id, pbl_ids' d vs))):itm)"
16.915 + | NONE => (i,vats,false,f,Sup (d,[vs])));
16.916 +
16.917 +(* chk_ thy pbt i
16.918 + *)
16.919 +
16.920 +fun eq2 (_,(d,_)) ((_,_,_,_,itm_):itm) = d = d_in itm_;
16.921 +fun eq2' (_,(d,_)) ((_,_,_,d',_):ori) = d = d';
16.922 +fun eq0 ((0,_,_,_,_):itm) = true
16.923 + | eq0 _ = false;
16.924 +fun max_i i [] = i
16.925 + | max_i i ((id,_,_,_,_)::is) =
16.926 + if i > id then max_i i is else max_i id is;
16.927 +fun max_id [] = 0
16.928 + | max_id ((id,_,_,_,_)::is) = max_i id is;
16.929 +fun add_idvat itms _ _ [] = itms
16.930 + | add_idvat itms i mvat (((_,_,b,f,itm_):itm)::its) =
16.931 + add_idvat (itms @ [(i,[(*mvat ...meaningless with pbl-identifier *)
16.932 + ],b,f,itm_):itm]) (i+1) mvat its;
16.933 +
16.934 +
16.935 +(*. find elements of pbt not contained in itms;
16.936 + if such one is untouched, return this one, otherwise create new itm .*)
16.937 +fun chk_m (itms:itm list) untouched (p as (f,(d,id))) =
16.938 + case find_first (eq2 p) itms of
16.939 + SOME _ => []
16.940 + | NONE => (case find_first (eq2 p) untouched of
16.941 + SOME itm => [itm]
16.942 + | NONE => [(0,[],false,f,Mis (d,id)):itm]);
16.943 +(* val itms = itms'';
16.944 + *)
16.945 +fun chk_mis mvat itms untouched pbt =
16.946 + let val mis = (flat o (map (chk_m itms untouched))) pbt;
16.947 + val mid = max_id itms;
16.948 + in add_idvat [] (mid + 1) mvat mis end;
16.949 +
16.950 +(*. check a problem (ie. itm list) for matching a problemtype,
16.951 + takes the max_vt for concluding completeness (could be another!) .*)
16.952 +(* val itms = itms'; val (pbt,pre) = (ppc, pre);
16.953 + val itms = itms; val (pbt,pre) = (ppc, pre);
16.954 + *)
16.955 +fun match_itms thy itms (pbt,pre,prls) =
16.956 + (let fun okv mvat (_,vats,b,_,_) = member op = vats mvat
16.957 + andalso b;
16.958 + val itms' = map (chk_ thy pbt) itms; (*all found are #3 true*)
16.959 + val mvat = max_vt itms';
16.960 + val itms'' = filter (okv mvat) itms';
16.961 + val untouched = filter eq0 itms;(*i.e. dsc only (from init)*)
16.962 + val mis = chk_mis mvat itms'' untouched pbt;
16.963 + val pre' = check_preconds' prls pre itms'' mvat
16.964 + val pb = foldl and_ (true, map fst pre')
16.965 + in (length mis = 0 andalso pb, (itms'@ mis, pre')) end);
16.966 +
16.967 +(*. check a problem pbl (ie. itm list) for matching a problemtype pbt,
16.968 + for missing items get data from formalization (ie. ori list);
16.969 + takes the max_vt for concluding completeness (could be another!) .*)
16.970 +(* (0) determine the most frequent variant mv in pbl
16.971 + ALL pbt. (1) dsc(pbt) notmem dsc(pbls) =>
16.972 + (2) filter (dsc(pbt) = dsc(oris)) oris; -> news;
16.973 + (3) newitms = filter (mv mem vat(news)) news
16.974 + (4) pbt @ newitms *)
16.975 +(* val (pbl, pbt, pre) = (met, mtt, pre);
16.976 + val (pbl, pbt, pre) = (itms, #ppc pbt, #where_ pbt);
16.977 + val (pbl, pbt, pre) = (itms, ppc, where_);
16.978 + *)
16.979 +fun match_itms_oris thy (pbl:itm list) (pbt, pre, prls) oris =
16.980 + let
16.981 + (*0*)val mv = max_vt pbl;
16.982 +
16.983 + fun eqdsc_pbt_itm ((_,(d,_))) ((_,_,_,_,itm_):itm) = d = d_in itm_;
16.984 + fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of
16.985 + SOME _ => false | NONE => true;
16.986 + (*1*)val mis = (*(map (cons2 (fst, fst o snd)))o*) (filter (notmem pbl)) pbt;
16.987 +
16.988 + fun eqdsc_ori (_,(d,_)) ((_,_,_,d',_):ori) = d = d';
16.989 + fun ori2itmMis (f,(d,pid)) ((i,v,_,_,ts):ori) =
16.990 + (i,v,false,f,Mis (d,pid)):itm;
16.991 + (*2*)fun oris2itms oris mis1 =
16.992 + ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris;
16.993 + val news = (flat o (map (oris2itms oris))) mis;
16.994 + (*3*)fun mem_vat (_,vats,b,_,_) = member op = vats mv;
16.995 + val newitms = filter mem_vat news;
16.996 + (*4*)val itms' = pbl @ newitms;
16.997 + val pre' = check_preconds' prls pre itms' mv
16.998 + val pb = foldl and_ (true, map fst pre')
16.999 + in (length mis = 0 andalso pb, (itms', pre')) end;
16.1000 + (*handle _ => (false,([],[]))*);
16.1001 +
16.1002 +
16.1003 +(*vvv--- doubled 20.9.01: ... 7.3.02 itms --> oris, because oris
16.1004 + allow for faster access to descriptions and terms *)
16.1005 +(**. check a problem (ie. itm list) for matching a problemtype .**)
16.1006 +
16.1007 +(*. check an ori for matching a problemtype by description;
16.1008 + returns true only for itms found in pbt .*)
16.1009 +fun chk1_ thy pbt ((i,vats,f,d,vs):ori) =
16.1010 + case find_first (eq1 d) pbt of
16.1011 + SOME (_,(_,id)) => [(i,vats,true,f,
16.1012 + Cor ((d,vs), (id, pbl_ids' thy d vs))):itm]
16.1013 + | NONE => [];
16.1014 +
16.1015 +(* elem 'p' of pbt contained in itms ? *)
16.1016 +fun chk1_m (itms:itm list) p =
16.1017 + case find_first (eq2 p) itms of
16.1018 + SOME _ => true | NONE => false;
16.1019 +fun chk1_m' (oris: ori list) (p as (f,(d,t))) =
16.1020 + case find_first (eq2' p) oris of
16.1021 + SOME _ => []
16.1022 + | NONE => [(f, Mis (d, t))];
16.1023 +fun pair0vatsfalse (f,itm_) = (0,[],false,f,itm_):itm;
16.1024 +
16.1025 +fun chk1_mis mvat itms ppc = foldl and_ (true, map (chk1_m itms) ppc);
16.1026 +fun chk1_mis' oris ppc =
16.1027 + map pair0vatsfalse ((flat o (map (chk1_m' oris))) ppc);
16.1028 +
16.1029 +
16.1030 +(*. check a problem (ie. ori list) for matching a problemtype,
16.1031 + takes the max_vt for concluding completeness (FIXME could be another!) .*)
16.1032 +(* val (prls,oris,pbt,pre)=(#prls py, ori, #ppc py, #where_ py);
16.1033 + *)
16.1034 +fun match_oris thy prls oris (pbt,pre) =
16.1035 + let val itms = (flat o (map (chk1_ thy pbt))) oris;
16.1036 + val mvat = max_vt itms;
16.1037 + val complete = chk1_mis mvat itms pbt;
16.1038 + val pre' = check_preconds' prls pre itms mvat
16.1039 + val pb = foldl and_ (true, map fst pre')
16.1040 + in if complete andalso pb then true else false end;
16.1041 +(*run subp-rooteq.sml 'root-eq + subpbl: solve_linear'
16.1042 + until 'val nxt = ("Model_Problem",Model_Problem ["linear","univariate"...
16.1043 +> val Nd(PblObj _,[_,_,_,_,_,_,_,_,_,_,_,
16.1044 + Nd(PblObj{origin=(oris,_,_),...},[])]) = pt;
16.1045 +> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"],
16.1046 + (#where_ o get_pbt) ["linear","univariate","equation"]);
16.1047 +> match_oris oris (pbt,pre);
16.1048 +val it = true : bool
16.1049 +
16.1050 +
16.1051 +> val (pbt,pre) =((#ppc o get_pbt) ["plain_square","univariate","equation"],
16.1052 + (#where_ o get_pbt)["plain_square","univariate","equation"]);
16.1053 +> match_oris oris (pbt,pre);
16.1054 +val it = false : bool
16.1055 +
16.1056 +
16.1057 + ---------------------------------------------------
16.1058 + run subp-rooteq.sml 'root-eq + subpbl: solve_plain_square'
16.1059 + until 'val nxt = ("Model_Problem",Model_Problem ["plain_square","univ...
16.1060 +> val Nd (PblObj _, [_,_,_,_,_,_,_,Nd (PrfObj _,[]),
16.1061 + Nd (PblObj {origin=(oris,_,_),...},[])]) = pt;
16.1062 +> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"],
16.1063 + (#where_ o get_pbt) ["linear","univariate","equation"]);
16.1064 +> match_oris oris (pbt,pre);
16.1065 +val it = false : bool
16.1066 +
16.1067 +
16.1068 +> val (pbt,pre)=((#ppc o get_pbt) ["plain_square","univariate","equation"],
16.1069 + (#where_ o get_pbt) ["plain_square","univariate","equation"]);
16.1070 +> match_oris oris (pbt,pre);
16.1071 +val it = true : bool
16.1072 +*)
16.1073 +(*^^^--- doubled 20.9.01 *)
16.1074 +
16.1075 +
16.1076 +(*. check a problem (ie. ori list) for matching a problemtype,
16.1077 + returns items for output to math-experts .*)
16.1078 +(* val (ppc,pre) = (#ppc py, #where_ py);
16.1079 + *)
16.1080 +fun match_oris' thy oris (ppc,pre,prls) =
16.1081 +(* val (thy, oris, (ppc,pre,prls)) = (thy, oris, (ppc, where_, prls));
16.1082 + *)
16.1083 + let val itms = (flat o (map (chk1_ thy ppc))) oris;
16.1084 + val sups = ((map ori2itmSup) o (filter(field_eq "#undef")))oris;
16.1085 + val mvat = max_vt itms;
16.1086 + val miss = chk1_mis' oris ppc;
16.1087 + val pre' = check_preconds' prls pre itms mvat
16.1088 + val pb = foldl and_ (true, map fst pre')
16.1089 + in (miss = [] andalso pb, (itms @ miss @ sups, pre')) end;
16.1090 +
16.1091 +(*. for the user .*)
16.1092 +datatype match' =
16.1093 + Matches' of item ppc
16.1094 +| NoMatch' of item ppc;
16.1095 +
16.1096 +(*. match a formalization with a problem type .*)
16.1097 +fun match_pbl (fmz:fmz_) ({thy=thy,where_=pre,ppc,prls=er,...}:pbt) =
16.1098 + let val oris = prep_ori fmz thy ppc;
16.1099 + val (bool, (itms, pre')) = match_oris' thy oris (ppc,pre,er);
16.1100 + in if bool then Matches' (itms2itemppc thy itms pre')
16.1101 + else NoMatch' (itms2itemppc thy itms pre') end;
16.1102 +(*
16.1103 +val fmz = ["equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))",
16.1104 + "solveFor x","errorBound (eps=0)","solutions L"];
16.1105 +val pbt as {thy = thy, where_ = pre, ppc = ppc,...} =
16.1106 + get_pbt ["univariate","equation"];
16.1107 +match_pbl fmz pbt;
16.1108 +*)
16.1109 +
16.1110 +
16.1111 +(*. refine a problem; construct pblRD while scanning .*)
16.1112 +(* val (pblRD,ori)=("xxx",oris);
16.1113 + val py = get_pbt ["equation"];
16.1114 + val py = get_pbt ["univariate","equation"];
16.1115 + val py = get_pbt ["linear","univariate","equation"];
16.1116 + val py = get_pbt ["root","univariate","equation"];
16.1117 + match_oris (#prls py) ori (#ppc py, #where_ py);
16.1118 +
16.1119 + *)
16.1120 +fun refin (pblRD:pblRD) ori
16.1121 +((Ptyp (pI,[py],[])):pbt ptyp) =
16.1122 + if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py)
16.1123 + then SOME ((pblRD @ [pI]):pblRD)
16.1124 + else NONE
16.1125 + | refin pblRD ori (Ptyp (pI,[py],pys)) =
16.1126 + if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py)
16.1127 + then (case refins (pblRD @ [pI]) ori pys of
16.1128 + SOME pblRD' => SOME pblRD'
16.1129 + | NONE => SOME (pblRD @ [pI]))
16.1130 + else NONE
16.1131 +and refins pblRD ori [] = NONE
16.1132 + | refins pblRD ori ((p as Ptyp (pI,_,_))::pts) =
16.1133 + (case refin pblRD ori p of
16.1134 + SOME pblRD' => SOME pblRD'
16.1135 + | NONE => refins pblRD ori pts);
16.1136 +
16.1137 +(*. refine a problem; version providing output for math-experts .*)
16.1138 +fun refin' (pblRD:pblRD) fmz pbls ((Ptyp (pI,[py],[])):pbt ptyp) =
16.1139 +(* val ((pblRD:pblRD), fmz, pbls, ((Ptyp (pI,[py],[])):pbt ptyp)) =
16.1140 + (rev ["linear","system"], fmz, [(*match list*)],
16.1141 + ((Ptyp ("2x2",[get_pbt ["2x2","linear","system"]],[])):pbt ptyp));
16.1142 + *)
16.1143 + let val _ = (writeln o ((curry op^)"*** pass ") o strs2str)(pblRD @ [pI])
16.1144 + val {thy,ppc,where_,prls,...} = py
16.1145 + val oris = prep_ori fmz thy ppc
16.1146 + (*8.3.02: itms!: oris ev. are _not_ complete here*)
16.1147 + val (b, (itms, pre')) = match_oris' thy oris (ppc, where_, prls)
16.1148 + in if b then pbls @ [Matches (rev (pblRD @ [pI]),
16.1149 + itms2itemppc thy itms pre')]
16.1150 + else pbls @ [NoMatch (rev (pblRD @ [pI]),
16.1151 + itms2itemppc thy itms pre')]
16.1152 + end
16.1153 +(* val pblRD = ["pbla"]; val fmz = fmz1; val pbls = [];
16.1154 + val Ptyp (pI,[py],pys) = hd (!ptyps);
16.1155 + refin' pblRD fmz pbls (Ptyp (pI,[py],pys));
16.1156 +*)
16.1157 + | refin' pblRD fmz pbls (Ptyp (pI,[py],pys)) =
16.1158 + let val _ = (writeln o ((curry op^)"*** pass ") o strs2str) (pblRD @ [pI])
16.1159 + val {thy,ppc,where_,prls,...} = py
16.1160 + val oris = prep_ori fmz thy ppc;
16.1161 + (*8.3.02: itms!: oris ev. are _not_ complete here*)
16.1162 + val(b, (itms, pre')) = match_oris' thy oris (ppc,where_,prls);
16.1163 + in if b
16.1164 + then let val pbl = Matches (rev (pblRD @ [pI]),
16.1165 + itms2itemppc thy itms pre')
16.1166 + in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end
16.1167 + else (pbls @ [NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')])
16.1168 + end
16.1169 +and refins' pblRD fmz pbls [] = pbls
16.1170 + | refins' pblRD fmz pbls ((p as Ptyp (pI,_,_))::pts) =
16.1171 + let val pbls' = refin' pblRD fmz pbls p
16.1172 + in case last_elem pbls' of
16.1173 + Matches _ => pbls'
16.1174 + | NoMatch _ => refins' pblRD fmz pbls' pts end;
16.1175 +
16.1176 +(*. refine a problem; version for tactic Refine_Problem .*)
16.1177 +fun refin'' thy (pblRD:pblRD) itms pbls ((Ptyp (pI,[py],[])):pbt ptyp) =
16.1178 + let (*val _ = writeln("### refin''1: pI="^pI);*)
16.1179 + val {thy,ppc,where_,prls,...} = py
16.1180 + val (b, (itms', pre')) = match_itms thy itms (ppc,where_,prls);
16.1181 + in if b then pbls @ [Match_ (rev (pblRD @ [pI]), (itms', pre'))]
16.1182 + else pbls @ [NoMatch_]
16.1183 + end
16.1184 +(* val pblRD = (rev o tl) pblID; val pbls = [];
16.1185 + val Ptyp (pI,[py],pys) = app_ptyp I pblID (rev pblID) (!ptyps);
16.1186 + *)
16.1187 + | refin'' thy pblRD itms pbls (Ptyp (pI,[py],pys)) =
16.1188 + let (*val _ = writeln("### refin''2: pI="^pI);*)
16.1189 + val {thy,ppc,where_,prls,...} = py
16.1190 + val(b, (itms', pre')) = match_itms thy itms (ppc,where_,prls);
16.1191 + in if b
16.1192 + then let val pbl = Match_ (rev (pblRD @ [pI]), (itms', pre'))
16.1193 + in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end
16.1194 + else (pbls @ [NoMatch_])
16.1195 + end
16.1196 +and refins'' thy pblRD itms pbls [] = pbls
16.1197 + | refins'' thy pblRD itms pbls ((p as Ptyp (pI,_,_))::pts) =
16.1198 + let val pbls' = refin'' thy pblRD itms pbls p
16.1199 + in case last_elem pbls' of
16.1200 + Match_ _ => pbls'
16.1201 + | NoMatch_ => refins'' thy pblRD itms pbls' pts end;
16.1202 +
16.1203 +
16.1204 +(*. apply a fun to a ptyps node; copied from get_py .*)
16.1205 +fun app_ptyp f (d:pblID) _ [] =
16.1206 + raise error ("app_ptyp not found: "^(strs2str d))
16.1207 + | app_ptyp f d (k::[]) ((p as Ptyp (k',[py],_))::pys) =
16.1208 + if k=k' then f p
16.1209 + else app_ptyp f d ([k]:pblRD) pys
16.1210 + | app_ptyp f d (k::ks) ((Ptyp (k',_,pys))::pys') =
16.1211 + if k=k' then app_ptyp f d ks pys
16.1212 + else app_ptyp f d (k::ks) pys';
16.1213 +
16.1214 +(*. for tactic Refine_Tacitly .*)
16.1215 +(*!!! oris are already created wrt. some pbt; pbt contains thy for parsing*)
16.1216 +(* val (thy,pblID) = (assoc_thy dI',pI);
16.1217 + *)
16.1218 +fun refine_ori oris (pblID:pblID) =
16.1219 + let val opt = app_ptyp (refin ((rev o tl) pblID) oris)
16.1220 + pblID (rev pblID) (!ptyps);
16.1221 + in case opt of
16.1222 + SOME pblRD => let val (pblID':pblID) =(rev pblRD)
16.1223 + in if pblID' = pblID then NONE
16.1224 + else SOME pblID' end
16.1225 + | NONE => NONE end;
16.1226 +fun refine_ori' oris pI = (the (refine_ori oris pI)) handle _ => pI;
16.1227 +
16.1228 +(*. for tactic Refine_Problem .*);
16.1229 +(* 10.03: returnvalue -> (pIrefined, itm list) would be sufficient *)
16.1230 +(* val pblID = pI; app_ptyp I pblID (rev pblID) (!ptyps);
16.1231 + *)
16.1232 +fun refine_pbl thy (pblID:pblID) itms =
16.1233 + case refined_ (app_ptyp (refin'' thy ((rev o tl) pblID) itms [])
16.1234 + pblID (rev pblID) (!ptyps)) of
16.1235 + NONE => NONE
16.1236 + | SOME (Match_ (rfd as (pI',_))) =>
16.1237 + if pblID = pI' then NONE else SOME rfd;
16.1238 +
16.1239 +
16.1240 +(*. for math-experts .*)
16.1241 +(*19.10.02FIXME: needs thy for parsing fmz*)
16.1242 +(* val fmz = fmz1; val pblID = ["pbla"]; val pblRD = (rev o tl) pblID;
16.1243 + val pbls = []; val ptys = !ptyps;
16.1244 + *)
16.1245 +fun refine (fmz:fmz_) (pblID:pblID) =
16.1246 + app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID) (!ptyps);
16.1247 +
16.1248 +
16.1249 +(*.make a guh from a reference to an element in the kestore;
16.1250 + EXCEPT theory hierarchy ... compare 'fun keref2xml'.*)
16.1251 +fun pblID2guh (pblID:pblID) =
16.1252 + (((#guh o get_pbt) pblID)
16.1253 + handle _ => raise error ("pblID2guh: not for '"^strs2str' pblID ^ "'"));
16.1254 +fun metID2guh (metID:metID) =
16.1255 + (((#guh o get_met) metID)
16.1256 + handle _ => raise error ("metID2guh: no 'Met_' for '"^
16.1257 + strs2str' metID ^ "'"));
16.1258 +fun kestoreID2guh Pbl_ (kestoreID:kestoreID) = pblID2guh kestoreID
16.1259 + | kestoreID2guh Met_ (kestoreID:kestoreID) = metID2guh kestoreID
16.1260 + | kestoreID2guh ketype kestoreID =
16.1261 + raise error ("kestoreID2guh: '" ^ ketype2str ketype ^ "' not for '" ^
16.1262 + strs2str' kestoreID ^ "'");
16.1263 +
16.1264 +fun show_pblguhs () =
16.1265 + (print_depth 999;
16.1266 + (writeln o strs2str o (map linefeed)) (coll_pblguhs (!ptyps));
16.1267 + print_depth 3);
16.1268 +fun sort_pblguhs () =
16.1269 + (print_depth 999;
16.1270 + (writeln o strs2str o (map linefeed))
16.1271 + (((sort string_ord) o coll_pblguhs) (!ptyps));
16.1272 + print_depth 3);
16.1273 +
16.1274 +fun show_metguhs () =
16.1275 + (print_depth 999;
16.1276 + (writeln o strs2str o (map linefeed)) (coll_metguhs (!mets));
16.1277 + print_depth 3);
16.1278 +fun sort_metguhs () =
16.1279 + (print_depth 999;
16.1280 + (writeln o strs2str o (map linefeed))
16.1281 + (((sort string_ord) o coll_metguhs) (!mets));
16.1282 + print_depth 3);
17.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2 +++ b/src/Tools/isac/Interpret/rewtools.sml Wed Aug 25 16:20:07 2010 +0200
17.3 @@ -0,0 +1,845 @@
17.4 +(* tools for rewriting, reverse rewriting, context to thy concerning rewriting
17.5 + authors: Walther Neuper 2002, 2006
17.6 + (c) due to copyright terms
17.7 +
17.8 +use"ME/rewtools.sml";
17.9 +use"rewtools.sml";
17.10 +*)
17.11 +
17.12 +
17.13 +
17.14 +(***.reverse rewriting.***)
17.15 +
17.16 +(*.derivation for insertin one level of nodes into the calctree.*)
17.17 +type deriv = (term * rule * (term *term list)) list;
17.18 +
17.19 +fun trta2str (t,r,(t',a)) = "\n("^(term2str t)^", "^(rule2str' r)^", ("^
17.20 + (term2str t')^", "^(terms2str a)^"))";
17.21 +fun trtas2str trtas = (strs2str o (map trta2str)) trtas;
17.22 +val deriv2str = trtas2str;
17.23 +fun rta2str (r,(t,a)) = "\n("^(rule2str' r)^", ("^
17.24 + (term2str t)^", "^(terms2str a)^"))";
17.25 +fun rtas2str rtas = (strs2str o (map rta2str)) rtas;
17.26 +val deri2str = rtas2str;
17.27 +
17.28 +
17.29 +(*.A1==>...==>An==>(Lhs = Rhs) goes to A1==>...==>An==>(Rhs = Lhs).*)
17.30 +fun sym_thm thm =
17.31 + let
17.32 + val (deriv, {thy_ref = thy_ref, tags = tags, maxidx = maxidx,
17.33 + shyps = shyps, hyps = hyps, tpairs = tpairs,
17.34 + prop = prop}) =
17.35 + rep_thm_G thm;
17.36 + val (lhs,rhs) = (dest_equals' o strip_trueprop
17.37 + o Logic.strip_imp_concl) prop;
17.38 + val prop' = case strip_imp_prems' prop of
17.39 + NONE => Trueprop $ (mk_equality (rhs, lhs))
17.40 + | SOME cs =>
17.41 + ins_concl cs (Trueprop $ (mk_equality (rhs, lhs)));
17.42 + in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end;
17.43 +(*
17.44 + (sym RS real_mult_div_cancel1) handle e => print_exn e;
17.45 +Exception THM 1 raised:
17.46 +RSN: no unifiers
17.47 +"?s = ?t ==> ?t = ?s"
17.48 +"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n"
17.49 +
17.50 + val thm = real_mult_div_cancel1;
17.51 + val prop = (#prop o rep_thm) thm;
17.52 + atomt prop;
17.53 + val ppp = Logic.strip_imp_concl prop;
17.54 + atomt ppp;
17.55 + ((#prop o rep_thm o sym_thm o sym_thm) thm) = (#prop o rep_thm) thm;
17.56 +val it = true : bool
17.57 + ((sym_thm o sym_thm) thm) = thm;
17.58 +val it = true : bool
17.59 +
17.60 + val thm = real_le_anti_sym;
17.61 + ((sym_thm o sym_thm) thm) = thm;
17.62 +val it = true : bool
17.63 +
17.64 + val thm = real_minus_zero;
17.65 + ((sym_thm o sym_thm) thm) = thm;
17.66 +val it = true : bool
17.67 +*)
17.68 +
17.69 +
17.70 +
17.71 +(*.derive normalform of a rls, or derive until SOME goal,
17.72 + and record rules applied and rewrites.
17.73 +val it = fn
17.74 + : theory
17.75 + -> rls
17.76 + -> rule list
17.77 + -> rew_ord : the order of this rls, which 1 theorem of is used
17.78 + for rewriting 1 single step (?14.4.03)
17.79 + -> term option : 040214 ??? nonsense ???
17.80 + -> term
17.81 + -> (term * : to this term ...
17.82 + rule * : ... this rule is applied yielding ...
17.83 + (term * : ... this term ...
17.84 + term list)) : ... under these assumptions.
17.85 + list :
17.86 +returns empty list for a normal form
17.87 +FIXME.WN040214: treats rules as in Rls, _not_ as in Seq
17.88 +
17.89 +WN060825 too complicated for the intended use by cancel_, common_nominator_
17.90 +and unreflectedly adapted to extion of rules by Rls_: returns Rls_("sym_simpl..
17.91 + -- replaced below*)
17.92 +(* val (thy, erls, rs, ro, goal, tt) = (thy, erls, rs, ro, goal, t);
17.93 + val (thy, erls, rs, ro, goal, tt) = (thy, Atools_erls, rules, ro, NONE, tt);
17.94 + *)
17.95 +fun make_deriv thy erls (rs:rule list) ro(*rew_ord*) goal tt =
17.96 + let datatype switch = Appl | Noap
17.97 + fun rew_once lim rts t Noap [] =
17.98 + (case goal of
17.99 + NONE => rts
17.100 + | SOME g =>
17.101 + raise error ("make_deriv: no derivation for "^(term2str t)))
17.102 + | rew_once lim rts t Appl [] =
17.103 + (*(case rs of Rls _ =>*) rew_once lim rts t Noap rs
17.104 + (*| Seq _ => rts) FIXXXXXME 14.3.03*)
17.105 + | rew_once lim rts t apno rs' =
17.106 + (case goal of
17.107 + NONE => rew_or_calc lim rts t apno rs'
17.108 + | SOME g =>
17.109 + if g = t then rts
17.110 + else rew_or_calc lim rts t apno rs')
17.111 + and rew_or_calc lim rts t apno (rrs' as (r::rs')) =
17.112 + if lim < 0
17.113 + then (writeln ("make_deriv exceeds " ^ int2str (!lim_deriv) ^
17.114 + "with deriv =\n"); writeln (deriv2str rts); rts)
17.115 + else
17.116 + case r of
17.117 + Thm (thmid, tm) =>
17.118 + (if not (!trace_rewrite) then () else
17.119 + writeln ("### trying thm '" ^ thmid ^ "'");
17.120 + case rewrite_ thy ro erls true tm t of
17.121 + NONE => rew_once lim rts t apno rs'
17.122 + | SOME (t',a') =>
17.123 + (if ! trace_rewrite
17.124 + then writeln ("### rewrites to: "^(term2str t')) else();
17.125 + rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs'))
17.126 + | Calc (c as (op_,_)) =>
17.127 + let val _ = if not (!trace_rewrite) then () else
17.128 + writeln ("### trying calc. '" ^ op_ ^ "'")
17.129 + val t = uminus_to_string t
17.130 + in case get_calculation_ thy c t of
17.131 + NONE => rew_once lim rts t apno rs'
17.132 + | SOME (thmid, tm) =>
17.133 + (let val SOME (t',a') = rewrite_ thy ro erls true tm t
17.134 + val _ = if not (!trace_rewrite) then () else
17.135 + writeln("### calc. to: " ^ (term2str t'))
17.136 + val r' = Thm (thmid, tm)
17.137 + in rew_once (lim-1) (rts@[(t,r',(t',a'))]) t' Appl rrs'
17.138 + end)
17.139 + handle _ => raise error "derive_norm, Calc: no rewrite"
17.140 + end
17.141 +(* TODO.WN080222: see rewrite__set_
17.142 + @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
17.143 + | Cal1 (cc as (op_,_)) =>
17.144 + (let val _= if !trace_rewrite andalso i < ! depth then
17.145 + writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else ();
17.146 + val ct = uminus_to_string ct
17.147 + in case get_calculation_ thy cc ct of
17.148 + NONE => (ct, asm)
17.149 + | SOME (thmid, thm') =>
17.150 + let
17.151 + val pairopt =
17.152 + rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
17.153 + ((#erls o rep_rls) rls) put_asm thm' ct;
17.154 + val _ = if pairopt <> NONE then ()
17.155 + else raise error("rewrite_set_, rewrite_ \""^
17.156 + (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE")
17.157 + val _ = if ! trace_rewrite andalso i < ! depth
17.158 + then writeln((idt"="(i+1))^" cal1. to: "^
17.159 + (term2str ((fst o the) pairopt)))
17.160 + else()
17.161 + in the pairopt end
17.162 + end)
17.163 +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
17.164 + | Rls_ rls =>
17.165 + (case rewrite_set_ thy true rls t of
17.166 + NONE => rew_once lim rts t apno rs'
17.167 + | SOME (t',a') =>
17.168 + rew_once (lim-1) (rts @ [(t,r,(t',a'))]) t' Appl rrs');
17.169 +(*WN060829 | Rls_ rls =>
17.170 + (case rewrite_set_ thy true rls t of
17.171 + NONE => rew_once lim rts t apno rs'
17.172 + | SOME (t',a') =>
17.173 + if ro [] (t, t') then rew_once lim rts t apno rs'
17.174 + else rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs');
17.175 +...lead to deriv = [] with make_polynomial.
17.176 +THERE IS SOMETHING DIFFERENT beetween rewriting with the code above
17.177 +and between rewriting with rewrite_set: with rules from make_polynomial and
17.178 +t = "(a^^^2 + -1*b^^^2) / (a^^^2 + -2*a*b + b^^^2)" the actual code
17.179 +leads to cycling Rls_ order_mult_rls_..Rls_ discard_parentheses_..Rls_ order..
17.180 +*)
17.181 + in rew_once (!lim_deriv) [] tt Noap rs end;
17.182 +
17.183 +
17.184 +(*.toggles the marker for 'fun sym_thm'.*)
17.185 +fun sym_thmID (thmID : thmID) =
17.186 + case explode thmID of
17.187 + "s"::"y"::"m"::"_"::id => implode id : thmID
17.188 + | id => "sym_"^thmID;
17.189 +(*
17.190 +> val thmID = "sym_real_mult_2";
17.191 +> sym_thmID thmID;
17.192 +val it = "real_mult_2" : string
17.193 +> val thmID = "real_num_collect";
17.194 +> sym_thmID thmID;
17.195 +val it = "sym_real_num_collect" : string*)
17.196 +fun sym_drop (thmID : thmID) =
17.197 + case explode thmID of
17.198 + "s"::"y"::"m"::"_"::id => implode id : thmID
17.199 + | id => thmID;
17.200 +fun is_sym (thmID : thmID) =
17.201 + case explode thmID of
17.202 + "s"::"y"::"m"::"_"::id => true
17.203 + | id => false;
17.204 +
17.205 +
17.206 +(*FIXXXXME.040219: detail has to handle Rls id="sym_..."
17.207 + by applying make_deriv, rev_deriv'; see concat_deriv*)
17.208 +fun sym_rls Erls = Erls
17.209 + | sym_rls (Rls {id, scr, calc, erls, srls, rules, rew_ord, preconds}) =
17.210 + Rls {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls,
17.211 + rules=rules, rew_ord=rew_ord, preconds=preconds}
17.212 + | sym_rls (Seq {id, scr, calc, erls, srls, rules, rew_ord, preconds}) =
17.213 + Seq {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls,
17.214 + rules=rules, rew_ord=rew_ord, preconds=preconds}
17.215 + | sym_rls (Rrls {id, scr, calc, erls, prepat, rew_ord}) =
17.216 + Rrls {id="sym_"^id, scr=scr, calc=calc, erls=erls, prepat=prepat,
17.217 + rew_ord=rew_ord};
17.218 +
17.219 +fun sym_Thm (Thm (thmID, thm)) = Thm (sym_thmID thmID, sym_thm thm)
17.220 + | sym_Thm (Rls_ rls) = Rls_ (*WN060825?!?*) (sym_rls rls)
17.221 + | sym_Thm r = raise error ("sym_Thm: not for "^(rule2str r));
17.222 +(*
17.223 + val th = Thm ("real_one_collect",num_str real_one_collect);
17.224 + sym_Thm th;
17.225 +val th =
17.226 + Thm ("real_one_collect","?m is_const ==> ?n + ?m * ?n = (1 + ?m) * ?n")
17.227 + : rule
17.228 +ML> val it =
17.229 + Thm ("sym_real_one_collect","?m is_const ==> (1 + ?m) * ?n = ?n + ?m * ?n")*)
17.230 +
17.231 +
17.232 +(*version for reverse rewrite used before 040214*)
17.233 +fun rev_deriv (t, r, (t', a)) = (sym_Thm r, (t, a));
17.234 +(* val (thy, erls, rs, ro, goal, t) = (thy, eval_rls, rules, ro, NONE, t');
17.235 + *)
17.236 +fun reverse_deriv thy erls (rs:rule list) ro(*rew_ord*) goal t =
17.237 + (rev o (map rev_deriv)) (make_deriv thy erls (rs:rule list) ro goal t);
17.238 +(*
17.239 + val rev_rew = reverse_deriv thy e_rls ;
17.240 + writeln(rtas2str rev_rew);
17.241 +*)
17.242 +
17.243 +fun eq_Thm (Thm (id1,_), Thm (id2,_)) = id1 = id2
17.244 + | eq_Thm (Thm (id1,_), _) = false
17.245 + | eq_Thm (Rls_ r1, Rls_ r2) = id_rls r1 = id_rls r2
17.246 + | eq_Thm (Rls_ r1, _) = false
17.247 + | eq_Thm (r1, r2) = raise error ("eq_Thm: called with '"^
17.248 + (rule2str r1)^"' '"^(rule2str r2)^"'");
17.249 +fun distinct_Thm r = gen_distinct eq_Thm r;
17.250 +
17.251 +fun eq_Thms thmIDs thm = (member op = thmIDs (id_of_thm thm))
17.252 + handle _ => false;
17.253 +
17.254 +
17.255 +(***. context to thy concerning rewriting .***)
17.256 +
17.257 +(*.create the unique handles and filenames for the theory-data.*)
17.258 +fun part2guh ([str]:theID) =
17.259 + (case str of
17.260 + "Isabelle" => "thy_isab_" ^ str ^ "-part" : guh
17.261 + | "IsacScripts" => "thy_scri_" ^ str ^ "-part"
17.262 + | "IsacKnowledge" => "thy_isac_" ^ str ^ "-part"
17.263 + | str => raise error ("thy2guh: called with '"^str^"'"))
17.264 + | part2guh theID = raise error ("part2guh called with theID = "
17.265 + ^ theID2str theID);
17.266 +fun part2filename str = part2guh str ^ ".xml" : filename;
17.267 +
17.268 +
17.269 +fun thy2guh ([part, thyID]:theID) =
17.270 + (case part of
17.271 + "Isabelle" => "thy_isab_" ^ thyID : guh
17.272 + | "IsacScripts" => "thy_scri_" ^ thyID
17.273 + | "IsacKnowledge" => "thy_isac_" ^ thyID
17.274 + | str => raise error ("thy2guh: called with '"^str^"'"))
17.275 + | thy2guh theID = raise error ("thy2guh called with '"^strs2str' theID^"'");
17.276 +fun thy2filename thy' = thy2guh thy' ^ ".xml" : filename;
17.277 +fun thypart2guh ([part, thyID, thypart]:theID) =
17.278 + case part of
17.279 + "Isabelle" => "thy_isab_" ^ thyID ^ "-" ^ thypart : guh
17.280 + | "IsacScripts" => "thy_scri_" ^ thyID ^ "-" ^ thypart
17.281 + | "IsacKnowledge" => "thy_isac_" ^ thyID ^ "-" ^ thypart
17.282 + | str => raise error ("thypart2guh: called with '"^str^"'");
17.283 +fun thypart2filename thy' = thypart2guh thy' ^ ".xml" : filename;
17.284 +
17.285 +(*.convert the data got via contextToThy to a globally unique handle
17.286 + there is another way to get the guh out of the 'theID' in the hierarchy.*)
17.287 +fun thm2guh (isa, thyID:thyID) (thmID:thmID) =
17.288 + case isa of
17.289 + "Isabelle" =>
17.290 + "thy_isab_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID : guh
17.291 + | "IsacKnowledge" =>
17.292 + "thy_isac_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
17.293 + | "IsacScripts" =>
17.294 + "thy_scri_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
17.295 + | str => raise error ("thm2guh called with isa = '"^isa^
17.296 + "' for thm = "^thmID^"'");
17.297 +fun thm2filename (isa_thyID: string * thyID) thmID =
17.298 + (thm2guh isa_thyID thmID) ^ ".xml" : filename;
17.299 +
17.300 +fun rls2guh (isa, thyID:thyID) (rls':rls') =
17.301 + case isa of
17.302 + "Isabelle" =>
17.303 + "thy_isab_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' : guh
17.304 + | "IsacKnowledge" =>
17.305 + "thy_isac_" ^ theory'2thyID thyID ^ "-rls-" ^ rls'
17.306 + | "IsacScripts" =>
17.307 + "thy_scri_" ^ theory'2thyID thyID ^ "-rls-" ^ rls'
17.308 + | str => raise error ("rls2guh called with isa = '"^isa^
17.309 + "' for rls = '"^rls'^"'");
17.310 + fun rls2filename (isa, thyID) rls' =
17.311 + rls2guh (isa, thyID) rls' ^ ".xml" : filename;
17.312 +
17.313 +fun cal2guh (isa, thyID:thyID) calID =
17.314 + case isa of
17.315 + "Isabelle" =>
17.316 + "thy_isab_" ^ theory'2thyID thyID ^ "-cal-" ^ calID : guh
17.317 + | "IsacKnowledge" =>
17.318 + "thy_isac_" ^ theory'2thyID thyID ^ "-cal-" ^ calID
17.319 + | "IsacScripts" =>
17.320 + "thy_scri_" ^ theory'2thyID thyID ^ "-cal-" ^ calID
17.321 + | str => raise error ("cal2guh called with isa = '"^isa^
17.322 + "' for cal = '"^calID^"'");
17.323 +fun cal2filename (isa, thyID:thyID) calID =
17.324 + cal2guh (isa, thyID:thyID) calID ^ ".xml" : filename;
17.325 +
17.326 +fun ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') =
17.327 + case isa of
17.328 + "Isabelle" =>
17.329 + "thy_isab_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' : guh
17.330 + | "IsacKnowledge" =>
17.331 + "thy_isac_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord'
17.332 + | "IsacScripts" =>
17.333 + "thy_scri_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord'
17.334 + | str => raise error ("ord2guh called with isa = '"^isa^
17.335 + "' for ord = '"^rew_ord'^"'");
17.336 +fun ord2filename (isa, thyID:thyID) (rew_ord':rew_ord') =
17.337 + ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') ^ ".xml" : filename;
17.338 +
17.339 +
17.340 +(**.set up isab_thm_thy in Isac.ML.**)
17.341 +
17.342 +fun rearrange (thyID, (thmID, thm)) = (thmID, (thyID, thm));
17.343 +fun rearrange_inv (thmID, (thyID, thm)) = (thyID, (thmID, thm));
17.344 +
17.345 +(*.lookup the missing theorems in some thy (of Isabelle).*)
17.346 +fun make_isa missthms thy =
17.347 + map (pair (theory2thyID thy))
17.348 + ((inter eq_thmI) missthms (PureThy.all_thms_of thy))
17.349 + : (thyID * (thmID * Thm.thm)) list;
17.350 +
17.351 +(*.separate handling of sym_thms.*)
17.352 +fun make_isab rlsthmsNOTisac isab_thys =
17.353 + let fun les ((s1,_), (s2,_)) = (s1 : string) < s2
17.354 + val notsym = filter_out (is_sym o #1) rlsthmsNOTisac
17.355 + val notsym_isab = (flat o (map (make_isa notsym))) isab_thys
17.356 +
17.357 + val sym = filter (is_sym o #1) rlsthmsNOTisac
17.358 +
17.359 + val symsym = map ((apfst sym_drop) o (apsnd sym_thm)) sym
17.360 + val symsym_isab = (flat o (map (make_isa symsym))) isab_thys
17.361 +
17.362 + val sym_isab = map (((apsnd o apfst) sym_drop) o
17.363 + ((apsnd o apsnd) sym_thm)) symsym_isab
17.364 +
17.365 + val isab = notsym_isab @ symsym_isab @ sym_isab
17.366 + in ((map rearrange) o (gen_sort les)) isab
17.367 + : (thmID * (thyID * Thm.thm)) list
17.368 + end;
17.369 +
17.370 +(*.which theory below thy' contains a theorem; this can be in isabelle !
17.371 +get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*)
17.372 +(* val (str, (_, thy)) = ("real_diff_minus", ("Root.thy", Root.thy));
17.373 + val (str, (_, thy)) = ("real_diff_minus", ("Poly.thy", Poly.thy));
17.374 + *)
17.375 +fun thy_contains_thm (str:xstring) (_, thy) =
17.376 + member op = (map (strip_thy o fst) (PureThy.all_thms_of thy)) str;
17.377 +(* val (thy', str) = ("Isac.thy", "real_mult_minus1");
17.378 + val (thy', str) = ("PolyMinus.thy", "klammer_minus_plus");
17.379 + *)
17.380 +fun thy_containing_thm (thy':theory') (str:xstring) =
17.381 + let val thy' = thyID2theory' thy'
17.382 + val str = sym_drop str
17.383 + val startsearch = dropuntil ((curry op= thy') o
17.384 + (#1:theory' * theory -> theory'))
17.385 + (rev (!theory'))
17.386 + in case find_first (thy_contains_thm str) startsearch of
17.387 + SOME (thy',_) => ("IsacKnowledge", thy')
17.388 + | NONE => (case assoc (!isab_thm_thy (*see Isac.ML*), str) of
17.389 + SOME (thyID,_) => ("Isabelle", thyID)
17.390 + | NONE =>
17.391 + raise error ("thy_containing_thm: theorem '"^str^
17.392 + "' not in !theory' above thy '"^thy'^"'"))
17.393 + end;
17.394 +
17.395 +
17.396 +(*.which theory below thy' contains a ruleset;
17.397 +get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*)
17.398 +(* val (thy', rls') = ("PolyEq.thy", "separate_bdv");
17.399 + *)
17.400 +local infix mem; (*from Isabelle2002*)
17.401 +fun x mem [] = false
17.402 + | x mem (y :: ys) = x = y orelse x mem ys;
17.403 +in
17.404 +fun thy_containing_rls (thy':theory') (rls':rls') =
17.405 + let val rls' = strip_thy rls'
17.406 + val thy' = thyID2theory' thy'
17.407 + (*take thys between "Isac" and thy' not to search #1#*)
17.408 + val dropthys = takewhile [] (not o (curry op= thy') o
17.409 + (#1:theory' * theory -> theory'))
17.410 + (rev (!theory'))
17.411 + val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory'))
17.412 + dropthys
17.413 + (*drop those rulesets which are generated in a theory found in #1#*)
17.414 + val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o
17.415 + ((#1 o #2) : rls' * (theory' * rls)
17.416 + -> theory'))
17.417 + (rev (!ruleset'))
17.418 + in case assoc (startsearch, rls') of
17.419 + SOME (thy', _) => ("IsacKnowledge", thyID2theory' thy')
17.420 + | _ => raise error ("thy_containing_rls : rls '"^rls'^
17.421 + "' not in !rulset' above thy '"^thy'^"'")
17.422 + end;
17.423 +(* val (thy', termop) = (thyID, termop);
17.424 + *)
17.425 +fun thy_containing_cal (thy':theory') termop =
17.426 + let val thy' = thyID2theory' thy'
17.427 + val dropthys = takewhile [] (not o (curry op= thy') o
17.428 + (#1:theory' * theory -> theory'))
17.429 + (rev (!theory'))
17.430 + val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory'))
17.431 + dropthys
17.432 + val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o
17.433 + (#1 : calc -> string)) (rev (!calclist'))
17.434 + in case assoc (startsearch, strip_thy termop) of
17.435 + SOME (th_termop, _) => ("IsacKnowledge", strip_thy th_termop)
17.436 + | _ => raise error ("thy_containing_rls : rls '"^termop^
17.437 + "' not in !calclist' above thy '"^thy'^"'")
17.438 + end
17.439 +end;
17.440 +
17.441 +(* print_depth 99; map #1 startsearch; print_depth 3;
17.442 + *)
17.443 +
17.444 +(*.packing return-values to matchTheory, contextToThy for xml-generation.*)
17.445 +datatype contthy = (*also an item from KEStore on Browser ......#*)
17.446 + EContThy (*not from KEStore ...........................*)
17.447 + | ContThm of (*a theorem in contex =============*)
17.448 + {thyID : thyID, (*for *2guh in sub-elems here .*)
17.449 + thm : guh, (*theorem in the context .*)
17.450 + applto : term, (*applied to formula ... .*)
17.451 + applat : term, (*... with lhs inserted .*)
17.452 + reword : rew_ord', (*order used for rewrite .*)
17.453 + asms : (term (*asumption instantiated .*)
17.454 + * term) list, (*asumption evaluated .*)
17.455 + lhs : term (*lhs of the theorem ... #*)
17.456 + * term, (*... instantiated .*)
17.457 + rhs : term (*rhs of the theorem ... #*)
17.458 + * term, (*... instantiated .*)
17.459 + result : term, (*resulting from the rewrite .*)
17.460 + resasms : term list, (*... with asms stored .*)
17.461 + asmrls : rls' (*ruleset for evaluating asms .*)
17.462 + }
17.463 + | ContThmInst of (*a theorem with bdvs in contex ======== *)
17.464 + {thyID : thyID, (*for *2guh in sub-elems here .*)
17.465 + thm : guh, (*theorem in the context .*)
17.466 + bdvs : subst, (*bound variables to modify....*)
17.467 + thminst : term, (*... theorem instantiated .*)
17.468 + applto : term, (*applied to formula ... .*)
17.469 + applat : term, (*... with lhs inserted .*)
17.470 + reword : rew_ord', (*order used for rewrite .*)
17.471 + asms : (term (*asumption instantiated .*)
17.472 + * term) list, (*asumption evaluated .*)
17.473 + lhs : term (*lhs of the theorem ... #*)
17.474 + * term, (*... instantiated .*)
17.475 + rhs : term (*rhs of the theorem ... #*)
17.476 + * term, (*... instantiated .*)
17.477 + result : term, (*resulting from the rewrite .*)
17.478 + resasms : term list, (*... with asms stored .*)
17.479 + asmrls : rls' (*ruleset for evaluating asms .*)
17.480 + }
17.481 + | ContRls of (*a rule set in contex ===================== *)
17.482 + {thyID : thyID, (*for *2guh in sub-elems here .*)
17.483 + rls : guh, (*rule set in the context .*)
17.484 + applto : term, (*rewrite this formula .*)
17.485 + result : term, (*resulting from the rewrite .*)
17.486 + asms : term list (*... with asms stored .*)
17.487 + }
17.488 + | ContRlsInst of (*a rule set with bdvs in contex ======= *)
17.489 + {thyID : thyID, (*for *2guh in sub-elems here .*)
17.490 + rls : guh, (*rule set in the context .*)
17.491 + bdvs : subst, (*for bound variables in thms .*)
17.492 + applto : term, (*rewrite this formula .*)
17.493 + result : term, (*resulting from the rewrite .*)
17.494 + asms : term list (*... with asms stored .*)
17.495 + }
17.496 + | ContNOrew of (*no rewrite for thm or rls ============== *)
17.497 + {thyID : thyID, (*for *2guh in sub-elems here .*)
17.498 + thm_rls : guh, (*thm or rls in the context .*)
17.499 + applto : term (*rewrite this formula .*)
17.500 + }
17.501 + | ContNOrewInst of (*no rewrite for some instantiation == *)
17.502 + {thyID : thyID, (*for *2guh in sub-elems here .*)
17.503 + thm_rls : guh, (*thm or rls in the context .*)
17.504 + bdvs : subst, (*for bound variables in thms .*)
17.505 + thminst : term, (*... theorem instantiated .*)
17.506 + applto : term (*rewrite this formula .*)
17.507 + };
17.508 +
17.509 +(*.check a rewrite-tac for bdv (RL always used *_Inst !) TODO.WN060718
17.510 + pass other tacs unchanged.*)
17.511 +fun get_tac_checked pt ((p,p_) : pos') = get_obj g_tac pt p;
17.512 +
17.513 +(*..*)
17.514 +
17.515 +
17.516 +
17.517 +(*.get the formula f at ptp rewritten by the Rewrite_* already applied to f.*)
17.518 +(* val (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) = tac';
17.519 + *)
17.520 +fun context_thy (pt, pos as (p,p_)) (tac as Rewrite (thmID,_)) =
17.521 + (case applicable_in pos pt tac of
17.522 + Appl (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) =>
17.523 + let val thy = assoc_thy thy'
17.524 + val thm = (norm o #prop o rep_thm o (PureThy.get_thm thy)) thmID
17.525 + (*WN060616 the following must be done on subterm found _IN_ rew_sub
17.526 + val (lhs,rhs) = (dest_equals' o strip_trueprop
17.527 + o Logic.strip_imp_concl) thm
17.528 + val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f)
17.529 + val thm' = ren_inst (insts, thm, lhs, f)
17.530 + val (lhs',rhs') = (dest_equals' o strip_trueprop
17.531 + o Logic.strip_imp_concl) thm'
17.532 + val asms = map strip_trueprop (Logic.strip_imp_prems thm)
17.533 + val asms' = map strip_trueprop (Logic.strip_imp_prems thm')
17.534 + *)
17.535 + in ContThm {thyID = theory'2thyID thy',
17.536 + thm = thm2guh (thy_containing_thm thy' thmID) thmID,
17.537 + applto = f,
17.538 + applat = e_term,
17.539 + reword = ord',
17.540 + asms = [](*asms ~~ asms'*),
17.541 + lhs = (e_term, e_term)(*(lhs, lhs')*),
17.542 + rhs = (e_term, e_term)(*(rhs, rhs')*),
17.543 + result = res,
17.544 + resasms = asm,
17.545 + asmrls = id_rls erls}
17.546 + end
17.547 + | Notappl _ =>
17.548 + let val pp = par_pblobj pt p
17.549 + val thy' = get_obj g_domID pt pp
17.550 + val f = case p_ of
17.551 + Frm => get_obj g_form pt p
17.552 + | Res => (fst o (get_obj g_result pt)) p
17.553 + in ContNOrew {thyID = theory'2thyID thy',
17.554 + thm_rls = thm2guh (thy_containing_thm thy' thmID) thmID,
17.555 + applto = f}
17.556 + end)
17.557 +
17.558 +(* val ((pt,p), tac as Rewrite_Inst (subs, (thmID,_))) = ((pt,pos), tac);
17.559 + *)
17.560 + | context_thy (pt, pos as (p,p_))
17.561 + (tac as Rewrite_Inst (subs, (thmID,_))) =
17.562 + (case applicable_in pos pt tac of
17.563 +(* val Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_),
17.564 + f, (res,asm))) = applicable_in p pt tac;
17.565 + *)
17.566 + Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_),
17.567 + f, (res,(*path to subterm,*)asm))) =>
17.568 + let val thm = (norm o #prop o rep_thm o
17.569 + (PureThy.get_thm (assoc_thy thy'))) thmID
17.570 + val thminst = inst_bdv subst thm
17.571 + (*WN060616 the following must be done on subterm found _IN_ rew_sub
17.572 + val (lhs,rhs) = (dest_equals' o strip_trueprop
17.573 + o Logic.strip_imp_concl) thminst
17.574 + val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f)
17.575 + val thm' = ren_inst (insts, thminst, lhs, f)
17.576 + val (lhs',rhs') = (dest_equals' o strip_trueprop
17.577 + o Logic.strip_imp_concl) thm'
17.578 + val asms = map strip_trueprop (Logic.strip_imp_prems thminst)
17.579 + val asms' = map strip_trueprop (Logic.strip_imp_prems thm')
17.580 + *)
17.581 + in ContThmInst {thyID = theory'2thyID thy',
17.582 + thm = thm2guh (thy_containing_thm
17.583 + thy' thmID) thmID,
17.584 + bdvs = subst,
17.585 + thminst = thminst,
17.586 + applto = f,
17.587 + applat = e_term,
17.588 + reword = ord',
17.589 + asms = [](*asms ~~ asms'*),
17.590 + lhs = (e_term, e_term)(*(lhs, lhs')*),
17.591 + rhs = (e_term, e_term)(*(rhs, rhs')*),
17.592 + result = res,
17.593 + resasms = asm,
17.594 + asmrls = id_rls erls}
17.595 + end
17.596 + | Notappl _ =>
17.597 + let val pp = par_pblobj pt p
17.598 + val thy' = get_obj g_domID pt pp
17.599 + val subst = subs2subst (assoc_thy thy') subs
17.600 + val thm = (norm o #prop o rep_thm o
17.601 + (PureThy.get_thm (assoc_thy thy'))) thmID
17.602 + val thminst = inst_bdv subst thm
17.603 + val f = case p_ of
17.604 + Frm => get_obj g_form pt p
17.605 + | Res => (fst o (get_obj g_result pt)) p
17.606 + in ContNOrewInst {thyID = theory'2thyID thy',
17.607 + thm_rls = thm2guh (thy_containing_thm
17.608 + thy' thmID) thmID,
17.609 + bdvs = subst,
17.610 + thminst = thminst,
17.611 + applto = f}
17.612 + end)
17.613 + | context_thy (pt,p) (tac as Rewrite_Set rls') =
17.614 + (case applicable_in p pt tac of
17.615 + Appl (Rewrite_Set' (thy', _, rls, f, (res,asm))) =>
17.616 + ContRls {thyID = theory'2thyID thy',
17.617 + rls = rls2guh (thy_containing_rls thy' rls') rls',
17.618 + applto = f,
17.619 + result = res,
17.620 + asms = asm})
17.621 + | context_thy (pt,p) (tac as Rewrite_Set_Inst (subs, rls')) =
17.622 + (case applicable_in p pt tac of
17.623 + Appl (Rewrite_Set_Inst' (thy', _, subst, rls, f, (res,asm))) =>
17.624 + ContRlsInst {thyID = theory'2thyID thy',
17.625 + rls = rls2guh (thy_containing_rls thy' rls') rls',
17.626 + bdvs = subst,
17.627 + applto = f,
17.628 + result = res,
17.629 + asms = asm});
17.630 +
17.631 +(*.get all theorems in a rule set (recursivley containing rule sets).*)
17.632 +fun thm_of_rule Erule = []
17.633 + | thm_of_rule (thm as Thm _) = [thm]
17.634 + | thm_of_rule (Calc _) = []
17.635 + | thm_of_rule (Cal1 _) = []
17.636 + | thm_of_rule (Rls_ rls) = thms_of_rls rls
17.637 +and thms_of_rls Erls = []
17.638 + | thms_of_rls (Rls {rules,...}) = (flat o (map thm_of_rule)) rules
17.639 + | thms_of_rls (Seq {rules,...}) = (flat o (map thm_of_rule)) rules
17.640 + | thms_of_rls (Rrls _) = [];
17.641 +(* val Hrls {thy_rls = (_, rls),...} =
17.642 + get_the ["IsacKnowledge", "Test", "Rulesets", "expand_binomtest"];
17.643 +> thms_of_rls rls;
17.644 + *)
17.645 +
17.646 +(*. check if a rule is contained in a rule-set (recursivley down in Rls_);
17.647 + this rule can even be a rule-set itself.*)
17.648 +fun contains_rule r rls =
17.649 + let fun find (r, Rls_ rls) = finds (get_rules rls)
17.650 + | find r12 = eq_rule r12
17.651 + and finds [] = false
17.652 + | finds (r1 :: rs) = if eq_rule (r, r1) then true else finds rs;
17.653 + in
17.654 + (*writeln ("### contains_rule: r = "^rule2str r^", rls = "^rls2str rls);*)
17.655 + finds (get_rules rls)
17.656 + end;
17.657 +
17.658 +(*. try if a rewrite-rule is applicable to a given formula;
17.659 + in case of rule-sets (recursivley) collect all _atomic_ rewrites .*)
17.660 +fun try_rew thy ((_, ro):rew_ord) erls (subst:subst) f (thm' as Thm(id, thm)) =
17.661 + if contains_bdv thm
17.662 + then case rewrite_inst_ thy ro erls false subst thm f of
17.663 + SOME (f',_) =>[rule2tac subst thm']
17.664 + | NONE => []
17.665 + else (case rewrite_ thy ro erls false thm f of
17.666 + SOME (f',_) => [rule2tac [] thm']
17.667 + | NONE => [])
17.668 + | try_rew thy _ _ _ f (cal as Calc c) =
17.669 + (case get_calculation_ thy c f of
17.670 + SOME (str, _) => [rule2tac [] cal]
17.671 + | NONE => [])
17.672 + | try_rew thy _ _ _ f (cal as Cal1 c) =
17.673 + (case get_calculation_ thy c f of
17.674 + SOME (str, _) => [rule2tac [] cal]
17.675 + | NONE => [])
17.676 + | try_rew thy _ _ subst f (Rls_ rls) = filter_appl_rews thy subst f rls
17.677 +and filter_appl_rews thy subst f (Rls {rew_ord = ro, erls, rules,...}) =
17.678 + distinct (flat (map (try_rew thy ro erls subst f) rules))
17.679 + | filter_appl_rews thy subst f (Seq {rew_ord = ro, erls, rules,...}) =
17.680 + distinct (flat (map (try_rew thy ro erls subst f) rules))
17.681 + | filter_appl_rews thy subst f (Rrls _) = [];
17.682 +
17.683 +(*. decide if a tactic is applicable to a given formula;
17.684 + in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*)
17.685 +(* val
17.686 + *)
17.687 +fun atomic_appl_tacs thy _ _ f (Calculate scrID) =
17.688 + try_rew thy e_rew_ordX e_rls [] f (Calc (snd(assoc1 (!calclist', scrID))))
17.689 + | atomic_appl_tacs thy ro erls f (Rewrite (thm' as (thmID, _))) =
17.690 + try_rew thy (ro, assoc_rew_ord ro) erls [] f
17.691 + (Thm (thmID, assoc_thm' thy thm'))
17.692 + | atomic_appl_tacs thy ro erls f (Rewrite_Inst (subs, thm' as (thmID, _))) =
17.693 + try_rew thy (ro, assoc_rew_ord ro) erls (subs2subst thy subs) f
17.694 + (Thm (thmID, assoc_thm' thy thm'))
17.695 +
17.696 + | atomic_appl_tacs thy _ _ f (Rewrite_Set rls') =
17.697 + filter_appl_rews thy [] f (assoc_rls rls')
17.698 + | atomic_appl_tacs thy _ _ f (Rewrite_Set_Inst (subs, rls')) =
17.699 + filter_appl_rews thy (subs2subst thy subs) f (assoc_rls rls')
17.700 + | atomic_appl_tacs _ _ _ _ tac =
17.701 + (writeln ("### atomic_appl_tacs: not impl. for tac = '"^ tac2str tac ^"'");
17.702 + []);
17.703 +
17.704 +
17.705 +
17.706 +
17.707 +
17.708 +(*.not only for thydata, but also for thy's etc.*)
17.709 +fun theID2guh (theID:theID) =
17.710 + case length theID of
17.711 + 0 => raise error ("theID2guh: called with theID = "^strs2str' theID)
17.712 + | 1 => part2guh theID
17.713 + | 2 => thy2guh theID
17.714 + | 3 => thypart2guh theID
17.715 + | 4 => let val [isa, thyID, typ, elemID] = theID
17.716 + in case typ of
17.717 + "Theorems" => thm2guh (isa, thyID) elemID
17.718 + | "Rulesets" => rls2guh (isa, thyID) elemID
17.719 + | "Calculations" => cal2guh (isa, thyID) elemID
17.720 + | "Orders" => ord2guh (isa, thyID) elemID
17.721 + | "Theorems" => thy2guh [isa, thyID]
17.722 + | str => raise error ("theID2guh: called with theID = "^
17.723 + strs2str' theID)
17.724 + end
17.725 + | n => raise error ("theID2guh called with theID = "^strs2str' theID);
17.726 +(*.filenames not only for thydata, but also for thy's etc.*)
17.727 +fun theID2filename (theID:theID) = theID2guh theID ^ ".xml" : filename;
17.728 +
17.729 +fun guh2theID (guh:guh) =
17.730 + let val guh' = explode guh
17.731 + val part = implode (take_fromto 1 4 guh')
17.732 + val isa = implode (take_fromto 5 9 guh')
17.733 + in if not (member op = ["exp_", "thy_", "pbl_", "met_"] part)
17.734 + then raise error ("guh '"^guh^"' does not begin with \
17.735 + \exp_ | thy_ | pbl_ | met_")
17.736 + else let val chap = case isa of
17.737 + "isab_" => "Isabelle"
17.738 + | "scri_" => "IsacScripts"
17.739 + | "isac_" => "IsacKnowledge"
17.740 + | _ =>
17.741 + raise error ("guh2theID: '"^guh^
17.742 + "' does not have isab_ | scri_ | \
17.743 + \isac_ at position 5..9")
17.744 + val rest = takerest (9, guh')
17.745 + val thyID = takewhile [] (not o (curry op= "-")) rest
17.746 + val rest' = dropuntil (curry op= "-") rest
17.747 + in case implode rest' of
17.748 + "-part" => [chap] : theID
17.749 + | "" => [chap, implode thyID]
17.750 + | "-Theorems" => [chap, implode thyID, "Theorems"]
17.751 + | "-Rulesets" => [chap, implode thyID, "Rulesets"]
17.752 + | "-Operations" => [chap, implode thyID, "Operations"]
17.753 + | "-Orders" => [chap, implode thyID, "Orders"]
17.754 + | _ =>
17.755 + let val sect = implode (take_fromto 1 5 rest')
17.756 + val sect' =
17.757 + case sect of
17.758 + "-thm-" => "Theorems"
17.759 + | "-rls-" => "Rulesets"
17.760 + | "-cal-" => "Operations"
17.761 + | "-ord-" => "Orders"
17.762 + | str =>
17.763 + raise error ("guh2theID: '"^guh^"' has '"^sect^
17.764 + "' instead -thm- | -rls- | \
17.765 + \-cal- | -ord-")
17.766 + in [chap, implode thyID, sect', implode
17.767 + (takerest (5, rest'))]
17.768 + end
17.769 + end
17.770 + end;
17.771 +(*> guh2theID "thy_isac_Biegelinie-Theorems";
17.772 +val it = ["IsacKnowledge", "Biegelinie", "Theorems"] : theID
17.773 +> guh2theID "thy_scri_ListC-thm-zip_Nil";
17.774 +val it = ["IsacScripts", "ListC", "Theorems", "zip_Nil"] : theID*)
17.775 +
17.776 +fun guh2filename (guh : guh) = guh ^ ".xml" : filename;
17.777 +
17.778 +
17.779 +(*..*)
17.780 +fun guh2rewtac (guh:guh) ([] : subs) =
17.781 + let val [isa, thy, sect, xstr] = guh2theID guh
17.782 + in case sect of
17.783 + "Theorems" => Rewrite (xstr, "")
17.784 + | "Rulesets" => Rewrite_Set xstr
17.785 + | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'")
17.786 + end
17.787 + | guh2rewtac (guh:guh) subs =
17.788 + let val [isa, thy, sect, xstr] = guh2theID guh
17.789 + in case sect of
17.790 + "Theorems" => Rewrite_Inst (subs, (xstr, ""))
17.791 + | "Rulesets" => Rewrite_Set_Inst (subs, xstr)
17.792 + | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'")
17.793 + end;
17.794 +(*> guh2rewtac "thy_isac_Test-thm-constant_mult_square" [];
17.795 +val it = Rewrite ("constant_mult_square", "") : tac
17.796 +> guh2rewtac "thy_isac_Test-thm-risolate_bdv_add" ["(bdv, x)"];
17.797 +val it = Rewrite_Inst (["(bdv, x)"], ("risolate_bdv_add", "")) : tac
17.798 +> guh2rewtac "thy_isac_Test-rls-Test_simplify" [];
17.799 +val it = Rewrite_Set "Test_simplify" : tac
17.800 +> guh2rewtac "thy_isac_Test-rls-isolate_bdv" ["(bdv, x)"];
17.801 +val it = Rewrite_Set_Inst (["(bdv, x)"], "isolate_bdv") : tac*)
17.802 +
17.803 +
17.804 +(*.the front-end may request a context for any element of the hierarchy.*)
17.805 +(* val guh = "thy_isac_Test-rls-Test_simplify";
17.806 + *)
17.807 +fun no_thycontext (guh : guh) = (guh2theID guh; false)
17.808 + handle _ => true;
17.809 +
17.810 +(*> has_thycontext "thy_isac_Test";
17.811 +if has_thycontext "thy_isac_Test" then "OK" else "NOTOK";
17.812 + *)
17.813 +
17.814 +
17.815 +
17.816 +(*.get the substitution of bound variables for matchTheory:
17.817 + # lookup the thm|rls' in the script
17.818 + # take the [(bdv, v_),..] from the respective Rewrite_(Set_)Inst
17.819 + # instantiate this subs with the istates env to [(bdv, x),..]
17.820 + # otherwise [].*)
17.821 +(*WN060617 hack assuming that all scripts use only one bound variable
17.822 +and use 'v_' as the formal argument for this bound variable*)
17.823 +(* val (ScrState (env,_,_,_,_,_), _, guh) = (is, "dummy", guh);
17.824 + *)
17.825 +fun subs_from (ScrState (env,_,_,_,_,_)) _(*:Script sc*) (guh:guh) =
17.826 + let val theID as [isa, thyID, sect, xstr] = guh2theID guh
17.827 + in case sect of
17.828 + "Theorems" =>
17.829 + let val thm = PureThy.get_thm (assoc_thy (thyID2theory' thyID)) xstr
17.830 + in if contains_bdv thm
17.831 + then let val formal_arg = str2term "v_"
17.832 + val value = subst_atomic env formal_arg
17.833 + in ["(bdv," ^ term2str value ^ ")"]:subs end
17.834 + else []
17.835 + end
17.836 + | "Rulesets" =>
17.837 + let val rules = (get_rules o assoc_rls) xstr
17.838 + in if contain_bdv rules
17.839 + then let val formal_arg = str2term"v_"
17.840 + val value = subst_atomic env formal_arg
17.841 + in ["(bdv,"^term2str value^")"]:subs end
17.842 + else []
17.843 + end
17.844 + end;
17.845 +
17.846 +(* use"ME/rewtools.sml";
17.847 + *)
17.848 +
18.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2 +++ b/src/Tools/isac/Interpret/script.sml Wed Aug 25 16:20:07 2010 +0200
18.3 @@ -0,0 +1,2031 @@
18.4 +(* interpreter for scripts
18.5 + (c) Walther Neuper 2000
18.6 +
18.7 +use"ME/script.sml";
18.8 +use"script.sml";
18.9 +*)
18.10 +signature INTERPRETER =
18.11 +sig
18.12 + (*type ets (list of executed tactics) see sequent.sml*)
18.13 +
18.14 + datatype locate
18.15 + = NotLocatable
18.16 + | Steps of (tac_ * mout * ptree * pos' * cid * safe (* ets*)) list
18.17 +(* | ToDo of ets 28.4.02*)
18.18 +
18.19 + (*diss: next-tactic-function*)
18.20 + val next_tac : theory' -> ptree * pos' -> metID -> scr -> ets -> tac_
18.21 + (*diss: locate-function*)
18.22 + val locate_gen : theory'
18.23 + -> tac_
18.24 + -> ptree * pos' -> scr * rls -> ets -> loc_ -> locate
18.25 +
18.26 + val sel_rules : ptree -> pos' -> tac list
18.27 + val init_form : scr -> ets -> loc_ * term option (*FIXME not up to date*)
18.28 + val formal_args : term -> term list
18.29 +
18.30 + (*shift to library ...*)
18.31 + val inst_abs : theory' -> term -> term
18.32 + val itms2args : metID -> itm list -> term list
18.33 + val user_interrupt : loc_ * (tac_ * env * env * term * term * safe)
18.34 + (*val empty : term*)
18.35 +end
18.36 +
18.37 +
18.38 +
18.39 +
18.40 +(*
18.41 +structure Interpreter : INTERPRETER =
18.42 +struct
18.43 +*)
18.44 +
18.45 +(*.traces the leaves (ie. non-tactical nodes) of the script
18.46 + found by next_tac.
18.47 + a leaf is either a tactic or an 'exp' in 'let v = expr'
18.48 + where 'exp' does not contain a tactic.*)
18.49 +val trace_script = ref false;
18.50 +
18.51 +type step = (*data for creating a new node in the ptree;
18.52 + designed for use:
18.53 + fun ass* scrstate steps =
18.54 + ... case ass* scrstate steps of
18.55 + Assoc (scrstate, steps) => ... ass* scrstate steps*)
18.56 + tac_ (*transformed from associated tac*)
18.57 + * mout (*result with indentation etc.*)
18.58 + * ptree (*containing node created by tac_ + resp. scrstate*)
18.59 + * pos' (*position in ptree; ptree * pos' is the proofstate*)
18.60 + * pos' list; (*of ptree-nodes probably cut (by fst tac_)*)
18.61 +val e_step = (Empty_Tac_, EmptyMout, EmptyPtree, e_pos',[]:pos' list):step;
18.62 +
18.63 +fun rule2thm' (Thm (id, thm)) = (id, string_of_thmI thm):thm'
18.64 + | rule2thm' r = raise error ("rule2thm': not defined for "^(rule2str r));
18.65 +fun rule2rls' (Rls_ rls) = id_rls rls
18.66 + | rule2rls' r = raise error ("rule2rls': not defined for "^(rule2str r));
18.67 +
18.68 +(*.makes a (rule,term) list to a Step (m, mout, pt', p', cid) for solve;
18.69 + complicated with current t in rrlsstate.*)
18.70 +fun rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) [(r, (f', am))] =
18.71 + let val thy = assoc_thy thy'
18.72 + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
18.73 + val is = RrlsState (f',f'',rss,rts)
18.74 + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
18.75 + val (p', cid, mout, pt') = generate1 thy m is p pt
18.76 + in (is, (m, mout, pt', p', cid)::steps) end
18.77 + | rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa))
18.78 + ((r, (f', am))::rts') =
18.79 + let val thy = assoc_thy thy'
18.80 + val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
18.81 + val is = RrlsState (f',f'',rss,rts)
18.82 + val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
18.83 + val (p', cid, mout, pt') = generate1 thy m is p pt
18.84 + in rts2steps ((m, mout, pt', p', cid)::steps)
18.85 + ((pt',p'),(f',f'',rss,rts),(thy',ro,er,pa)) rts' end;
18.86 +
18.87 +
18.88 +(*. functions for the environment stack .*)
18.89 +fun accessenv id es = the (assoc((top es):env, id))
18.90 + handle _ => error ("accessenv: "^(free2str id)^" not in env");
18.91 +fun updateenv id vl (es:env stack) =
18.92 + (push (overwrite(top es, (id, vl))) (pop es)):env stack;
18.93 +fun pushenv id vl (es:env stack) =
18.94 + (push (overwrite(top es, (id, vl))) es):env stack;
18.95 +val popenv = pop:env stack -> env stack;
18.96 +
18.97 +
18.98 +
18.99 +fun de_esc_underscore str =
18.100 + let fun scan [] = []
18.101 + | scan (s::ss) = if s = "'" then (scan ss)
18.102 + else (s::(scan ss))
18.103 + in (implode o scan o explode) str end;
18.104 +(*
18.105 +> val str = "Rewrite_Set_Inst";
18.106 +> val esc = esc_underscore str;
18.107 +val it = "Rewrite'_Set'_Inst" : string
18.108 +> val des = de_esc_underscore esc;
18.109 + val des = de_esc_underscore esc;*)
18.110 +
18.111 +(*go at a location in a script and fetch the contents*)
18.112 +fun go [] t = t
18.113 + | go (D::p) (Abs(s,ty,t0)) = go (p:loc_) t0
18.114 + | go (L::p) (t1 $ t2) = go p t1
18.115 + | go (R::p) (t1 $ t2) = go p t2
18.116 + | go l _ = raise error ("go: no "^(loc_2str l));
18.117 +(*
18.118 +> val t = (term_of o the o (parse thy)) "a+b";
18.119 +val it = Const (#,#) $ Free (#,#) $ Free ("b","RealDef.real") : term
18.120 +> val plus_a = go [L] t;
18.121 +> val b = go [R] t;
18.122 +> val plus = go [L,L] t;
18.123 +> val a = go [L,R] t;
18.124 +
18.125 +> val t = (term_of o the o (parse thy)) "a+b+c";
18.126 +val t = Const (#,#) $ (# $ # $ Free #) $ Free ("c","RealDef.real") : term
18.127 +> val pl_pl_a_b = go [L] t;
18.128 +> val c = go [R] t;
18.129 +> val a = go [L,R,L,R] t;
18.130 +> val b = go [L,R,R] t;
18.131 +*)
18.132 +
18.133 +
18.134 +(* get a subterm t with test t, and record location *)
18.135 +fun get l test (t as Const (s,T)) =
18.136 + if test t then SOME (l,t) else NONE
18.137 + | get l test (t as Free (s,T)) =
18.138 + if test t then SOME (l,t) else NONE
18.139 + | get l test (t as Bound n) =
18.140 + if test t then SOME (l,t) else NONE
18.141 + | get l test (t as Var (s,T)) =
18.142 + if test t then SOME (l,t) else NONE
18.143 + | get l test (t as Abs (s,T,body)) =
18.144 + if test t then SOME (l:loc_,t) else get ((l@[D]):loc_) test body
18.145 + | get l test (t as t1 $ t2) =
18.146 + if test t then SOME (l,t)
18.147 + else case get (l@[L]) test t1 of
18.148 + NONE => get (l@[R]) test t2
18.149 + | SOME (l',t') => SOME (l',t');
18.150 +(*18.6.00
18.151 +> val sss = ((term_of o the o (parse thy))
18.152 + "Script Solve_root_equation (eq_::bool) (v_::real) (err_::bool) =\
18.153 + \ (let e_ = Try (Rewrite square_equation_left True eq_) \
18.154 + \ in [e_])");
18.155 + ______ compares head_of !!
18.156 +> get [] (eq_str "Let") sss; [R]
18.157 +> get [] (eq_str "Script.Try") sss; [R,L,R]
18.158 +> get [] (eq_str "Script.Rewrite") sss; [R,L,R,R]
18.159 +> get [] (eq_str "True") sss; [R,L,R,R,L,R]
18.160 +> get [] (eq_str "e_") sss; [R,R]
18.161 +*)
18.162 +
18.163 +fun test_negotiable t =
18.164 + member op = (!negotiable)
18.165 + ((strip_thy o (term_str (theory "Script")) o head_of) t);
18.166 +
18.167 +(*.get argument of first stactic in a script for init_form.*)
18.168 +fun get_stac thy (h $ body) =
18.169 +(*
18.170 + *)
18.171 + let
18.172 + fun get_t y (Const ("Script.Seq",_) $ e1 $ e2) a =
18.173 + (case get_t y e1 a of NONE => get_t y e2 a | la => la)
18.174 + | get_t y (Const ("Script.Seq",_) $ e1 $ e2 $ a) _ =
18.175 + (case get_t y e1 a of NONE => get_t y e2 a | la => la)
18.176 + | get_t y (Const ("Script.Try",_) $ e) a = get_t y e a
18.177 + | get_t y (Const ("Script.Try",_) $ e $ a) _ = get_t y e a
18.178 + | get_t y (Const ("Script.Repeat",_) $ e) a = get_t y e a
18.179 + | get_t y (Const ("Script.Repeat",_) $ e $ a) _ = get_t y e a
18.180 + | get_t y (Const ("Script.Or",_) $e1 $ e2) a =
18.181 + (case get_t y e1 a of NONE => get_t y e2 a | la => la)
18.182 + | get_t y (Const ("Script.Or",_) $e1 $ e2 $ a) _ =
18.183 + (case get_t y e1 a of NONE => get_t y e2 a | la => la)
18.184 + | get_t y (Const ("Script.While",_) $ c $ e) a = get_t y e a
18.185 + | get_t y (Const ("Script.While",_) $ c $ e $ a) _ = get_t y e a
18.186 + | get_t y (Const ("Script.Letpar",_) $ e1 $ Abs (_,_,e2)) a =
18.187 + (case get_t y e1 a of NONE => get_t y e2 a | la => la)
18.188 + (*| get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
18.189 + (writeln("get_t: Let e1= "^(term2str e1)^", e2= "^(term2str e2));
18.190 + case get_t y e1 a of NONE => get_t y e2 a | la => la)
18.191 + | get_t y (Abs (_,_,e)) a = get_t y e a*)
18.192 + | get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
18.193 + get_t y e1 a (*don't go deeper without evaluation !*)
18.194 + | get_t y (Const ("If",_) $ c $ e1 $ e2) a = NONE
18.195 + (*(case get_t y e1 a of NONE => get_t y e2 a | la => la)*)
18.196 +
18.197 + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ $ a) _ = SOME a
18.198 + | get_t y (Const ("Script.Rewrite",_) $ _ $ _ ) a = SOME a
18.199 + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ a) _ = SOME a
18.200 + | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ ) a = SOME a
18.201 + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ a) _ = SOME a
18.202 + | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ ) a = SOME a
18.203 + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $a)_ =SOME a
18.204 + | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ ) a =SOME a
18.205 + | get_t y (Const ("Script.Calculate",_) $ _ $ a) _ = SOME a
18.206 + | get_t y (Const ("Script.Calculate",_) $ _ ) a = SOME a
18.207 +
18.208 + | get_t y (Const ("Script.Substitute",_) $ _ $ a) _ = SOME a
18.209 + | get_t y (Const ("Script.Substitute",_) $ _ ) a = SOME a
18.210 +
18.211 + | get_t y (Const ("Script.SubProblem",_) $ _ $ _) _ = NONE
18.212 +
18.213 + | get_t y x _ =
18.214 + ((*writeln ("### get_t yac: list-expr "^(term2str x));*)
18.215 + NONE)
18.216 +in get_t thy body e_term end;
18.217 +
18.218 +(*FIXME: get 1st stac by next_stac [] instead of ... ?? 29.7.02*)
18.219 +(* val Script sc = scr;
18.220 + *)
18.221 +fun init_form thy (Script sc) env =
18.222 + (case get_stac thy sc of
18.223 + NONE => NONE (*raise error ("init_form: no 1st stac in "^
18.224 + (Syntax.string_of_term (thy2ctxt thy) sc))*)
18.225 + | SOME stac => SOME (subst_atomic env stac))
18.226 + | init_form _ _ _ = raise error "init_form: no match";
18.227 +
18.228 +(* use"ME/script.sml";
18.229 + use"script.sml";
18.230 + *)
18.231 +
18.232 +
18.233 +
18.234 +(*the 'iteration-argument' of a stac (args not eval)*)
18.235 +fun itr_arg _ (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ v) = v
18.236 + | itr_arg _ (Const ("Script.Rewrite",_) $ _ $ _ $ v) = v
18.237 + | itr_arg _ (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ v) = v
18.238 + | itr_arg _ (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ v) = v
18.239 + | itr_arg _ (Const ("Script.Calculate",_) $ _ $ v) = v
18.240 + | itr_arg _ (Const ("Script.Check'_elementwise",_) $ consts $ _) = consts
18.241 + | itr_arg _ (Const ("Script.Or'_to'_List",_) $ _) = e_term
18.242 + | itr_arg _ (Const ("Script.Tac",_) $ _) = e_term
18.243 + | itr_arg _ (Const ("Script.SubProblem",_) $ _ $ _) = e_term
18.244 + | itr_arg thy t = raise error
18.245 + ("itr_arg not impl. for "^
18.246 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));
18.247 +(* val t = (term_of o the o (parse thy))"Rewrite rroot_square_inv False e_";
18.248 +> itr_arg "Script.thy" t;
18.249 +val it = Free ("e_","RealDef.real") : term
18.250 +> val t = (term_of o the o (parse thy))"xxx";
18.251 +> itr_arg "Script.thy" t;
18.252 +*** itr_arg not impl. for xxx
18.253 +uncaught exception ERROR
18.254 + raised at: library.ML:1114.35-1114.40*)
18.255 +
18.256 +
18.257 +(*.get the arguments of the script out of the scripts parsetree.*)
18.258 +fun formal_args scr = (fst o split_last o snd o strip_comb) scr;
18.259 +(*
18.260 +> formal_args scr;
18.261 + [Free ("f_","RealDef.real"),Free ("v_","RealDef.real"),
18.262 + Free ("eqs_","bool List.list")] : term list
18.263 +*)
18.264 +
18.265 +(*.get the identifier of the script out of the scripts parsetree.*)
18.266 +fun id_of_scr sc = (id_of o fst o strip_comb) sc;
18.267 +
18.268 +
18.269 +(*WN020526: not clear, when a is available in ass_up for eva-_true*)
18.270 +(*WN060906: in "fun handle_leaf" eg. uses "SOME M__"(from some PREVIOUS
18.271 + curried Rewrite) for CURRENT value (which may be different from PREVIOUS);
18.272 + thus "NONE" must be set at the end of currying (ill designed anyway)*)
18.273 +fun upd_env_opt env (SOME a, v) = upd_env env (a,v)
18.274 + | upd_env_opt env (NONE, v) =
18.275 + (writeln("*** upd_env_opt: (NONE,"^(term2str v)^")");env);
18.276 +
18.277 +
18.278 +type dsc = typ; (*<-> nam..unknow in Descript.thy*)
18.279 +fun typ_str (Type (s,_)) = s
18.280 + | typ_str (TFree(s,_)) = s
18.281 + | typ_str (TVar ((s,i),_)) = s^(string_of_int i);
18.282 +
18.283 +(*get the _result_-type of a description*)
18.284 +fun dsc_valT (Const (_,(Type (_,[_,T])))) = (strip_thy o typ_str) T;
18.285 +(*> val t = (term_of o the o (parse thy)) "equality";
18.286 +> val T = type_of t;
18.287 +val T = "bool => Tools.una" : typ
18.288 +> val dsc = dsc_valT t;
18.289 +val dsc = "una" : string
18.290 +
18.291 +> val t = (term_of o the o (parse thy)) "fixedValues";
18.292 +> val T = type_of t;
18.293 +val T = "bool List.list => Tools.nam" : typ
18.294 +> val dsc = dsc_valT t;
18.295 +val dsc = "nam" : string*)
18.296 +
18.297 +(*.from penv in itm_ make args for script depending on type of description.*)
18.298 +(*6.5.03 TODO: push penv into script -- and drop mk_arg here || drop penv
18.299 + 9.5.03 penv postponed: penv = env for script at the moment, (*mk_arg*)*)
18.300 +fun mk_arg thy d [] = raise error ("mk_arg: no data for "^
18.301 + (Syntax.string_of_term (thy2ctxt thy) d))
18.302 + | mk_arg thy d [t] =
18.303 + (case dsc_valT d of
18.304 + "una" => [t]
18.305 + | "nam" =>
18.306 + [case t of
18.307 + r as (Const ("op =",_) $ _ $ _) => r
18.308 + | _ => raise error
18.309 + ("mk_arg: dsc-typ 'nam' applied to non-equality "^
18.310 + (Syntax.string_of_term (thy2ctxt thy) t))]
18.311 + | s => raise error ("mk_arg: not impl. for "^s))
18.312 +
18.313 + | mk_arg thy d (t::ts) = (mk_arg thy d [t]) @ (mk_arg thy d ts);
18.314 +(*
18.315 + val d = d_in itm_;
18.316 + val [t] = ts_in itm_;
18.317 +mk_arg thy
18.318 +*)
18.319 +
18.320 +
18.321 +
18.322 +
18.323 +(*.create the actual parameters (args) of script: their order
18.324 + is given by the order in met.pat .*)
18.325 +(*WN.5.5.03: ?: does this allow for different descriptions ???
18.326 + ?: why not taken from formal args of script ???
18.327 +!: FIXXXME penv: push it here in itms2args into script-evaluation*)
18.328 +(* val (thy, mI, itms) = (thy, metID, itms);
18.329 + *)
18.330 +fun itms2args thy mI (itms:itm list) =
18.331 + let val mvat = max_vt itms
18.332 + fun okv mvat (_,vats,b,_,_) = member op = vats mvat andalso b
18.333 + val itms = filter (okv mvat) itms
18.334 + fun test_dsc d (_,_,_,_,itm_) = (d = d_in itm_)
18.335 + fun itm2arg itms (_,(d,_)) =
18.336 + case find_first (test_dsc d) itms of
18.337 + NONE =>
18.338 + raise error ("itms2args: '"^term2str d^"' not in itms")
18.339 + (*| SOME (_,_,_,_,itm_) => mk_arg thy (d_in itm_) (ts_in itm_);
18.340 + penv postponed; presently penv holds already env for script*)
18.341 + | SOME (_,_,_,_,itm_) => penvval_in itm_
18.342 + fun sel_given_find (s,_) = (s = "#Given") orelse (s = "#Find")
18.343 + val pats = (#ppc o get_met) mI
18.344 + in (flat o (map (itm2arg itms))) pats end;
18.345 +(*
18.346 +> val sc = ... Solve_root_equation ...
18.347 +> val mI = ("Script.thy","sqrt-equ-test");
18.348 +> val PblObj{meth={ppc=itms,...},...} = get_obj I pt [];
18.349 +> val ts = itms2args thy mI itms;
18.350 +> map (Syntax.string_of_term (thy2ctxt thy)) ts;
18.351 +["sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)","x","#0"] : string list
18.352 +*)
18.353 +
18.354 +
18.355 +(*["bool_ (1+x=2)","real_ x"] --match_ags--> oris
18.356 + --oris2fmz_vals--> ["equality (1+x=2)","boundVariable x","solutions L"]*)
18.357 +fun oris2fmz_vals oris =
18.358 + let fun ori2fmz_vals ((_,_,_,dsc,ts):ori) =
18.359 + ((term2str o comp_dts') (dsc, ts), last_elem ts)
18.360 + handle _ => raise error ("ori2fmz_env called with "^terms2str ts)
18.361 + in (split_list o (map ori2fmz_vals)) oris end;
18.362 +
18.363 +(*detour necessary, because generate1 delivers a string-result*)
18.364 +fun mout2term thy (Form' (FormKF (_,_,_,_,res))) =
18.365 + (term_of o the o (parse (assoc_thy thy))) res
18.366 + | mout2term thy (Form' (PpcKF _)) = e_term;(*3.8.01: res of subpbl
18.367 + at time of detection in script*)
18.368 +
18.369 +(*.convert a script-tac 'stac' to a tactic 'tac'; if stac is an initac,
18.370 + then convert to a 'tac_' (as required in appy).
18.371 + arg pt:ptree for pushing the thy specified in rootpbl into subpbls.*)
18.372 +fun stac2tac_ pt thy (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f) =
18.373 +(* val (pt, thy, (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f)) =
18.374 + (pt, (assoc_thy th), stac);
18.375 + *)
18.376 + let val tid = (de_esc_underscore o strip_thy) thmID
18.377 + in (Rewrite (tid, (string_of_thmI o
18.378 + (assoc_thm' thy)) (tid,"")), Empty_Tac_) end
18.379 +(* val (thy,
18.380 + mm as(Const ("Script.Rewrite'_Inst",_) $ sub $ Free(thmID,_) $ _ $ f))
18.381 + = (assoc_thy th,stac);
18.382 + stac2tac_ pt thy mm;
18.383 +
18.384 + assoc_thm' (assoc_thy "Isac.thy") (tid,"");
18.385 + assoc_thm' Isac.thy (tid,"");
18.386 + *)
18.387 + | stac2tac_ pt thy (Const ("Script.Rewrite'_Inst",_) $
18.388 + sub $ Free (thmID,_) $ _ $ f) =
18.389 + let val subML = ((map isapair2pair) o isalist2list) sub
18.390 + val subStr = subst2subs subML
18.391 + val tid = (de_esc_underscore o strip_thy) thmID (*4.10.02 unnoetig*)
18.392 + in (Rewrite_Inst
18.393 + (subStr, (tid, (string_of_thmI o
18.394 + (assoc_thm' thy)) (tid,""))), Empty_Tac_) end
18.395 +
18.396 + | stac2tac_ pt thy (Const ("Script.Rewrite'_Set",_) $ Free (rls,_) $ _ $ f)=
18.397 + (Rewrite_Set ((de_esc_underscore o strip_thy) rls), Empty_Tac_)
18.398 +
18.399 + | stac2tac_ pt thy (Const ("Script.Rewrite'_Set'_Inst",_) $
18.400 + sub $ Free (rls,_) $ _ $ f) =
18.401 + let val subML = ((map isapair2pair) o isalist2list) sub;
18.402 + val subStr = subst2subs subML;
18.403 + in (Rewrite_Set_Inst (subStr,rls), Empty_Tac_) end
18.404 +
18.405 + | stac2tac_ pt thy (Const ("Script.Calculate",_) $ Free (op_,_) $ f) =
18.406 + (Calculate op_, Empty_Tac_)
18.407 +
18.408 + | stac2tac_ pt thy (Const ("Script.Take",_) $ t) =
18.409 + (Take (term2str t), Empty_Tac_)
18.410 +
18.411 + | stac2tac_ pt thy (Const ("Script.Substitute",_) $ isasub $ arg) =
18.412 + (Substitute ((subte2sube o isalist2list) isasub), Empty_Tac_)
18.413 +(* val t = str2term"Substitute [x = L, M_b L = 0] (M_b x = q_0 * x + c)";
18.414 + val Const ("Script.Substitute", _) $ isasub $ arg = t;
18.415 + *)
18.416 +
18.417 +(*12.1.01.*)
18.418 + | stac2tac_ pt thy (Const("Script.Check'_elementwise",_) $ _ $
18.419 + (set as Const ("Collect",_) $ Abs (_,_,pred))) =
18.420 + (Check_elementwise (Syntax.string_of_term (thy2ctxt thy) pred),
18.421 + (*set*)Empty_Tac_)
18.422 +
18.423 + | stac2tac_ pt thy (Const("Script.Or'_to'_List",_) $ _ ) =
18.424 + (Or_to_List, Empty_Tac_)
18.425 +
18.426 +(*12.1.01.for subproblem_equation_dummy in root-equation *)
18.427 + | stac2tac_ pt thy (Const ("Script.Tac",_) $ Free (str,_)) =
18.428 + (Tac ((de_esc_underscore o strip_thy) str), Empty_Tac_)
18.429 + (*L_ will come from pt in appl_in*)
18.430 +
18.431 + (*3.12.03 copied from assod SubProblem*)
18.432 +(* val Const ("Script.SubProblem",_) $
18.433 + (Const ("Pair",_) $
18.434 + Free (dI',_) $
18.435 + (Const ("Pair",_) $ pI' $ mI')) $ ags' =
18.436 + str2term
18.437 + "SubProblem (EqSystem_, [linear, system], [no_met])\
18.438 + \ [bool_list_ [c_2 = 0, L * c + c_2 = q_0 * L ^^^ 2 / 2],\
18.439 + \ real_list_ [c, c_2]]";
18.440 +*)
18.441 + | stac2tac_ pt thy (stac as Const ("Script.SubProblem",_) $
18.442 + (Const ("Pair",_) $
18.443 + Free (dI',_) $
18.444 + (Const ("Pair",_) $ pI' $ mI')) $ ags') =
18.445 +(*compare "| assod _ (Subproblem'"*)
18.446 + let val dI = ((implode o drop_last(*.._*) o explode) dI')^".thy";
18.447 + val thy = maxthy (assoc_thy dI) (rootthy pt);
18.448 + val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI';
18.449 + val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI';
18.450 + val ags = isalist2list ags';
18.451 + val (pI, pors, mI) =
18.452 + if mI = ["no_met"]
18.453 + then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags)
18.454 + handle _ =>(match_ags_msg pI stac ags(*raise exn*);[])
18.455 + val pI' = refine_ori' pors pI;
18.456 + in (pI', pors (*refinement over models with diff.prec only*),
18.457 + (hd o #met o get_pbt) pI') end
18.458 + else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags)
18.459 + handle _ => (match_ags_msg pI stac ags(*raise exn*); []),
18.460 + mI);
18.461 + val (fmz_, vals) = oris2fmz_vals pors;
18.462 + val {cas,ppc,thy,...} = get_pbt pI
18.463 + val dI = theory2theory' thy (*.take dI from _refined_ pbl.*)
18.464 + val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt));
18.465 + val hdl = case cas of
18.466 + NONE => pblterm dI pI
18.467 + | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t
18.468 + val f = subpbl (strip_thy dI) pI
18.469 + in (Subproblem (dI, pI),
18.470 + Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f))
18.471 + end
18.472 +
18.473 + | stac2tac_ pt thy t = raise error
18.474 + ("stac2tac_ TODO: no match for "^
18.475 + (Syntax.string_of_term (thy2ctxt thy) t));
18.476 +(*
18.477 +> val t = (term_of o the o (parse thy))
18.478 + "Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False (x=a+#1)";
18.479 +> stac2tac_ pt t;
18.480 +val it = Rewrite_Set_Inst ([(#,#)],"isolate_bdv") : tac
18.481 +
18.482 +> val t = (term_of o the o (parse SqRoot.thy))
18.483 +"(SubProblem (SqRoot_,[equation,univariate],(SqRoot_,solve_linear))\
18.484 + \ [bool_ e_, real_ v_])::bool list";
18.485 +> stac2tac_ pt SqRoot.thy t;
18.486 +val it = (Subproblem ("SqRoot.thy",[#,#]),Const (#,#) $ (# $ # $ (# $ #)))
18.487 +*)
18.488 +
18.489 +fun stac2tac pt thy t = (fst o stac2tac_ pt thy) t;
18.490 +
18.491 +
18.492 +
18.493 +
18.494 +(*test a term for being a _list_ (set ?) of constants; could be more rigorous*)
18.495 +fun list_of_consts (Const ("List.list.Cons",_) $ _ $ _) = true
18.496 + | list_of_consts (Const ("List.list.Nil",_)) = true
18.497 + | list_of_consts _ = false;
18.498 +(*val ttt = (term_of o the o (parse thy)) "[x=#1,x=#2,x=#3]";
18.499 +> list_of_consts ttt;
18.500 +val it = true : bool
18.501 +> val ttt = (term_of o the o (parse thy)) "[]";
18.502 +> list_of_consts ttt;
18.503 +val it = true : bool*)
18.504 +
18.505 +
18.506 +
18.507 +
18.508 +
18.509 +(* 15.1.01: evaluation of preds only works occasionally,
18.510 + but luckily for the 2 examples of root-equ:
18.511 +> val s = ((term_of o the o (parse thy)) "x",
18.512 + (term_of o the o (parse thy)) "-#5//#12");
18.513 +> val asm = (term_of o the o (parse thy))
18.514 + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)";
18.515 +> val pred = subst_atomic [s] asm;
18.516 +> rewrite_set_ thy false ((cterm_of thy) pred);
18.517 +val it = NONE : (cterm * cterm list) option !!!!!!!!!!!!!!!!!!!!!!!!!!!!
18.518 +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
18.519 +val it = false : bool
18.520 +
18.521 +> val s = ((term_of o the o (parse thy)) "x",
18.522 + (term_of o the o (parse thy)) "#4");
18.523 +> val asm = (term_of o the o (parse thy))
18.524 + "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#5 + x)";
18.525 +> val pred = subst_atomic [s] asm;
18.526 +> rewrite_set_ thy false ((cterm_of thy) pred);
18.527 +val it = SOME ("True & True",[]) : (cterm * cterm list) option
18.528 +> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
18.529 +val it = true : bool`*)
18.530 +
18.531 +(*for check_elementwise: take apart the set, ev. instantiate assumptions
18.532 +fun rep_set thy pt p (set as Const ("Collect",_) $ Abs _) =
18.533 + let val (_ $ Abs (bdv,T,pred)) = inst_abs thy set;
18.534 + val bdv = Free (bdv,T);
18.535 + val pred = if pred <> Const ("Script.Assumptions",bool)
18.536 + then pred
18.537 + else (mk_and o (map fst)) (get_assumptions_ pt (p,Res))
18.538 + in (bdv, pred) end
18.539 + | rep_set thy _ _ set =
18.540 + raise error ("check_elementwise: no set "^ (*from script*)
18.541 + (Syntax.string_of_term (thy2ctxt thy) set));
18.542 +(*> val set = (term_of o the o (parse thy)) "{(x::real). Assumptions}";
18.543 +> val p = [];
18.544 +> val pt = union_asm pt p [("#0 <= sqrt x + sqrt (#5 + x)",[11]),
18.545 + ("#0 <= #9 + #4 * x",[22]),
18.546 + ("#0 <= x ^^^ #2 + #5 * x",[33]),
18.547 + ("#0 <= #2 + x",[44])];
18.548 +> val (bdv,pred) = rep_set thy pt p set;
18.549 +val bdv = Free ("x","RealDef.real") : term
18.550 +> writeln (Syntax.string_of_term (thy2ctxt thy) pred);
18.551 +((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) &
18.552 + #0 <= x ^^^ #2 + #5 * x) &
18.553 +#0 <= #2 + x
18.554 +*)
18.555 +--------------------------------------------11.6.03--was unused*)
18.556 +
18.557 +
18.558 +
18.559 +
18.560 +datatype ass =
18.561 + Ass of tac_ * (*SubProblem gets args instantiated in assod*)
18.562 + term (*for itr_arg,result in ets*)
18.563 +| AssWeak of tac_ *
18.564 + term (*for itr_arg,result in ets*)
18.565 +| NotAss;
18.566 +
18.567 +(*.assod: tac_ associated with stac w.r.t. d
18.568 +args
18.569 + pt:ptree for pushing the thy specified in rootpbl into subpbls
18.570 +returns
18.571 + Ass : associated: e.g. thmID in stac = thmID in m
18.572 + +++ arg in stac = arg in m
18.573 + AssWeak: weakly ass.:e.g. thmID in stac = thmID in m, //arg//
18.574 + NotAss : e.g. thmID in stac/=/thmID in m (not =)
18.575 +8.01:
18.576 + tac_ SubProblem with args completed from script
18.577 +.*)
18.578 +fun assod pt d (m as Rewrite_Inst' (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) stac =
18.579 + (case stac of
18.580 + (Const ("Script.Rewrite'_Inst",_) $ subs_ $ Free (thmID_,idT) $b$f_)=>
18.581 + if thmID = thmID_ then
18.582 + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
18.583 + else ((*writeln"3### assod ..AssWeak";*)AssWeak(m, f'))
18.584 + else ((*writeln"3### assod ..NotAss";*)NotAss)
18.585 + | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $_$f_)=>
18.586 + if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then
18.587 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.588 + else NotAss
18.589 + | _ => NotAss)
18.590 +
18.591 + | assod pt d (m as Rewrite' (thy,rod,rls,put,(thmID,thm),f,(f',asm))) stac =
18.592 + (case stac of
18.593 + (t as Const ("Script.Rewrite",_) $ Free (thmID_,idT) $ b $ f_) =>
18.594 + ((*writeln("3### assod: stac = "^
18.595 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));
18.596 + writeln("3### assod: f(m)= "^
18.597 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) f));*)
18.598 + if thmID = thmID_ then
18.599 + if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
18.600 + else ((*writeln"### assod ..AssWeak";
18.601 + writeln("### assod: f(m) = "^
18.602 + (Sign.string_of_term (sign_of(assoc_thy thy)) f));
18.603 + writeln("### assod: f(stac)= "^
18.604 + (Sign.string_of_term(sign_of(assoc_thy thy))f_))*)
18.605 + AssWeak (m,f'))
18.606 + else ((*writeln"3### assod ..NotAss";*)NotAss))
18.607 + | (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =>
18.608 + if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then
18.609 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.610 + else NotAss
18.611 + | _ => NotAss)
18.612 +
18.613 +(*val f = (term_of o the o (parse thy))"#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0";
18.614 +> val f'= (term_of o the o (parse thy))"#0+(sqrt(sqrt a))^^^#2=#0";
18.615 +> val m = Rewrite'("Script.thy","tless_true","eval_rls",false,
18.616 + ("rroot_square_inv",""),f,(f',[]));
18.617 +> val stac = (term_of o the o (parse thy))
18.618 + "Rewrite rroot_square_inv False (#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0)";
18.619 +> assod e_rls m stac;
18.620 +val it =
18.621 + (SOME (Rewrite' (#,#,#,#,#,#,#)),Const ("empty","RealDef.real"),
18.622 + Const ("empty","RealDef.real")) : tac_ option * term * term*)
18.623 +
18.624 + | assod pt d (m as Rewrite_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
18.625 + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
18.626 + if id_rls rls = rls_ then
18.627 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.628 + else NotAss
18.629 +
18.630 + | assod pt d (m as Detail_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
18.631 + (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
18.632 + if id_rls rls = rls_ then
18.633 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.634 + else NotAss
18.635 +
18.636 + | assod pt d (m as Rewrite_Set' (thy,put,rls,f,(f',asm)))
18.637 + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
18.638 + if id_rls rls = rls_ then
18.639 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.640 + else NotAss
18.641 +
18.642 + | assod pt d (m as Detail_Set' (thy,put,rls,f,(f',asm)))
18.643 + (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
18.644 + if id_rls rls = rls_ then
18.645 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.646 + else NotAss
18.647 +
18.648 + | assod pt d (m as Calculate' (thy',op_,f,(f',thm'))) stac =
18.649 + (case stac of
18.650 + (Const ("Script.Calculate",_) $ Free (op__,_) $ f_) =>
18.651 + if op_ = op__ then
18.652 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.653 + else NotAss
18.654 + | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free(rls_,_) $_$f_)=>
18.655 + if contains_rule (Calc (snd (assoc1 (!calclist', op_))))
18.656 + (assoc_rls rls_) then
18.657 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.658 + else NotAss
18.659 + | (Const ("Script.Rewrite'_Set",_) $ Free (rls_, _) $ _ $ f_) =>
18.660 + if contains_rule (Calc (snd (assoc1 (!calclist', op_))))
18.661 + (assoc_rls rls_) then
18.662 + if f = f_ then Ass (m,f') else AssWeak (m,f')
18.663 + else NotAss
18.664 + | _ => NotAss)
18.665 +
18.666 + | assod pt _ (m as Check_elementwise' (consts,_,(consts_chkd,_)))
18.667 + (Const ("Script.Check'_elementwise",_) $ consts' $ _) =
18.668 + ((*writeln("### assod Check'_elementwise: consts= "^(term2str consts)^
18.669 + ", consts'= "^(term2str consts'));
18.670 + atomty consts; atomty consts';*)
18.671 + if consts = consts' then ((*writeln"### assod Check'_elementwise: Ass";*)
18.672 + Ass (m, consts_chkd))
18.673 + else ((*writeln"### assod Check'_elementwise: NotAss";*) NotAss))
18.674 +
18.675 + | assod pt _ (m as Or_to_List' (ors, list))
18.676 + (Const ("Script.Or'_to'_List",_) $ _) =
18.677 + Ass (m, list)
18.678 +
18.679 + | assod pt _ (m as Take' term)
18.680 + (Const ("Script.Take",_) $ _) =
18.681 + Ass (m, term)
18.682 +
18.683 + | assod pt _ (m as Substitute' (_, _, res))
18.684 + (Const ("Script.Substitute",_) $ _ $ _) =
18.685 + Ass (m, res)
18.686 +(* val t = str2term "Substitute [(x, 3)] (x^^^2 + x + 1)";
18.687 + val (Const ("Script.Substitute",_) $ _ $ _) = t;
18.688 + *)
18.689 +
18.690 + | assod pt _ (m as Tac_ (thy,f,id,f'))
18.691 + (Const ("Script.Tac",_) $ Free (id',_)) =
18.692 + if id = id' then Ass (m, ((term_of o the o (parse thy)) f'))
18.693 + else NotAss
18.694 +
18.695 +
18.696 +(* val t = str2term
18.697 + "SubProblem (DiffApp_,[make,function],[no_met]) \
18.698 + \[real_ m_, real_ v_, bool_list_ rs_]";
18.699 +
18.700 + val (Subproblem' ((domID,pblID,metID),_,_,_,f)) = m;
18.701 + val (Const ("Script.SubProblem",_) $
18.702 + (Const ("Pair",_) $
18.703 + Free (dI',_) $
18.704 + (Const ("Pair",_) $ pI' $ mI')) $ ags') = stac;
18.705 + *)
18.706 + | assod pt _ (Subproblem' ((domID,pblID,metID),_,_,_,f))
18.707 + (stac as Const ("Script.SubProblem",_) $
18.708 + (Const ("Pair",_) $
18.709 + Free (dI',_) $
18.710 + (Const ("Pair",_) $ pI' $ mI')) $ ags') =
18.711 +(*compare "| stac2tac_ thy (Const ("Script.SubProblem",_)"*)
18.712 + let val dI = ((implode o drop_last o explode) dI')^".thy";
18.713 + val thy = maxthy (assoc_thy dI) (rootthy pt);
18.714 + val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI';
18.715 + val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI';
18.716 + val ags = isalist2list ags';
18.717 + val (pI, pors, mI) =
18.718 + if mI = ["no_met"]
18.719 + then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags)
18.720 + handle _=>(match_ags_msg pI stac ags(*raise exn*);[]);
18.721 + val pI' = refine_ori' pors pI;
18.722 + in (pI', pors (*refinement over models with diff.prec only*),
18.723 + (hd o #met o get_pbt) pI') end
18.724 + else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags)
18.725 + handle _ => (match_ags_msg pI stac ags(*raise exn*);[]),
18.726 + mI);
18.727 + val (fmz_, vals) = oris2fmz_vals pors;
18.728 + val {cas, ppc,...} = get_pbt pI
18.729 + val {cas, ppc, thy,...} = get_pbt pI
18.730 + val dI = theory2theory' thy (*take dI from _refined_ pbl*)
18.731 + val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt))
18.732 + val hdl = case cas of
18.733 + NONE => pblterm dI pI
18.734 + | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t
18.735 + val f = subpbl (strip_thy dI) pI
18.736 + in if domID = dI andalso pblID = pI
18.737 + then Ass (Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f), f)
18.738 + else NotAss
18.739 + end
18.740 +
18.741 + | assod pt d m t =
18.742 + (if (!trace_script)
18.743 + then writeln("@@@ the 'tac_' proposed to apply does NOT match the leaf found in the script:\n"^
18.744 + "@@@ tac_ = "^(tac_2str m))
18.745 + else ();
18.746 + NotAss);
18.747 +
18.748 +
18.749 +
18.750 +fun tac_2tac (Refine_Tacitly' (pI,_,_,_,_)) = Refine_Tacitly pI
18.751 + | tac_2tac (Model_Problem' (pI,_,_)) = Model_Problem
18.752 + | tac_2tac (Add_Given' (t,_)) = Add_Given t
18.753 + | tac_2tac (Add_Find' (t,_)) = Add_Find t
18.754 + | tac_2tac (Add_Relation' (t,_)) = Add_Relation t
18.755 +
18.756 + | tac_2tac (Specify_Theory' dI) = Specify_Theory dI
18.757 + | tac_2tac (Specify_Problem' (dI,_)) = Specify_Problem dI
18.758 + | tac_2tac (Specify_Method' (dI,_,_)) = Specify_Method dI
18.759 +
18.760 + | tac_2tac (Rewrite' (thy,rod,erls,put,(thmID,thm),f,(f',asm))) =
18.761 + Rewrite (thmID,thm)
18.762 +
18.763 + | tac_2tac (Rewrite_Inst' (thy,rod,erls,put,sub,(thmID,thm),f,(f',asm)))=
18.764 + Rewrite_Inst (subst2subs sub,(thmID,thm))
18.765 +
18.766 + | tac_2tac (Rewrite_Set' (thy,put,rls,f,(f',asm))) =
18.767 + Rewrite_Set (id_rls rls)
18.768 +
18.769 + | tac_2tac (Detail_Set' (thy,put,rls,f,(f',asm))) =
18.770 + Detail_Set (id_rls rls)
18.771 +
18.772 + | tac_2tac (Rewrite_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
18.773 + Rewrite_Set_Inst (subst2subs sub,id_rls rls)
18.774 +
18.775 + | tac_2tac (Detail_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
18.776 + Detail_Set_Inst (subst2subs sub,id_rls rls)
18.777 +
18.778 + | tac_2tac (Calculate' (thy,op_,t,(t',thm'))) = Calculate (op_)
18.779 +
18.780 + | tac_2tac (Check_elementwise' (consts,pred,consts')) =
18.781 + Check_elementwise pred
18.782 +
18.783 + | tac_2tac (Or_to_List' _) = Or_to_List
18.784 + | tac_2tac (Take' term) = Take (term2str term)
18.785 + | tac_2tac (Substitute' (subte, t, res)) = Substitute (subte2sube subte)
18.786 +
18.787 + | tac_2tac (Tac_ (_,f,id,f')) = Tac id
18.788 +
18.789 + | tac_2tac (Subproblem' ((domID, pblID, _), _, _,_,_)) =
18.790 + Subproblem (domID, pblID)
18.791 + | tac_2tac (Check_Postcond' (pblID, _)) =
18.792 + Check_Postcond pblID
18.793 + | tac_2tac Empty_Tac_ = Empty_Tac
18.794 +
18.795 + | tac_2tac m =
18.796 + raise error ("tac_2tac: not impl. for "^(tac_2str m));
18.797 +
18.798 +
18.799 +
18.800 +
18.801 +(** decompose tac_ to a rule and to (lhs,rhs)
18.802 + unly needed ~~~ **)
18.803 +
18.804 +val idT = Type ("Script.ID",[]);
18.805 +(*val tt = (term_of o the o (parse thy)) "square_equation_left::ID";
18.806 +type_of tt = idT;
18.807 +val it = true : bool
18.808 +*)
18.809 +
18.810 +fun make_rule thy t =
18.811 + let val ct = cterm_of thy (Trueprop $ t)
18.812 + in Thm (Syntax.string_of_term (thy2ctxt thy) (term_of ct), make_thm ct) end;
18.813 +
18.814 +(* val (Rewrite_Inst'(thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))=m;
18.815 + *)
18.816 +(*decompose tac_ to a rule and to (lhs,rhs) for ets FIXME.12.03: obsolete!
18.817 + NOTE.12.03: also used for msg 'not locatable' ?!: 'Subproblem' missing !!!
18.818 +WN0508 only use in tac_2res, which uses only last return-value*)
18.819 +fun rep_tac_ (Rewrite_Inst'
18.820 + (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) =
18.821 + let val fT = type_of f;
18.822 + val b = if put then HOLogic.true_const else HOLogic.false_const;
18.823 + val sT = (type_of o fst o hd) subs;
18.824 + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
18.825 + (map HOLogic.mk_prod subs);
18.826 + val sT' = type_of subs';
18.827 + val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,(*fT*)bool,fT] ---> fT)
18.828 + $ subs' $ Free (thmID,idT) $ b $ f;
18.829 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
18.830 +(*Fehlersuche 25.4.01
18.831 +(a)----- als String zusammensetzen:
18.832 +ML> Syntax.string_of_term (thy2ctxt thy)f;
18.833 +val it = "d_d x #4 + d_d x (x ^^^ #2 + #3 * x)" : string
18.834 +ML> Syntax.string_of_term (thy2ctxt thy)f';
18.835 +val it = "#0 + d_d x (x ^^^ #2 + #3 * x)" : string
18.836 +ML> subs;
18.837 +val it = [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real"))] : subst
18.838 +> val tt = (term_of o the o (parse thy))
18.839 + "(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))";
18.840 +> atomty tt;
18.841 +ML> writeln(Syntax.string_of_term (thy2ctxt thy)tt);
18.842 +(Rewrite_Inst [(bdv,x)] diff_const False d_d x #4 + d_d x (x ^^^ #2 + #3 * x)) =
18.843 + #0 + d_d x (x ^^^ #2 + #3 * x)
18.844 +
18.845 +(b)----- laut rep_tac_:
18.846 +> val ttt=HOLogic.mk_eq (lhs,f');
18.847 +> atomty ttt;
18.848 +
18.849 +
18.850 +(*Fehlersuche 1-2Monate vor 4.01:*)
18.851 +> val tt = (term_of o the o (parse thy))
18.852 + "Rewrite_Inst[(bdv,x)]square_equation_left True(x=#1+#2)";
18.853 +> atomty tt;
18.854 +
18.855 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
18.856 +> val f' = (term_of o the o (parse thy)) "x=#3";
18.857 +> val subs = [((term_of o the o (parse thy)) "bdv",
18.858 + (term_of o the o (parse thy)) "x")];
18.859 +> val sT = (type_of o fst o hd) subs;
18.860 +> val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
18.861 + (map HOLogic.mk_prod subs);
18.862 +> val sT' = type_of subs';
18.863 +> val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,fT,fT] ---> fT)
18.864 + $ subs' $ Free (thmID,idT) $ HOLogic.true_const $ f;
18.865 +> lhs = tt;
18.866 +val it = true : bool
18.867 +> rep_tac_ (Rewrite_Inst'
18.868 + ("Script.thy","tless_true","eval_rls",false,subs,
18.869 + ("square_equation_left",""),f,(f',[])));
18.870 +*)
18.871 + | rep_tac_ (Rewrite' (thy',rod,rls,put,(thmID,thm),f,(f',asm)))=
18.872 + let
18.873 + val fT = type_of f;
18.874 + val b = if put then HOLogic.true_const else HOLogic.false_const;
18.875 + val lhs = Const ("Script.Rewrite",[idT,HOLogic.boolT,fT] ---> fT)
18.876 + $ Free (thmID,idT) $ b $ f;
18.877 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
18.878 +(*
18.879 +> val tt = (term_of o the o (parse thy)) (*____ ____..test*)
18.880 + "Rewrite square_equation_left True (x=#1+#2) = (x=#3)";
18.881 +
18.882 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
18.883 +> val f' = (term_of o the o (parse thy)) "x=#3";
18.884 +> val Thm (id,thm) =
18.885 + rep_tac_ (Rewrite'
18.886 + ("Script.thy","tless_true","eval_rls",false,
18.887 + ("square_equation_left",""),f,(f',[])));
18.888 +> val SOME ct = parse thy
18.889 + "Rewrite square_equation_left True (x=#1+#2)";
18.890 +> rewrite_ Script.thy tless_true eval_rls true thm ct;
18.891 +val it = SOME ("x = #3",[]) : (cterm * cterm list) option
18.892 +*)
18.893 + | rep_tac_ (Rewrite_Set_Inst'
18.894 + (thy',put,subs,rls,f,(f',asm))) =
18.895 + (e_rule, (e_term, f'))
18.896 +(*WN050824: type error ...
18.897 + let val fT = type_of f;
18.898 + val sT = (type_of o fst o hd) subs;
18.899 + val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
18.900 + (map HOLogic.mk_prod subs);
18.901 + val sT' = type_of subs';
18.902 + val b = if put then HOLogic.true_const else HOLogic.false_const
18.903 + val lhs = Const ("Script.Rewrite'_Set'_Inst",
18.904 + [sT',idT,fT,fT] ---> fT)
18.905 + $ subs' $ Free (id_rls rls,idT) $ b $ f;
18.906 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end*)
18.907 +(* ... vals from Rewrite_Inst' ...
18.908 +> rep_tac_ (Rewrite_Set_Inst'
18.909 + ("Script.thy",false,subs,
18.910 + "isolate_bdv",f,(f',[])));
18.911 +*)
18.912 +(* val (Rewrite_Set' (thy',put,rls,f,(f',asm)))=m;
18.913 +*)
18.914 + | rep_tac_ (Rewrite_Set' (thy',put,rls,f,(f',asm)))=
18.915 + let val fT = type_of f;
18.916 + val b = if put then HOLogic.true_const else HOLogic.false_const;
18.917 + val lhs = Const ("Script.Rewrite'_Set",[idT,bool,fT] ---> fT)
18.918 + $ Free (id_rls rls,idT) $ b $ f;
18.919 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
18.920 +(* 13.3.01:
18.921 +val thy = assoc_thy thy';
18.922 +val t = HOLogic.mk_eq (lhs,f');
18.923 +make_rule thy t;
18.924 +--------------------------------------------------
18.925 +val lll = (term_of o the o (parse thy))
18.926 + "Rewrite_Set SqRoot_simplify False (d_d x (x ^^^ #2 + #3 * x) + d_d x #4)";
18.927 +
18.928 +--------------------------------------------------
18.929 +> val f = (term_of o the o (parse thy)) "x=#1+#2";
18.930 +> val f' = (term_of o the o (parse thy)) "x=#3";
18.931 +> val Thm (id,thm) =
18.932 + rep_tac_ (Rewrite_Set'
18.933 + ("Script.thy",false,"SqRoot_simplify",f,(f',[])));
18.934 +val id = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : string
18.935 +val thm = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : thm
18.936 +*)
18.937 + | rep_tac_ (Calculate' (thy',op_,f,(f',thm')))=
18.938 + let val fT = type_of f;
18.939 + val lhs = Const ("Script.Calculate",[idT,fT] ---> fT)
18.940 + $ Free (op_,idT) $ f
18.941 + in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
18.942 +(*
18.943 +> val lhs'=(term_of o the o (parse thy))"Calculate plus (#1+#2)";
18.944 + ... test-root-equ.sml: calculate ...
18.945 +> val Appl m'=applicable_in p pt (Calculate "PLUS");
18.946 +> val (lhs,_)=tac_2etac m';
18.947 +> lhs'=lhs;
18.948 +val it = true : bool*)
18.949 + | rep_tac_ (Check_elementwise' (t,str,(t',asm))) = (Erule, (e_term, t'))
18.950 + | rep_tac_ (Subproblem' (_,_,_,_,t')) = (Erule, (e_term, t'))
18.951 + | rep_tac_ (Take' (t')) = (Erule, (e_term, t'))
18.952 + | rep_tac_ (Substitute' (subst,t,t')) = (Erule, (t, t'))
18.953 + | rep_tac_ (Or_to_List' (t, t')) = (Erule, (t, t'))
18.954 + | rep_tac_ m = raise error ("rep_tac_: not impl.for "^
18.955 + (tac_2str m));
18.956 +
18.957 +(*"N.3.6.03------
18.958 +fun tac_2rule m = (fst o rep_tac_) m;
18.959 +fun tac_2etac m = (snd o rep_tac_) m;
18.960 +fun tac_2tac m = (fst o snd o rep_tac_) m;*)
18.961 +fun tac_2res m = (snd o snd o rep_tac_) m;(*ONLYuse of rep_tac_
18.962 + FIXXXXME: simplify rep_tac_*)
18.963 +
18.964 +
18.965 +(*.handle a leaf;
18.966 + a leaf is either a tactic or an 'exp' in 'let v = expr'
18.967 + where 'exp' does not contain a tactic.
18.968 + handling a leaf comprises
18.969 + (1) 'subst_stacexpr' substitute env and complete curried tactic
18.970 + (2) rewrite the leaf by 'srls'
18.971 +WN060906 quick and dirty fix: return a' too (for updating E later)
18.972 +.*)
18.973 +fun handle_leaf call thy srls E a v t =
18.974 + (*WN050916 'upd_env_opt' is a blind copy from previous version*)
18.975 + case subst_stacexpr E a v t of
18.976 + (a', STac stac) => (*script-tactic*)
18.977 + let val stac' = eval_listexpr_ (assoc_thy thy) srls
18.978 + (subst_atomic (upd_env_opt E (a,v)) stac)
18.979 + in (if (!trace_script)
18.980 + then writeln ("@@@ "^call^" leaf '"^term2str t^"' ---> STac '"^
18.981 + term2str stac'^"'")
18.982 + else ();
18.983 + (a', STac stac'))
18.984 + end
18.985 + | (a', Expr lexpr) => (*leaf-expression*)
18.986 + let val lexpr' = eval_listexpr_ (assoc_thy thy) srls
18.987 + (subst_atomic (upd_env_opt E (a,v)) lexpr)
18.988 + in (if (!trace_script)
18.989 + then writeln("@@@ "^call^" leaf '"^term2str t^"' ---> Expr '"^
18.990 + term2str lexpr'^"'")
18.991 + else ();
18.992 + (a', Expr lexpr'))
18.993 + end;
18.994 +
18.995 +
18.996 +
18.997 +(** locate an applicable stactic in a script **)
18.998 +
18.999 +datatype assoc = (*ExprVal in the sense of denotational semantics*)
18.1000 + Assoc of (*the stac is associated, strongly or weakly*)
18.1001 + scrstate * (*the current; returned for next_tac etc. outside ass* *)
18.1002 + (step list) (*list of steps done until associated stac found;
18.1003 + initiated with the data for doing the 1st step,
18.1004 + thus the head holds these data further on,
18.1005 + while the tail holds steps finished (incl.scrstate in ptree)*)
18.1006 +| NasApp of (*stac not associated, but applicable, ptree-node generated*)
18.1007 + scrstate * (step list)
18.1008 +| NasNap of (*stac not associated, not applicable, nothing generated;
18.1009 + for distinction in Or, for leaving iterations, leaving Seq,
18.1010 + evaluate scriptexpressions*)
18.1011 + term * env;
18.1012 +fun assoc2str (Assoc _) = "Assoc"
18.1013 + | assoc2str (NasNap _) = "NasNap"
18.1014 + | assoc2str (NasApp _) = "NasApp";
18.1015 +
18.1016 +
18.1017 +datatype asap = (*arg. of assy _only_ for distinction w.r.t. Or*)
18.1018 + Aundef (*undefined: set only by (topmost) Or*)
18.1019 +| AssOnly (*do not execute appl stacs - there could be an associated
18.1020 + in parallel Or-branch*)
18.1021 +| AssGen; (*no Ass(Weak) found within Or, thus
18.1022 + search for _applicable_ stacs, execute and generate pt*)
18.1023 +(*this constructions doesnt allow arbitrary nesting of Or !!!*)
18.1024 +
18.1025 +
18.1026 +(*assy, ass_up, astep_up scanning for locate_gen at stactic in a script.
18.1027 + search is clearly separated into (1)-(2):
18.1028 + (1) assy is recursive descent;
18.1029 + (2) ass_up resumes interpretation at a location somewhere in the script;
18.1030 + astep_up does only get to the parentnode of the scriptexpr.
18.1031 + consequence:
18.1032 + * call of (2) means _always_ that in this branch below
18.1033 + there was an appl.stac (Repeat, Or e1, ...)
18.1034 +*)
18.1035 +fun assy ya (is as (E,l,a,v,S,b),ss)
18.1036 + (Const ("Let",_) $ e $ (Abs (id,T,body))) =
18.1037 +(* val (ya, (is as (E,l,a,v,S,b),ss),Const ("Let",_) $ e $ (Abs (id,T,body))) =
18.1038 + (*1*)(((ts,d),Aundef), ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]), body);
18.1039 + *)
18.1040 + ((*writeln("### assy Let$e$Abs: is=");
18.1041 + writeln(istate2str (ScrState is));*)
18.1042 + case assy ya ((E , l@[L,R], a,v,S,b),ss) e of
18.1043 + NasApp ((E',l,a,v,S,bb),ss) =>
18.1044 + let val id' = mk_Free (id, T);
18.1045 + val E' = upd_env E' (id', v);
18.1046 + (*val _=writeln("### assy Let -> NasApp");*)
18.1047 + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
18.1048 + | NasNap (v,E) =>
18.1049 + let val id' = mk_Free (id, T);
18.1050 + val E' = upd_env E (id', v);
18.1051 + (*val _=writeln("### assy Let -> NasNap");*)
18.1052 + in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
18.1053 + | ay => ay)
18.1054 +
18.1055 + | assy (ya as (((thy,srls),_),_)) ((E,l,_,v,S,b),ss)
18.1056 + (Const ("Script.While",_) $ c $ e $ a) =
18.1057 + ((*writeln("### assy While $ c $ e $ a, upd_env= "^
18.1058 + (subst2str (upd_env E (a,v))));*)
18.1059 + if eval_true_ thy srls (subst_atomic (upd_env E (a,v)) c)
18.1060 + then assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e
18.1061 + else NasNap (v, E))
18.1062 +
18.1063 + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
18.1064 + (Const ("Script.While",_) $ c $ e) =
18.1065 + ((*writeln("### assy While, l= "^(loc_2str l));*)
18.1066 + if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
18.1067 + then assy ya ((E, l@[R], a,v,S,b),ss) e
18.1068 + else NasNap (v, E))
18.1069 +
18.1070 + | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
18.1071 + (Const ("If",_) $ c $ e1 $ e2) =
18.1072 + (if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
18.1073 + then assy ya ((E, l@[L,R], a,v,S,b),ss) e1
18.1074 + else assy ya ((E, l@[ R], a,v,S,b),ss) e2)
18.1075 +
18.1076 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Try",_) $ e $ a) =
18.1077 + ((*writeln("### assy Try $ e $ a, l= "^(loc_2str l));*)
18.1078 + case assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e of
18.1079 + ay => ay)
18.1080 +
18.1081 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Try",_) $ e) =
18.1082 + ((*writeln("### assy Try $ e, l= "^(loc_2str l));*)
18.1083 + case assy ya ((E, l@[R], a,v,S,b),ss) e of
18.1084 + ay => ay)
18.1085 +(* val (ya, ((E,l,_,v,S,b),ss), (Const ("Script.Seq",_) $e1 $ e2 $ a)) =
18.1086 + (*2*)(ya, ((E , l@[L,R], a,v,S,b),ss), e);
18.1087 + *)
18.1088 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2 $ a) =
18.1089 + ((*writeln("### assy Seq $e1 $ e2 $ a, E= "^(subst2str E));*)
18.1090 + case assy ya ((E, l@[L,L,R], SOME a,v,S,b),ss) e1 of
18.1091 + NasNap (v, E) => assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2
18.1092 + | NasApp ((E,_,_,v,_,_),ss) =>
18.1093 + assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2
18.1094 + | ay => ay)
18.1095 +
18.1096 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2) =
18.1097 + (case assy ya ((E, l@[L,R], a,v,S,b),ss) e1 of
18.1098 + NasNap (v, E) => assy ya ((E, l@[R], a,v,S,b),ss) e2
18.1099 + | NasApp ((E,_,_,v,_,_),ss) =>
18.1100 + assy ya ((E, l@[R], a,v,S,b),ss) e2
18.1101 + | ay => ay)
18.1102 +
18.1103 + | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Repeat",_) $ e $ a) =
18.1104 + assy ya ((E,(l@[L,R]),SOME a,v,S,b),ss) e
18.1105 +
18.1106 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Repeat",_) $ e) =
18.1107 + assy ya ((E,(l@[R]),a,v,S,b),ss) e
18.1108 +
18.1109 +(*15.6.02: ass,app Or nochmals "uberlegen FIXXXME*)
18.1110 + | assy (y, Aundef) ((E,l,_,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2 $ a) =
18.1111 + (case assy (y, AssOnly) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of
18.1112 + NasNap (v, E) =>
18.1113 + (case assy (y, AssOnly) ((E,(l@[L,R]),SOME a,v,S,b),ss) e2 of
18.1114 + NasNap (v, E) =>
18.1115 + (case assy (y, AssGen) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of
18.1116 + NasNap (v, E) =>
18.1117 + assy (y, AssGen) ((E, (l@[L,R]), SOME a,v,S,b),ss) e2
18.1118 + | ay => ay)
18.1119 + | ay =>(ay))
18.1120 + | NasApp _ => raise error ("assy: FIXXXME ///must not return NasApp///")
18.1121 + | ay => (ay))
18.1122 +
18.1123 + | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2) =
18.1124 + (case assy ya ((E,(l@[L,R]),a,v,S,b),ss) e1 of
18.1125 + NasNap (v, E) =>
18.1126 + assy ya ((E,(l@[R]),a,v,S,b),ss) e2
18.1127 + | ay => (ay))
18.1128 +(* val ((m,_,pt,(p,p_),c)::ss) = [(m,EmptyMout,pt,p,[])];
18.1129 + val t = (term_of o the o (parse Isac.thy)) "Rewrite rmult_1 False";
18.1130 +
18.1131 + val (ap,(p,p_),c,ss) = (Aundef,p,[],[]);
18.1132 + assy (((thy',srls),d),ap) ((E,l,a,v,S,b), (m,EmptyMout,pt,(p,p_),c)::ss) t;
18.1133 +val ((((thy',sr),d),ap), (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss), t) =
18.1134 + ();
18.1135 + *)
18.1136 +
18.1137 + | assy (((thy',sr),d),ap) (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss) t =
18.1138 + ((*writeln("### assy, m = "^tac_2str m);
18.1139 + writeln("### assy, (p,p_) = "^pos'2str (p,p_));
18.1140 + writeln("### assy, is= ");
18.1141 + writeln(istate2str (ScrState is));*)
18.1142 + case handle_leaf "locate" thy' sr E a v t of
18.1143 + (a', Expr s) =>
18.1144 + ((*writeln("### assy: listexpr t= "^(term2str t));
18.1145 + writeln("### assy, E= "^(env2str E));
18.1146 + writeln("### assy, eval(..)= "^(term2str
18.1147 + (eval_listexpr_ (assoc_thy thy') sr
18.1148 + (subst_atomic (upd_env_opt E (a',v)) t))));*)
18.1149 + NasNap (eval_listexpr_ (assoc_thy thy') sr
18.1150 + (subst_atomic (upd_env_opt E (a',v)) t), E))
18.1151 + (* val (_,STac stac) = subst_stacexpr E a v t;
18.1152 + *)
18.1153 + | (a', STac stac) =>
18.1154 + let (*val _=writeln("### assy, stac = "^term2str stac);*)
18.1155 + val p' = case p_ of Frm => p | Res => lev_on p
18.1156 + | _ => raise error ("assy: call by "^
18.1157 + (pos'2str (p,p_)));
18.1158 + in case assod pt d m stac of
18.1159 + Ass (m,v') =>
18.1160 + let (*val _=writeln("### assy: Ass ("^tac_2str m^", "^
18.1161 + term2str v'^")");*)
18.1162 + val (p'',c',f',pt') = generate1 (assoc_thy thy') m
18.1163 + (ScrState (E,l,a',v',S,true)) (p',p_) pt;
18.1164 + in Assoc ((E,l,a',v',S,true), (m,f',pt',p'',c @ c')::ss) end
18.1165 + | AssWeak (m,v') =>
18.1166 + let (*val _=writeln("### assy: Ass Weak("^tac_2str m^", "^
18.1167 + term2str v'^")");*)
18.1168 + val (p'',c',f',pt') = generate1 (assoc_thy thy') m
18.1169 + (ScrState (E,l,a',v',S,false)) (p',p_) pt;
18.1170 + in Assoc ((E,l,a',v',S,false), (m,f',pt',p'',c @ c')::ss) end
18.1171 + | NotAss =>
18.1172 + ((*writeln("### assy, NotAss");*)
18.1173 + case ap of (*switch for Or: 1st AssOnly, 2nd AssGen*)
18.1174 + AssOnly => (NasNap (v, E))
18.1175 + | gen => (case applicable_in (p,p_) pt
18.1176 + (stac2tac pt (assoc_thy thy') stac) of
18.1177 + Appl m' =>
18.1178 + let val is = (E,l,a',tac_2res m',S,false(*FIXXXME*))
18.1179 + val (p'',c',f',pt') =
18.1180 + generate1 (assoc_thy thy') m' (ScrState is) (p',p_) pt;
18.1181 + in NasApp (is,(m,f',pt',p'',c @ c')::ss) end
18.1182 + | Notappl _ =>
18.1183 + (NasNap (v, E))
18.1184 + )
18.1185 + )
18.1186 + end);
18.1187 +(* (astep_up ((thy',scr,d),NasApp_) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])) handle e => print_exn_G e;
18.1188 + *)
18.1189 +
18.1190 +
18.1191 +(* val (ys as (y,s,Script sc,d),(is as (E,l,a,v,S,b),ss),Const ("Let",_) $ _) =
18.1192 + (ys, ((E,up,a,v,S,b),ss), go up sc);
18.1193 + *)
18.1194 +fun ass_up (ys as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss)
18.1195 + (Const ("Let",_) $ _) =
18.1196 + let (*val _= writeln("### ass_up1 Let$e: is=")
18.1197 + val _= writeln(istate2str (ScrState is))*)
18.1198 + val l = drop_last l; (*comes from e, goes to Abs*)
18.1199 + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go l sc;
18.1200 + val i = mk_Free (i, T);
18.1201 + val E = upd_env E (i, v);
18.1202 + (*val _=writeln("### ass_up2 Let$e: E="^(subst2str E));*)
18.1203 + in case assy (((y,s),d),Aundef) ((E, l@[R,D], a,v,S,b),ss) body of
18.1204 + Assoc iss => Assoc iss
18.1205 + | NasApp iss => astep_up ys iss
18.1206 + | NasNap (v, E) => astep_up ys ((E,l,a,v,S,b),ss) end
18.1207 +
18.1208 + | ass_up ys (iss as (is,_)) (Abs (_,_,_)) =
18.1209 + ((*writeln("### ass_up Abs: is=");
18.1210 + writeln(istate2str (ScrState is));*)
18.1211 + astep_up ys iss) (*TODO 5.9.00: env ?*)
18.1212 +
18.1213 + | ass_up ys (iss as (is,_)) (Const ("Let",_) $ e $ (Abs (i,T,b)))=
18.1214 + ((*writeln("### ass_up Let $ e $ Abs: is=");
18.1215 + writeln(istate2str (ScrState is));*)
18.1216 + astep_up ys iss) (*TODO 5.9.00: env ?*)
18.1217 +
18.1218 + (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _ $ _)) =
18.1219 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
18.1220 + *)
18.1221 + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _ $ _) =
18.1222 + astep_up ysa iss (*all has been done in (*2*) below*)
18.1223 +
18.1224 + | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _) =
18.1225 + (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _)) =
18.1226 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
18.1227 + *)
18.1228 + astep_up ysa iss (*2*: comes from e2*)
18.1229 +
18.1230 + | ass_up (ysa as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss)
18.1231 + (Const ("Script.Seq",_) $ _ ) = (*2*: comes from e1, goes to e2*)
18.1232 + (* val ((ysa as (y,s,Script sc,d)), (is as (E,l,a,v,S,b),ss),
18.1233 + (Const ("Script.Seq",_) $ _ )) =
18.1234 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
18.1235 + *)
18.1236 + let val up = drop_last l;
18.1237 + val Const ("Script.Seq",_) $ _ $ e2 = go up sc
18.1238 + (*val _= writeln("### ass_up Seq$e: is=")
18.1239 + val _= writeln(istate2str (ScrState is))*)
18.1240 + in case assy (((y,s),d),Aundef) ((E, up@[R], a,v,S,b),ss) e2 of
18.1241 + NasNap (v,E) => astep_up ysa ((E,up,a,v,S,b),ss)
18.1242 + | NasApp iss => astep_up ysa iss
18.1243 + | ay => ay end
18.1244 +
18.1245 + (* val (ysa, iss, (Const ("Script.Try",_) $ e $ _)) =
18.1246 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
18.1247 + *)
18.1248 + | ass_up ysa iss (Const ("Script.Try",_) $ e $ _) =
18.1249 + astep_up ysa iss
18.1250 +
18.1251 + (* val (ysa, iss, (Const ("Script.Try",_) $ e)) =
18.1252 + (ys, ((E,up,a,v,S,b),ss), (go up sc));
18.1253 + *)
18.1254 + | ass_up ysa iss (Const ("Script.Try",_) $ e) =
18.1255 + ((*writeln("### ass_up Try $ e");*)
18.1256 + astep_up ysa iss)
18.1257 +
18.1258 + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
18.1259 + (*(Const ("Script.While",_) $ c $ e $ a) = WN050930 blind fix*)
18.1260 + (t as Const ("Script.While",_) $ c $ e $ a) =
18.1261 + ((*writeln("### ass_up: While c= "^
18.1262 + (term2str (subst_atomic (upd_env E (a,v)) c)));*)
18.1263 + if eval_true_ y s (subst_atomic (upd_env E (a,v)) c)
18.1264 + then (case assy (((y,s),d),Aundef) ((E, l@[L,R], SOME a,v,S,b),ss) e of
18.1265 + NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss)
18.1266 + | NasApp ((E',l,a,v,S,b),ss) =>
18.1267 + ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*)
18.1268 + | ay => ay)
18.1269 + else astep_up ys ((E,l, SOME a,v,S,b),ss)
18.1270 + )
18.1271 +
18.1272 + | ass_up (ys as (y,s,_,d)) ((E,l,a,v,S,b),ss)
18.1273 + (*(Const ("Script.While",_) $ c $ e) = WN050930 blind fix*)
18.1274 + (t as Const ("Script.While",_) $ c $ e) =
18.1275 + if eval_true_ y s (subst_atomic (upd_env_opt E (a,v)) c)
18.1276 + then (case assy (((y,s),d),Aundef) ((E, l@[R], a,v,S,b),ss) e of
18.1277 + NasNap (v,E') => astep_up ys ((E',l, a,v,S,b),ss)
18.1278 + | NasApp ((E',l,a,v,S,b),ss) =>
18.1279 + ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*)
18.1280 + | ay => ay)
18.1281 + else astep_up ys ((E,l, a,v,S,b),ss)
18.1282 +
18.1283 + | ass_up y iss (Const ("If",_) $ _ $ _ $ _) = astep_up y iss
18.1284 +
18.1285 + | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
18.1286 + (t as Const ("Script.Repeat",_) $ e $ a) =
18.1287 + (case assy (((y,s),d), Aundef) ((E, (l@[L,R]), SOME a,v,S,b),ss) e of
18.1288 + NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss)
18.1289 + | NasApp ((E',l,a,v,S,b),ss) =>
18.1290 + ass_up ys ((E',l,a,v,S,b),ss) t
18.1291 + | ay => ay)
18.1292 +
18.1293 + | ass_up (ys as (y,s,_,d)) (is as ((E,l,a,v,S,b),ss))
18.1294 + (t as Const ("Script.Repeat",_) $ e) =
18.1295 + (case assy (((y,s),d), Aundef) ((E, (l@[R]), a,v,S,b),ss) e of
18.1296 + NasNap (v', E') => astep_up ys ((E',l,a,v',S,b),ss)
18.1297 + | NasApp ((E',l,a,v',S,bb),ss) =>
18.1298 + ass_up ys ((E',l,a,v',S,b),ss) t
18.1299 + | ay => ay)
18.1300 +
18.1301 + | ass_up y iss (Const ("Script.Or",_) $ _ $ _ $ _) = astep_up y iss
18.1302 +
18.1303 + | ass_up y iss (Const ("Script.Or",_) $ _ $ _) = astep_up y iss
18.1304 +
18.1305 + | ass_up y ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $ _ ) =
18.1306 + astep_up y ((E, (drop_last l), a,v,S,b),ss)
18.1307 +
18.1308 + | ass_up y iss t =
18.1309 + raise error ("ass_up not impl for t= "^(term2str t))
18.1310 +(* 9.6.03
18.1311 + val (ys as (_,_,Script sc,_), ss) =
18.1312 + ((thy',srls,scr,d), [(m,EmptyMout,pt,p,[])]:step list);
18.1313 + astep_up ys ((E,l,a,v,S,b),ss);
18.1314 + val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) =
18.1315 + (ysa, iss);
18.1316 + val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) =
18.1317 + ((thy',srls,scr,d), ((E,l,a,v,S,b), [(m,EmptyMout,pt,p,[])]));
18.1318 + *)
18.1319 +and astep_up (ys as (_,_,Script sc,_)) ((E,l,a,v,S,b),ss) =
18.1320 + if 1 < length l
18.1321 + then
18.1322 + let val up = drop_last l;
18.1323 + (*val _= writeln("### astep_up: E= "^env2str E);*)
18.1324 + in ass_up ys ((E,up,a,v,S,b),ss) (go up sc) end
18.1325 + else (NasNap (v, E))
18.1326 +;
18.1327 +
18.1328 +
18.1329 +
18.1330 +
18.1331 +
18.1332 +(* use"ME/script.sml";
18.1333 + use"script.sml";
18.1334 + term2str (go up sc);
18.1335 +
18.1336 + *)
18.1337 +
18.1338 +(*check if there are tacs for rewriting only*)
18.1339 +fun rew_only ([]:step list) = true
18.1340 + | rew_only (((Rewrite' _ ,_,_,_,_))::ss) = rew_only ss
18.1341 + | rew_only (((Rewrite_Inst' _ ,_,_,_,_))::ss) = rew_only ss
18.1342 + | rew_only (((Rewrite_Set' _ ,_,_,_,_))::ss) = rew_only ss
18.1343 + | rew_only (((Rewrite_Set_Inst' _ ,_,_,_,_))::ss) = rew_only ss
18.1344 + | rew_only (((Calculate' _ ,_,_,_,_))::ss) = rew_only ss
18.1345 + | rew_only (((Begin_Trans' _ ,_,_,_,_))::ss) = rew_only ss
18.1346 + | rew_only (((End_Trans' _ ,_,_,_,_))::ss) = rew_only ss
18.1347 + | rew_only _ = false;
18.1348 +
18.1349 +
18.1350 +datatype locate =
18.1351 + Steps of istate (*producing hd of step list (which was latest)
18.1352 + for next_tac, for reporting Safe|Unsafe to DG*)
18.1353 + * step (*(scrstate producing this step is in ptree !)*)
18.1354 + list (*locate_gen may produce intermediate steps*)
18.1355 +| NotLocatable; (*no (m Ass m') or (m AssWeak m') found*)
18.1356 +
18.1357 +
18.1358 +
18.1359 +(* locate_gen tries to locate an input tac m in the script.
18.1360 + pursuing this goal the script is executed until an (m' equiv m) is found,
18.1361 + or the end of the script
18.1362 +args
18.1363 + m : input by the user, already checked by applicable_in,
18.1364 + (to be searched within Or; and _not_ an m doing the step on ptree !)
18.1365 + p,pt: (incl ets) at the time of input
18.1366 + scr : the script
18.1367 + d : canonical simplifier for locating Take, Substitute, Subproblems etc.
18.1368 + ets : ets at the time of input
18.1369 + l : the location (in scr) of the stac which generated the current formula
18.1370 +returns
18.1371 + Steps: pt,p (incl. ets) with m done
18.1372 + pos' list of proofobjs cut (from generate)
18.1373 + safe: implied from last proofobj
18.1374 + ets:
18.1375 + ///ToDo : ets contains a list of tacs to be done before m can be done
18.1376 + NOT IMPL. -- "error: do other step before"
18.1377 + NotLocatable: thus generate_hard
18.1378 +*)
18.1379 +(* val (Rewrite'(_,ro,er,pa,(id,str),f,_), p, Rfuns {locate_rule=lo,...},
18.1380 + RrlsState (_,f'',rss,rts)) = (m, (p,p_), sc, is);
18.1381 + *)
18.1382 +fun locate_gen (thy',_) (Rewrite'(_,ro,er,pa,(id,str),f,_)) (pt,p)
18.1383 + (Rfuns {locate_rule=lo,...}, d) (RrlsState (_,f'',rss,rts)) =
18.1384 + (case lo rss f (Thm (id, mk_thm (assoc_thy thy') str)) of
18.1385 + [] => NotLocatable
18.1386 + | rts' =>
18.1387 + Steps (rts2steps [] ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) rts'))
18.1388 +(* val p as(p',p_)=(p,p_);val scr as Script(h $ body)=sc;val (E,l,a,v,S,bb)=is;
18.1389 + locate_gen (thy':theory') (m:tac_) ((pt,p):ptree * pos')
18.1390 + (scr,d) (E,l,a,v,S,bb);
18.1391 + 9.6.03
18.1392 + val ts = (thy',srls);
18.1393 + val p = (p,p_);
18.1394 + val (scr as Script (h $ body)) = (sc);
18.1395 + val ScrState (E,l,a,v,S,b) = (is);
18.1396 +
18.1397 + val (ts as (thy',srls), m, (pt,p),
18.1398 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
18.1399 + ((thy',srls), m, (pt,(p,p_)), (sc,d), is);
18.1400 + locate_gen (thy',srls) m (pt,p) (Script(h $ body),d)(ScrState(E,l,a,v,S,b));
18.1401 +
18.1402 + val (ts as (thy',srls), m, (pt,p),
18.1403 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
18.1404 + ((thy',srls), m', (pt,(lev_on p,Frm)), (sc,d), is');
18.1405 +
18.1406 + val (ts as (thy',srls), m, (pt,p),
18.1407 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
18.1408 + ((thy',srls), m', (pt,(p, Res)), (sc,d), is');
18.1409 +
18.1410 + val (ts as (thy',srls), m, (pt,p),
18.1411 + (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
18.1412 + ((thy',srls), m, (pt,(p,p_)), (sc,d), is);
18.1413 + *)
18.1414 + | locate_gen (ts as (thy',srls)) (m:tac_) ((pt,p):ptree * pos')
18.1415 + (scr as Script (h $ body),d) (ScrState (E,l,a,v,S,b)) =
18.1416 + let (*val _= writeln("### locate_gen-----------------: is=");
18.1417 + val _= writeln( istate2str (ScrState (E,l,a,v,S,b)));
18.1418 + val _= writeln("### locate_gen: l= "^loc_2str l^", p= "^pos'2str p)*)
18.1419 + val thy = assoc_thy thy';
18.1420 + in case if l=[] orelse ((*init.in solve..Apply_Method...*)
18.1421 + (last_elem o fst) p = 0 andalso snd p = Res)
18.1422 + then (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),
18.1423 + [(m,EmptyMout,pt,p,[])]) body)
18.1424 +(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =
18.1425 + (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])]));
18.1426 + (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]) body);
18.1427 + *)
18.1428 + else (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),
18.1429 + [(m,EmptyMout,pt,p,[])]) ) of
18.1430 + Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =>
18.1431 +(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =
18.1432 + (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),
18.1433 + [(m,EmptyMout,pt,p,[])]) );
18.1434 + *)
18.1435 + ((*writeln("### locate_gen Assoc: p'="^(pos'2str p'));*)
18.1436 + if bb then Steps (ScrState is, ss)
18.1437 + else if rew_only ss (*andalso 'not bb'= associated weakly*)
18.1438 + then let val (po,p_) = p
18.1439 + val po' = case p_ of Frm => po | Res => lev_on po
18.1440 + (*WN.12.03: noticed, that pos is also updated in assy !?!
18.1441 + instead take p' from Assoc ?????????????????????????????*)
18.1442 + val (p'',c'',f'',pt'') =
18.1443 + generate1 thy m (ScrState is) (po',p_) pt;
18.1444 + (*val _=writeln("### locate_gen, aft g1: p''="^(pos'2str p''));*)
18.1445 + (*drop the intermediate steps !*)
18.1446 + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
18.1447 + else Steps (ScrState is, ss))
18.1448 +
18.1449 + | NasApp _ (*[((E,l,a,v,S,bb),(m',f',pt',p',c'))] =>
18.1450 + raise error ("locate_gen: should not have got NasApp, ets =")*)
18.1451 + => NotLocatable
18.1452 + | NasNap (_,_) =>
18.1453 + if l=[] then NotLocatable
18.1454 + else (*scan from begin of script for rew_only*)
18.1455 + (case assy ((ts,d),Aundef) ((E,[R],a,v,Unsafe,b),
18.1456 + [(m,EmptyMout,pt,p,[])]) body of
18.1457 + Assoc (iss as (is as (_,_,_,_,_,bb),
18.1458 + ss as ((m',f',pt',p',c')::_))) =>
18.1459 + ((*writeln"4### locate_gen Assoc after Fini";*)
18.1460 + if rew_only ss
18.1461 + then let val(p'',c'',f'',pt'') =
18.1462 + generate1 thy m (ScrState is) p' pt;
18.1463 + (*drop the intermediate steps !*)
18.1464 + in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
18.1465 + else NotLocatable)
18.1466 + | _ => ((*writeln ("#### locate_gen: after Fini");*)
18.1467 + NotLocatable))
18.1468 + end
18.1469 + | locate_gen _ m _ (sc,_) is =
18.1470 + raise error ("locate_gen: wrong arguments,\n tac= "^(tac_2str m)^
18.1471 + ",\n scr= "^(scr2str sc)^",\n istate= "^(istate2str is));
18.1472 +
18.1473 +
18.1474 +
18.1475 +(** find the next stactic in a script **)
18.1476 +
18.1477 +datatype appy = (*ExprVal in the sense of denotational semantics*)
18.1478 + Appy of (*applicable stac found, search stalled*)
18.1479 + tac_ * (*tac_ associated (fun assod) with stac*)
18.1480 + scrstate (*after determination of stac WN.18.8.03*)
18.1481 + | Napp of (*stac found was not applicable;
18.1482 + this mode may become Skip in Repeat, Try and Or*)
18.1483 + env (*stack*) (*popped while nxt_up*)
18.1484 + | Skip of (*for restart after Appy, for leaving iterations,
18.1485 + for passing the value of scriptexpressions,
18.1486 + and for finishing the script successfully*)
18.1487 + term * env (*stack*);
18.1488 +
18.1489 +(*appy, nxt_up, nstep_up scanning for next_tac.
18.1490 + search is clearly separated into (1)-(2):
18.1491 + (1) appy is recursive descent;
18.1492 + (2) nxt_up resumes interpretation at a location somewhere in the script;
18.1493 + nstep_up does only get to the parentnode of the scriptexpr.
18.1494 + consequence:
18.1495 + * call of (2) means _always_ that in this branch below
18.1496 + there was an applicable stac (Repeat, Or e1, ...)
18.1497 +*)
18.1498 +
18.1499 +
18.1500 +datatype appy_ = (*as argument in nxt_up, nstep_up, from appy*)
18.1501 + (* Appy is only (final) returnvalue, not argument during search
18.1502 + |*) Napp_ (*ev. detects 'script is not appropriate for this example'*)
18.1503 + | Skip_; (*detects 'script successfully finished'
18.1504 + also used as init-value for resuming; this works,
18.1505 + because 'nxt_up Or e1' treats as Appy*)
18.1506 +
18.1507 +fun appy thy ptp E l
18.1508 + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
18.1509 +(* val (thy, ptp, E, l, t as Const ("Let",_) $ e $ (Abs (i,T,b)),a, v)=
18.1510 + (thy, ptp, E, up@[R,D], body, a, v);
18.1511 + appy thy ptp E l t a v;
18.1512 + *)
18.1513 + ((*writeln("### appy Let$e$Abs: is=");
18.1514 + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
18.1515 + case appy thy ptp E (l@[L,R]) e a v of
18.1516 + Skip (res, E) =>
18.1517 + let (*val _= writeln("### appy Let "^(term2str t));
18.1518 + val _= writeln("### appy Let: Skip res ="^(term2str res));*)
18.1519 + (*val (i',b') = variant_abs (i,T,b); WN.15.5.03
18.1520 + val i = mk_Free(i',T); WN.15.5.03 *)
18.1521 + val E' = upd_env E (Free (i,T), res);
18.1522 + in appy thy ptp E' (l@[R,D]) b a v end
18.1523 + | ay => ay)
18.1524 +
18.1525 + | appy (thy as (th,sr)) ptp E l
18.1526 + (t as Const ("Script.While"(*1*),_) $ c $ e $ a) _ v = (*ohne n. 28.9.00*)
18.1527 + ((*writeln("### appy While $ c $ e $ a, upd_env= "^
18.1528 + (subst2str (upd_env E (a,v))));*)
18.1529 + if eval_true_ th sr (subst_atomic (upd_env E (a,v)) c)
18.1530 + then appy thy ptp E (l@[L,R]) e (SOME a) v
18.1531 + else Skip (v, E))
18.1532 +
18.1533 + | appy (thy as (th,sr)) ptp E l
18.1534 + (t as Const ("Script.While"(*2*),_) $ c $ e) a v =(*ohne nachdenken 28.9.00*)
18.1535 + ((*writeln("### appy While $ c $ e, upd_env= "^
18.1536 + (subst2str (upd_env_opt E (a,v))));*)
18.1537 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
18.1538 + then appy thy ptp E (l@[R]) e a v
18.1539 + else Skip (v, E))
18.1540 +
18.1541 + | appy (thy as (th,sr)) ptp E l (t as Const ("If",_) $ c $ e1 $ e2) a v =
18.1542 + ((*writeln("### appy If: t= "^(term2str t));
18.1543 + writeln("### appy If: c= "^(term2str(subst_atomic(upd_env_opt E(a,v))c)));
18.1544 + writeln("### appy If: thy= "^(fst thy));*)
18.1545 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
18.1546 + then ((*writeln("### appy If: true");*)appy thy ptp E (l@[L,R]) e1 a v)
18.1547 + else ((*writeln("### appy If: false");*)appy thy ptp E (l@[ R]) e2 a v))
18.1548 +(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e $ a), _, v) =
18.1549 + (thy, ptp, E, (l@[R]), e, a, v);
18.1550 + *)
18.1551 + | appy thy ptp E (*env*) l
18.1552 + (Const ("Script.Repeat"(*1*),_) $ e $ a) _ v =
18.1553 + ((*writeln("### appy Repeat a: ");*)
18.1554 + appy thy ptp E (*env*) (l@[L,R]) e (SOME a) v)
18.1555 +(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e), _, v) =
18.1556 + (thy, ptp, E, (l@[R]), e, a, v);
18.1557 + *)
18.1558 + | appy thy ptp E (*env*) l
18.1559 + (Const ("Script.Repeat"(*2*),_) $ e) a v =
18.1560 + ((*writeln("3### appy Repeat: a= "^
18.1561 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) a));*)
18.1562 + appy thy ptp E (*env*) (l@[R]) e a v)
18.1563 +(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e $ a), _, v)=
18.1564 + (thy, ptp, E, (l@[R]), e2, a, v);
18.1565 + *)
18.1566 + | appy thy ptp E l
18.1567 + (t as Const ("Script.Try",_) $ e $ a) _ v =
18.1568 + (case appy thy ptp E (l@[L,R]) e (SOME a) v of
18.1569 + Napp E => ((*writeln("### appy Try "^
18.1570 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
18.1571 + Skip (v, E))
18.1572 + | ay => ay)
18.1573 +(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)=
18.1574 + (thy, ptp, E, (l@[R]), e2, a, v);
18.1575 + val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)=
18.1576 + (thy, ptp, E, (l@[L,R]), e1, a, v);
18.1577 + *)
18.1578 + | appy thy ptp E l
18.1579 + (t as Const ("Script.Try",_) $ e) a v =
18.1580 + (case appy thy ptp E (l@[R]) e a v of
18.1581 + Napp E => ((*writeln("### appy Try "^
18.1582 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
18.1583 + Skip (v, E))
18.1584 + | ay => ay)
18.1585 +
18.1586 +
18.1587 + | appy thy ptp E l
18.1588 + (Const ("Script.Or"(*1*),_) $e1 $ e2 $ a) _ v =
18.1589 + (case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of
18.1590 + Appy lme => Appy lme
18.1591 + | _ => appy thy ptp E (*env*) (l@[L,R]) e2 (SOME a) v)
18.1592 +
18.1593 + | appy thy ptp E l
18.1594 + (Const ("Script.Or"(*2*),_) $e1 $ e2) a v =
18.1595 + (case appy thy ptp E (l@[L,R]) e1 a v of
18.1596 + Appy lme => Appy lme
18.1597 + | _ => appy thy ptp E (l@[R]) e2 a v)
18.1598 +
18.1599 +(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)=
18.1600 + (thy, ptp, E,(up@[R]),e2, a, v);
18.1601 + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)=
18.1602 + (thy, ptp, E,(up@[R,D]),body, a, v);
18.1603 + *)
18.1604 + | appy thy ptp E l
18.1605 + (Const ("Script.Seq"(*1*),_) $ e1 $ e2 $ a) _ v =
18.1606 + ((*writeln("### appy Seq $ e1 $ e2 $ a, upd_env= "^
18.1607 + (subst2str (upd_env E (a,v))));*)
18.1608 + case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of
18.1609 + Skip (v,E) => appy thy ptp E (l@[L,R]) e2 (SOME a) v
18.1610 + | ay => ay)
18.1611 +
18.1612 +(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
18.1613 + (thy, ptp, E,(up@[R]),e2, a, v);
18.1614 + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
18.1615 + (thy, ptp, E,(l@[R]), e2, a, v);
18.1616 + val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
18.1617 + (thy, ptp, E,(up@[R,D]),body, a, v);
18.1618 + *)
18.1619 + | appy thy ptp E l
18.1620 + (Const ("Script.Seq",_) $ e1 $ e2) a v =
18.1621 + (case appy thy ptp E (l@[L,R]) e1 a v of
18.1622 + Skip (v,E) => appy thy ptp E (l@[R]) e2 a v
18.1623 + | ay => ay)
18.1624 +
18.1625 + (*.a leaf has been found*)
18.1626 + | appy (thy as (th,sr)) (pt, p) E l t a v =
18.1627 +(* val (thy as (th,sr),(pt, p),E, l, t, a, v) =
18.1628 + (thy, ptp, E, up@[R,D], body, a, v);
18.1629 + val (thy as (th,sr),(pt, p),E, l, t, a, v) =
18.1630 + (thy, ptp, E, l@[L,R], e, a, v);
18.1631 + val (thy as (th,sr),(pt, p),E, l, t, a, v) =
18.1632 + (thy, ptp, E,(l@[R]), e, a, v);
18.1633 + *)
18.1634 + (case handle_leaf "next " th sr E a v t of
18.1635 +(* val (a', Expr s) = handle_leaf "next " th sr E a v t;
18.1636 + *)
18.1637 + (a', Expr s) => Skip (s, E)
18.1638 +(* val (a', STac stac) = handle_leaf "next " th sr E a v t;
18.1639 + *)
18.1640 + | (a', STac stac) =>
18.1641 + let
18.1642 + (*val _= writeln("### appy t, vor stac2tac_ is=");
18.1643 + val _= writeln(istate2str (ScrState (E,l,a',v,Sundef,false)));*)
18.1644 + val (m,m') = stac2tac_ pt (assoc_thy th) stac
18.1645 + in case m of
18.1646 + Subproblem _ => Appy (m', (E,l,a',tac_2res m',Sundef,false))
18.1647 + | _ => (case applicable_in p pt m of
18.1648 +(* val Appl m' = applicable_in p pt m;
18.1649 + *)
18.1650 + Appl m' =>
18.1651 + ((*writeln("### appy: Appy");*)
18.1652 + Appy (m', (E,l,a',tac_2res m',Sundef,false)))
18.1653 + | _ => ((*writeln("### appy: Napp");*)Napp E))
18.1654 + end);
18.1655 +
18.1656 +
18.1657 +(* val (scr as Script sc, l, t as Const ("Let",_) $ _) =
18.1658 + (Script sc, up, go up sc);
18.1659 + nxt_up thy ptp (Script sc) E l ay t a v;
18.1660 +
18.1661 + val (thy,ptp,scr as (Script sc),E,l, ay, t as Const ("Let",_) $ _, a, v)=
18.1662 + (thy,ptp,Script sc, E,up,ay, go up sc, a, v);
18.1663 + nxt_up thy ptp scr E l ay t a v;
18.1664 + *)
18.1665 +fun nxt_up thy ptp (scr as (Script sc)) E l ay
18.1666 + (t as Const ("Let",_) $ _) a v = (*comes from let=...*)
18.1667 + ((*writeln("### nxt_up1 Let$e: is=");
18.1668 + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
18.1669 + if ay = Napp_
18.1670 + then nstep_up thy ptp scr E (drop_last l) Napp_ a v
18.1671 + else (*Skip_*)
18.1672 + let val up = drop_last l;
18.1673 + val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go up sc;
18.1674 + val i = mk_Free (i, T);
18.1675 + val E = upd_env E (i, v);
18.1676 + (*val _= writeln("### nxt_up2 Let$e: is=");
18.1677 + val _= writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
18.1678 + in case appy thy ptp (E) (up@[R,D]) body a v of
18.1679 + Appy lre => Appy lre
18.1680 + | Napp E => nstep_up thy ptp scr E up Napp_ a v
18.1681 + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end)
18.1682 +
18.1683 + | nxt_up thy ptp scr E l ay
18.1684 + (t as Abs (_,_,_)) a v =
18.1685 + ((*writeln("### nxt_up Abs: "^
18.1686 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
18.1687 + nstep_up thy ptp scr E (*enr*) l ay a v)
18.1688 +
18.1689 + | nxt_up thy ptp scr E l ay
18.1690 + (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
18.1691 + ((*writeln("### nxt_up Let$e$Abs: is=");
18.1692 + writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
18.1693 + (*writeln("### nxt_up Let e Abs: "^
18.1694 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
18.1695 + nstep_up thy ptp scr (*upd_env*) E (*a,v)*)
18.1696 + (*eno,upd_env env (iar,res),iar,res,saf*) l ay a v)
18.1697 +
18.1698 + (*no appy_: never causes Napp -> Helpless*)
18.1699 + | nxt_up (thy as (th,sr)) ptp scr E l _
18.1700 + (Const ("Script.While"(*1*),_) $ c $ e $ _) a v =
18.1701 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
18.1702 + then case appy thy ptp E (l@[L,R]) e a v of
18.1703 + Appy lr => Appy lr
18.1704 + | Napp E => nstep_up thy ptp scr E l Skip_ a v
18.1705 + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
18.1706 + else nstep_up thy ptp scr E l Skip_ a v
18.1707 +
18.1708 + (*no appy_: never causes Napp - Helpless*)
18.1709 + | nxt_up (thy as (th,sr)) ptp scr E l _
18.1710 + (Const ("Script.While"(*2*),_) $ c $ e) a v =
18.1711 + if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
18.1712 + then case appy thy ptp E (l@[R]) e a v of
18.1713 + Appy lr => Appy lr
18.1714 + | Napp E => nstep_up thy ptp scr E l Skip_ a v
18.1715 + | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
18.1716 + else nstep_up thy ptp scr E l Skip_ a v
18.1717 +
18.1718 +(* val (scr, l) = (Script sc, up);
18.1719 + *)
18.1720 + | nxt_up thy ptp scr E l ay (Const ("If",_) $ _ $ _ $ _) a v =
18.1721 + nstep_up thy ptp scr E l ay a v
18.1722 +
18.1723 + | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*)
18.1724 + (Const ("Script.Repeat"(*1*),T) $ e $ _) a v =
18.1725 + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[L,R]):loc_) e a v of
18.1726 + Appy lr => Appy lr
18.1727 + | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
18.1728 + nstep_up thy ptp scr E l Skip_ a v)
18.1729 + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
18.1730 + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
18.1731 + nstep_up thy ptp scr E l Skip_ a v))
18.1732 +
18.1733 + | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*)
18.1734 + (Const ("Script.Repeat"(*2*),T) $ e) a v =
18.1735 + (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[R]):loc_) e a v of
18.1736 + Appy lr => Appy lr
18.1737 + | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
18.1738 + nstep_up thy ptp scr E l Skip_ a v)
18.1739 + | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
18.1740 + (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
18.1741 + nstep_up thy ptp scr E l Skip_ a v))
18.1742 +(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e $ _), a, v) =
18.1743 + (thy, ptp, (Script sc),
18.1744 + E, up, ay,(go up sc), a, v);
18.1745 + *)
18.1746 + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
18.1747 + (t as Const ("Script.Try",_) $ e $ _) a v =
18.1748 + ((*writeln("### nxt_up Try "^
18.1749 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
18.1750 + nstep_up thy ptp scr E l Skip_ a v )
18.1751 +(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e), a, v) =
18.1752 + (thy, ptp, (Script sc),
18.1753 + E, up, ay,(go up sc), a, v);
18.1754 + *)
18.1755 + | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
18.1756 + (t as Const ("Script.Try"(*2*),_) $ e) a v =
18.1757 + ((*writeln("### nxt_up Try "^
18.1758 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
18.1759 + nstep_up thy ptp scr E l Skip_ a v)
18.1760 +
18.1761 +
18.1762 + | nxt_up thy ptp scr E l ay
18.1763 + (Const ("Script.Or",_) $ _ $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
18.1764 +
18.1765 + | nxt_up thy ptp scr E l ay
18.1766 + (Const ("Script.Or",_) $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
18.1767 +
18.1768 + | nxt_up thy ptp scr E l ay
18.1769 + (Const ("Script.Or",_) $ _ ) a v =
18.1770 + nstep_up thy ptp scr E (drop_last l) ay a v
18.1771 +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ _ $ _), a, v) =
18.1772 + (thy, ptp, (Script sc),
18.1773 + E, up, ay,(go up sc), a, v);
18.1774 + *)
18.1775 + | nxt_up thy ptp scr E l ay (*all has been done in (*2*) below*)
18.1776 + (Const ("Script.Seq"(*1*),_) $ _ $ _ $ _) a v =
18.1777 + nstep_up thy ptp scr E l ay a v
18.1778 +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ e2), a, v) =
18.1779 + (thy, ptp, (Script sc),
18.1780 + E, up, ay,(go up sc), a, v);
18.1781 + *)
18.1782 + | nxt_up thy ptp scr E l ay (*comes from e2*)
18.1783 + (Const ("Script.Seq"(*2*),_) $ _ $ e2) a v =
18.1784 + nstep_up thy ptp scr E l ay a v
18.1785 +(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _), a, v) =
18.1786 + (thy, ptp, (Script sc),
18.1787 + E, up, ay,(go up sc), a, v);
18.1788 + *)
18.1789 + | nxt_up thy ptp (scr as Script sc) E l ay (*comes from e1*)
18.1790 + (Const ("Script.Seq",_) $ _) a v =
18.1791 + if ay = Napp_
18.1792 + then nstep_up thy ptp scr E (drop_last l) Napp_ a v
18.1793 + else (*Skip_*)
18.1794 + let val up = drop_last l;
18.1795 + val Const ("Script.Seq"(*2*),_) $ _ $ e2 = go up sc;
18.1796 + in case appy thy ptp E (up@[R]) e2 a v of
18.1797 + Appy lr => Appy lr
18.1798 + | Napp E => nstep_up thy ptp scr E up Napp_ a v
18.1799 + | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end
18.1800 +
18.1801 + | nxt_up (thy,_) ptp scr E l ay t a v =
18.1802 + raise error ("nxt_up not impl for "^
18.1803 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t))
18.1804 +
18.1805 +(* val (thy, ptp, (Script sc), E, l, ay, a, v)=
18.1806 + (thy, ptp, scr, E, l, Skip_, a, v);
18.1807 + val (thy, ptp, (Script sc), E, l, ay, a, v)=
18.1808 + (thy, ptp, sc, E, l, Skip_, a, v);
18.1809 + *)
18.1810 +and nstep_up thy ptp (Script sc) E l ay a v =
18.1811 + ((*writeln("### nstep_up from: "^(loc_2str l));
18.1812 + writeln("### nstep_up from: "^
18.1813 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go l sc)));*)
18.1814 + if 1 < length l
18.1815 + then
18.1816 + let
18.1817 + val up = drop_last l;
18.1818 + in ((*writeln("### nstep_up to: "^
18.1819 + (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go up sc)));*)
18.1820 + nxt_up thy ptp (Script sc) E up ay (go up sc) a v ) end
18.1821 + else (*interpreted to end*)
18.1822 + if ay = Skip_ then Skip (v, E) else Napp E
18.1823 +);
18.1824 +
18.1825 +(* decide for the next applicable stac in the script;
18.1826 + returns (stactic, value) - the value in case the script is finished
18.1827 + 12.8.02: ~~~~~ and no assumptions ??? FIXME ???
18.1828 + 20.8.02: must return p in case of finished, because the next script
18.1829 + consulted need not be the calling script:
18.1830 + in case of detail ie. _inserted_ PrfObjs, the next stac
18.1831 + has to searched in a script with PblObj.status<>Complete !
18.1832 + (.. not true for other details ..PrfObj ??????????????????
18.1833 + 20.8.02: do NOT return safe (is only changed in locate !!!)
18.1834 +*)
18.1835 +(* val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
18.1836 + (thy', (pt,p), sc, RrlsState (ii t));
18.1837 + val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
18.1838 + (thy', (pt',p'), sc, is');
18.1839 + *)
18.1840 +fun next_tac (thy,_) (pt,p) (Rfuns {next_rule,...}) (RrlsState(f,f',rss,_))=
18.1841 + if f = f' then (End_Detail' (f',[])(*8.6.03*), Uistate,
18.1842 + (f', Sundef(*FIXME is no value of next_tac! vor 8.6.03*)))
18.1843 + (*finished*)
18.1844 + else (case next_rule rss f of
18.1845 + NONE => (Empty_Tac_, Uistate, (e_term, Sundef)) (*helpless*)
18.1846 +(* val SOME (Thm (id,thm)) = next_rule rss f;
18.1847 + *)
18.1848 + | SOME (Thm (id,thm))(*8.6.03: muss auch f' liefern ?!!*) =>
18.1849 + (Rewrite' (thy, "e_rew_ord", e_rls,(*!?!8.6.03*) false,
18.1850 + (id, string_of_thmI thm), f,(e_term,[(*!?!8.6.03*)])),
18.1851 + Uistate, (e_term, Sundef))) (*next stac*)
18.1852 +
18.1853 +(* val(thy, ptp as (pt,(p,_)), sc as Script (h $ body),ScrState (E,l,a,v,s,b))=
18.1854 + ((thy',srls), (pt,pos), sc, is);
18.1855 + *)
18.1856 + | next_tac thy (ptp as (pt,(p,_)):ptree * pos') (sc as Script (h $ body))
18.1857 + (ScrState (E,l,a,v,s,b)) =
18.1858 + ((*writeln("### next_tac-----------------: E= ");
18.1859 + writeln( istate2str (ScrState (E,l,a,v,s,b)));*)
18.1860 + case if l=[] then appy thy ptp E [R] body NONE v
18.1861 + else nstep_up thy ptp sc E l Skip_ a v of
18.1862 + Skip (v,_) => (*finished*)
18.1863 + (case par_pbl_det pt p of
18.1864 + (true, p', _) =>
18.1865 + let val (_,pblID,_) = get_obj g_spec pt p';
18.1866 + in (Check_Postcond' (pblID, (v, [(*8.6.03 NO asms???*)])),
18.1867 + e_istate, (v,s)) end
18.1868 + | (_,p',rls') => (End_Detail' (e_term,[])(*8.6.03*), e_istate, (v,s)))
18.1869 + | Napp _ => (Empty_Tac_, e_istate, (e_term, Sundef)) (*helpless*)
18.1870 + | Appy (m', scrst as (_,_,_,v,_,_)) => (m', ScrState scrst,
18.1871 + (v, Sundef))) (*next stac*)
18.1872 +
18.1873 + | next_tac _ _ _ is = raise error ("next_tac: not impl for "^
18.1874 + (istate2str is));
18.1875 +
18.1876 +
18.1877 +
18.1878 +
18.1879 +(*.create the initial interpreter state from the items of the guard.*)
18.1880 +(* val (thy, itms, metID) = (thy, itms, mI);
18.1881 + *)
18.1882 +fun init_scrstate thy itms metID =
18.1883 + let val actuals = itms2args thy metID itms;
18.1884 + val scr as Script sc = (#scr o get_met) metID;
18.1885 + val formals = formal_args sc
18.1886 + (*expects same sequence of (actual) args in itms
18.1887 + and (formal) args in met*)
18.1888 + fun relate_args env [] [] = env
18.1889 + | relate_args env _ [] =
18.1890 + raise error ("ERROR in creating the environment for '"
18.1891 + ^id_of_scr sc^"' from \nthe items of the guard of "
18.1892 + ^metID2str metID^",\n\
18.1893 + \formal arg(s), from the script,\
18.1894 + \ miss actual arg(s), from the guards env:\n"
18.1895 + ^(string_of_int o length) formals
18.1896 + ^" formals: "^terms2str formals^"\n"
18.1897 + ^(string_of_int o length) actuals
18.1898 + ^" actuals: "^terms2str actuals)
18.1899 + | relate_args env [] actual_finds = env (*may drop Find!*)
18.1900 + | relate_args env (a::aa) (f::ff) =
18.1901 + if type_of a = type_of f
18.1902 + then relate_args (env @ [(a, f)]) aa ff else
18.1903 + raise error ("ERROR in creating the environment for '"
18.1904 + ^id_of_scr sc^"' from \nthe items of the guard of "
18.1905 + ^metID2str metID^",\n\
18.1906 + \different types of formal arg, from the script,\
18.1907 + \ and actual arg, from the guards env:'\n\
18.1908 + \formal: '"^term2str a^"::"^(type2str o type_of) a^"'\n\
18.1909 + \actual: '"^term2str f^"::"^(type2str o type_of) f^"'\n\
18.1910 + \in\n\
18.1911 + \formals: "^terms2str formals^"\n\
18.1912 + \actuals: "^terms2str actuals)
18.1913 + val env = relate_args [] formals actuals;
18.1914 + in (ScrState (env,[],NONE,e_term,Safe,true), scr):istate * scr end;
18.1915 +
18.1916 +(*.decide, where to get script/istate from:
18.1917 + (*1*) from PblObj.env: at begin of script if no init_form
18.1918 + (*2*) from PblObj/PrfObj: if stac is in the middle of the script
18.1919 + (*3*) from rls/PrfObj: in case of detail a ruleset.*)
18.1920 +(* val (thy', (p,p_), pt) = (thy', (p,p_), pt);
18.1921 + *)
18.1922 +fun from_pblobj_or_detail' thy' (p,p_) pt =
18.1923 + if member op = [Pbl,Met] p_
18.1924 + then case get_obj g_env pt p of
18.1925 + NONE => raise error "from_pblobj_or_detail': no istate"
18.1926 + | SOME is =>
18.1927 + let val metID = get_obj g_metID pt p
18.1928 + val {srls,...} = get_met metID
18.1929 + in (srls, is, (#scr o get_met) metID) end
18.1930 + else
18.1931 + let val (pbl,p',rls') = par_pbl_det pt p
18.1932 + in if pbl
18.1933 + then (*2*)
18.1934 + let val thy = assoc_thy thy'
18.1935 + val PblObj{meth=itms,...} = get_obj I pt p'
18.1936 + val metID = get_obj g_metID pt p'
18.1937 + val {srls,...} = get_met metID
18.1938 + in (*if last_elem p = 0 (*nothing written to pt yet*)
18.1939 + then let val (is, sc) = init_scrstate thy itms metID
18.1940 + in (srls, is, sc) end
18.1941 + else*) (srls, get_istate pt (p,p_), (#scr o get_met) metID)
18.1942 + end
18.1943 + else (*3*)
18.1944 + (e_rls, (*FIXME: get from pbl or met !!!
18.1945 + unused for Rrls in locate_gen, next_tac*)
18.1946 + get_istate pt (p,p_),
18.1947 + case rls' of
18.1948 + Rls {scr=scr,...} => scr
18.1949 + | Seq {scr=scr,...} => scr
18.1950 + | Rrls {scr=rfuns,...} => rfuns)
18.1951 + end;
18.1952 +
18.1953 +(*.get script and istate from PblObj, see (*1*) above.*)
18.1954 +fun from_pblobj' thy' (p,p_) pt =
18.1955 + let val p' = par_pblobj pt p
18.1956 + val thy = assoc_thy thy'
18.1957 + val PblObj{meth=itms,...} = get_obj I pt p'
18.1958 + val metID = get_obj g_metID pt p'
18.1959 + val {srls,scr,...} = get_met metID
18.1960 + in if last_elem p = 0 (*nothing written to pt yet*)
18.1961 + then let val (is, scr) = init_scrstate thy itms metID
18.1962 + in (srls, is, scr) end
18.1963 + else (srls, get_istate pt (p,p_), scr)
18.1964 + end;
18.1965 +
18.1966 +(*.get the stactics and problems of a script as tacs
18.1967 + instantiated with the current environment;
18.1968 + l is the location which generated the given formula.*)
18.1969 +(*WN.12.5.03: quick-and-dirty repair for listexpressions*)
18.1970 +fun is_spec_pos Pbl = true
18.1971 + | is_spec_pos Met = true
18.1972 + | is_spec_pos _ = false;
18.1973 +
18.1974 +(*. fetch _all_ tactics from script .*)
18.1975 +fun sel_rules _ (([],Res):pos') =
18.1976 + raise PTREE "no tactics applicable at the end of a calculation"
18.1977 +| sel_rules pt (p,p_) =
18.1978 + if is_spec_pos p_
18.1979 + then [get_obj g_tac pt p]
18.1980 + else
18.1981 + let val pp = par_pblobj pt p;
18.1982 + val thy' = (get_obj g_domID pt pp):theory';
18.1983 + val thy = assoc_thy thy';
18.1984 + val metID = get_obj g_metID pt pp;
18.1985 + val metID' =if metID =e_metID then(thd3 o snd3)(get_obj g_origin pt pp)
18.1986 + else metID
18.1987 + val {scr=Script sc,srls,...} = get_met metID'
18.1988 + val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_);
18.1989 + in map ((stac2tac pt thy) o rep_stacexpr o #2 o
18.1990 + (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) end;
18.1991 +(*
18.1992 +> val Script sc = (#scr o get_met) ("SqRoot.thy","sqrt-equ-test");
18.1993 +> val env = [((term_of o the o (parse Isac.thy)) "bdv",
18.1994 + (term_of o the o (parse Isac.thy)) "x")];
18.1995 +> map ((stac2tac pt thy) o #2 o(subst_stacexpr env NONE e_term)) (stacpbls sc);
18.1996 +*)
18.1997 +
18.1998 +
18.1999 +(*. fetch tactics from script and filter _applicable_ tactics;
18.2000 + in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*)
18.2001 +fun sel_appl_atomic_tacs _ (([],Res):pos') =
18.2002 + raise PTREE "no tactics applicable at the end of a calculation"
18.2003 + | sel_appl_atomic_tacs pt (p,p_) =
18.2004 + if is_spec_pos p_
18.2005 + then [get_obj g_tac pt p]
18.2006 + else
18.2007 + let val pp = par_pblobj pt p
18.2008 + val thy' = (get_obj g_domID pt pp):theory'
18.2009 + val thy = assoc_thy thy'
18.2010 + val metID = get_obj g_metID pt pp
18.2011 + val metID' =if metID = e_metID
18.2012 + then (thd3 o snd3) (get_obj g_origin pt pp)
18.2013 + else metID
18.2014 + val {scr=Script sc,srls,erls,rew_ord'=ro,...} = get_met metID'
18.2015 + val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_)
18.2016 + val alltacs = (*we expect at least 1 stac in a script*)
18.2017 + map ((stac2tac pt thy) o rep_stacexpr o #2 o
18.2018 + (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc)
18.2019 + val f = case p_ of
18.2020 + Frm => get_obj g_form pt p
18.2021 + | Res => (fst o (get_obj g_result pt)) p
18.2022 + (*WN071231 ? replace atomic_appl_tacs with applicable_in (ineff!) ?*)
18.2023 + in (distinct o flat o
18.2024 + (map (atomic_appl_tacs thy ro erls f))) alltacs end;
18.2025 +
18.2026 +
18.2027 +(*
18.2028 +end
18.2029 +open Interpreter;
18.2030 +*)
18.2031 +
18.2032 +(* use"ME/script.sml";
18.2033 + use"script.sml";
18.2034 + *)
19.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
19.2 +++ b/src/Tools/isac/Interpret/solve.sml Wed Aug 25 16:20:07 2010 +0200
19.3 @@ -0,0 +1,579 @@
19.4 +(* solve an example by interpreting a method's script
19.5 + (c) Walther Neuper 1999
19.6 +
19.7 +use"ME/solve.sml";
19.8 +use"solve.sml";
19.9 +*)
19.10 +
19.11 +fun safe (ScrState (_,_,_,_,s,_)) = s
19.12 + | safe (RrlsState _) = Safe;
19.13 +
19.14 +type mstID = string;
19.15 +type tac'_ = mstID * tac; (*DG <-> ME*)
19.16 +val e_tac'_ = ("Empty_Tac", Empty_Tac):tac'_;
19.17 +
19.18 +fun mk_tac'_ m = case m of
19.19 + Init_Proof (ppc, spec) => ("Init_Proof", Init_Proof (ppc, spec ))
19.20 +| Model_Problem => ("Model_Problem", Model_Problem)
19.21 +| Refine_Tacitly pblID => ("Refine_Tacitly", Refine_Tacitly pblID)
19.22 +| Refine_Problem pblID => ("Refine_Problem", Refine_Problem pblID)
19.23 +| Add_Given cterm' => ("Add_Given", Add_Given cterm')
19.24 +| Del_Given cterm' => ("Del_Given", Del_Given cterm')
19.25 +| Add_Find cterm' => ("Add_Find", Add_Find cterm')
19.26 +| Del_Find cterm' => ("Del_Find", Del_Find cterm')
19.27 +| Add_Relation cterm' => ("Add_Relation", Add_Relation cterm')
19.28 +| Del_Relation cterm' => ("Del_Relation", Del_Relation cterm')
19.29 +
19.30 +| Specify_Theory domID => ("Specify_Theory", Specify_Theory domID)
19.31 +| Specify_Problem pblID => ("Specify_Problem", Specify_Problem pblID)
19.32 +| Specify_Method metID => ("Specify_Method", Specify_Method metID)
19.33 +| Apply_Method metID => ("Apply_Method", Apply_Method metID)
19.34 +| Check_Postcond pblID => ("Check_Postcond", Check_Postcond pblID)
19.35 +| Free_Solve => ("Free_Solve",Free_Solve)
19.36 +
19.37 +| Rewrite_Inst (subs, thm') => ("Rewrite_Inst", Rewrite_Inst (subs, thm'))
19.38 +| Rewrite thm' => ("Rewrite", Rewrite thm')
19.39 +| Rewrite_Asm thm' => ("Rewrite_Asm", Rewrite_Asm thm')
19.40 +| Rewrite_Set_Inst (subs, rls')
19.41 + => ("Rewrite_Set_Inst", Rewrite_Set_Inst (subs, rls'))
19.42 +| Rewrite_Set rls' => ("Rewrite_Set", Rewrite_Set rls')
19.43 +| End_Ruleset => ("End_Ruleset", End_Ruleset)
19.44 +
19.45 +| End_Detail => ("End_Detail", End_Detail)
19.46 +| Detail_Set rls' => ("Detail_Set", Detail_Set rls')
19.47 +| Detail_Set_Inst (s, rls') => ("Detail_Set_Inst", Detail_Set_Inst (s, rls'))
19.48 +
19.49 +| Calculate op_ => ("Calculate", Calculate op_)
19.50 +| Substitute sube => ("Substitute", Substitute sube)
19.51 +| Apply_Assumption cts' => ("Apply_Assumption", Apply_Assumption cts')
19.52 +
19.53 +| Take cterm' => ("Take", Take cterm')
19.54 +| Take_Inst cterm' => ("Take_Inst", Take_Inst cterm')
19.55 +| Group (con, ints) => ("Group", Group (con, ints))
19.56 +| Subproblem (domID, pblID) => ("Subproblem", Subproblem (domID, pblID))
19.57 +(*
19.58 +| Subproblem_Full(spec,cts')=> ("Subproblem_Full", Subproblem_Full(spec,cts'))
19.59 +*)
19.60 +| End_Subproblem => ("End_Subproblem",End_Subproblem)
19.61 +| CAScmd cterm' => ("CAScmd", CAScmd cterm')
19.62 +
19.63 +| Split_And => ("Split_And", Split_And)
19.64 +| Conclude_And => ("Conclude_And", Conclude_And)
19.65 +| Split_Or => ("Split_Or", Split_Or)
19.66 +| Conclude_Or => ("Conclude_Or", Conclude_Or)
19.67 +| Begin_Trans => ("Begin_Trans", Begin_Trans)
19.68 +| End_Trans => ("End_Trans", End_Trans)
19.69 +| Begin_Sequ => ("Begin_Sequ", Begin_Sequ)
19.70 +| End_Sequ => ("End_Sequ", Begin_Sequ)
19.71 +| Split_Intersect => ("Split_Intersect", Split_Intersect)
19.72 +| End_Intersect => ("End_Intersect", End_Intersect)
19.73 +| Check_elementwise cterm' => ("Check_elementwise", Check_elementwise cterm')
19.74 +| Or_to_List => ("Or_to_List", Or_to_List)
19.75 +| Collect_Trues => ("Collect_Results", Collect_Trues)
19.76 +
19.77 +| Empty_Tac => ("Empty_Tac",Empty_Tac)
19.78 +| Tac string => ("Tac",Tac string)
19.79 +| User => ("User",User)
19.80 +| End_Proof' => ("End_Proof'",End_Proof');
19.81 +
19.82 +(*Detail*)
19.83 +val empty_tac'_ = (mk_tac'_ Empty_Tac):tac'_;
19.84 +
19.85 +fun mk_tac ((_,m):tac'_) = m;
19.86 +fun mk_mstID ((mI,_):tac'_) = mI;
19.87 +
19.88 +fun tac'_2str ((ID,ms):tac'_) = ID ^ (tac2str ms);
19.89 +(* TODO: tac2str, tac'_2str NOT tested *)
19.90 +
19.91 +
19.92 +
19.93 +type squ = ptree; (* TODO: safe etc. *)
19.94 +
19.95 +(*13.9.02--------------
19.96 +type ctr = (loc * pos) list;
19.97 +val ops = [("PLUS","op +"),("minus","op -"),("TIMES","op *"),
19.98 + ("cancel","cancel"),("pow","pow"),("sqrt","sqrt")];
19.99 +fun op_intern op_ =
19.100 + case assoc (ops,op_) of
19.101 + SOME op' => op' | NONE => raise error ("op_intern: no op= "^op_);
19.102 +-----------------------*)
19.103 +
19.104 +
19.105 +
19.106 +(* use"ME/solve.sml";
19.107 + use"solve.sml";
19.108 +
19.109 +val ttt = (term_of o the o (parse thy))"Substitute [(bdv,x)] g";
19.110 +val ttt = (term_of o the o (parse thy))"Rewrite thmid True g";
19.111 +
19.112 + Const ("Script.Rewrite'_Inst",_) $ sub $ Free (thm',_) $ Const (pa,_) $ f'
19.113 + *)
19.114 +
19.115 +
19.116 +
19.117 +val specsteps = ["Init_Proof","Refine_Tacitly","Refine_Problem",
19.118 + "Model_Problem",(*"Match_Problem",*)
19.119 + "Add_Given","Del_Given","Add_Find","Del_Find",
19.120 + "Add_Relation","Del_Relation",
19.121 + "Specify_Theory","Specify_Problem","Specify_Method"];
19.122 +
19.123 +"-----------------------------------------------------------------------";
19.124 +
19.125 +
19.126 +fun step2taci ((tac_, _, pt, p, _):step) = (*FIXXME.040312: redesign step*)
19.127 + (tac_2tac tac_, tac_, (p, get_istate pt p)):taci;
19.128 +
19.129 +
19.130 +(*FIXME.WN050821 compare solve ... nxt_solv*)
19.131 +(* val ("Apply_Method",Apply_Method' (mI,_))=(mI,m);
19.132 + val (("Apply_Method",Apply_Method' (mI,_,_)),pt, pos as (p,_))=(m,pt, pos);
19.133 + *)
19.134 +fun solve ("Apply_Method", m as Apply_Method' (mI, _, _))
19.135 + (pt:ptree, (pos as (p,_))) =
19.136 + let val {srls,...} = get_met mI;
19.137 + val PblObj{meth=itms,...} = get_obj I pt p;
19.138 + val thy' = get_obj g_domID pt p;
19.139 + val thy = assoc_thy thy';
19.140 + val (is as ScrState (env,_,_,_,_,_), sc) = init_scrstate thy itms mI;
19.141 + val ini = init_form thy sc env;
19.142 + val p = lev_dn p;
19.143 + in
19.144 + case ini of
19.145 + SOME t => (* val SOME t = ini;
19.146 + *)
19.147 + let val (pos,c,_,pt) =
19.148 + generate1 thy (Apply_Method' (mI, SOME t, is))
19.149 + is (lev_on p, Frm)(*implicit Take*) pt;
19.150 + in ("ok",([(Apply_Method mI, Apply_Method' (mI, SOME t, is),
19.151 + ((lev_on p, Frm), is))], c, (pt,pos)):calcstate')
19.152 + end
19.153 + | NONE => (*execute the first tac in the Script, compare solve m*)
19.154 + let val (m', is', _) = next_tac (thy', srls) (pt, (p, Res)) sc is;
19.155 + val d = e_rls (*FIXME: get simplifier from domID*);
19.156 + in
19.157 + case locate_gen (thy',srls) m' (pt,(p, Res))(sc,d) is' of
19.158 + Steps (is'', ss as (m'',f',pt',p',c')::_) =>
19.159 +(* val Steps (is'', ss as (m'',f',pt',p',c')::_) =
19.160 + locate_gen (thy',srls) m' (pt,(p,Res)) (sc,d) is';
19.161 + *)
19.162 + ("ok", (map step2taci ss, c', (pt',p')))
19.163 + | NotLocatable =>
19.164 + let val (p,ps,f,pt) =
19.165 + generate_hard (assoc_thy "Isac.thy") m (p,Frm) pt;
19.166 + in ("not-found-in-script",
19.167 + ([(tac_2tac m, m, (pos, is))], ps, (pt,p))) end
19.168 + (*just-before------------------------------------------------------
19.169 + ("ok",([(Apply_Method mI,Apply_Method'(mI,NONE,e_istate),
19.170 + (pos, is))],
19.171 + [], (update_env pt (fst pos) (SOME is),pos)))
19.172 + -----------------------------------------------------------------*)
19.173 + end
19.174 + end
19.175 +
19.176 + | solve ("Free_Solve", Free_Solve') (pt,po as (p,_)) =
19.177 + let (*val _=writeln"###solve Free_Solve";*)
19.178 + val p' = lev_dn_ (p,Res);
19.179 + val pt = update_metID pt (par_pblobj pt p) e_metID;
19.180 + in ("ok", ((*(p',Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Unsafe,*)
19.181 + [(Empty_Tac, Empty_Tac_, (po, Uistate))], [], (pt,p'))) end
19.182 +
19.183 +(* val (("Check_Postcond",Check_Postcond' (pI,_)), (pt,(pos as (p,p_)))) =
19.184 + ( m, (pt, pos));
19.185 + *)
19.186 + | solve ("Check_Postcond",Check_Postcond' (pI,_)) (pt,(pos as (p,p_))) =
19.187 + let (*val _=writeln"###solve Check_Postcond";*)
19.188 + val pp = par_pblobj pt p
19.189 + val asm = (case get_obj g_tac pt p of
19.190 + Check_elementwise _ => (*collects and instantiates asms*)
19.191 + (snd o (get_obj g_result pt)) p
19.192 + | _ => ((map fst) o (get_assumptions_ pt)) (p,p_))
19.193 + handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*)
19.194 + val metID = get_obj g_metID pt pp;
19.195 + val {srls=srls,scr=sc,...} = get_met metID;
19.196 + val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_);
19.197 + (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_)));
19.198 + val _= writeln("### solve Check_postc, is= "^(istate2str is));*)
19.199 + val thy' = get_obj g_domID pt pp;
19.200 + val thy = assoc_thy thy';
19.201 + val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is;
19.202 + (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*)
19.203 +
19.204 + in if pp = [] then
19.205 + let val is = ScrState (E,l,a,scval,scsaf,b)
19.206 + val tac_ = Check_Postcond'(pI,(scval, map term2str asm))
19.207 + val (pos,ps,f,pt) = generate1 thy tac_ is (pp,Res) pt;
19.208 + in ("ok", ((*(([],Res),is,End_Proof''), f, End_Proof', scsaf,*)
19.209 + [(Check_Postcond pI, tac_, ((pp,Res),is))], ps,(pt,pos))) end
19.210 + else
19.211 + let
19.212 + (*resume script of parpbl, transfer value of subpbl-script*)
19.213 + val ppp = par_pblobj pt (lev_up p);
19.214 + val thy' = get_obj g_domID pt ppp;
19.215 + val thy = assoc_thy thy';
19.216 + val metID = get_obj g_metID pt ppp;
19.217 + val sc = (#scr o get_met) metID;
19.218 + val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm);
19.219 + (*val _=writeln("### solve Check_postc, parpbl pos= "^(pos'2str(pp,Frm)));
19.220 + val _=writeln("### solve Check_postc, is(pt)= "^(istate2str is));
19.221 + val _=writeln("### solve Check_postc, is'= "^
19.222 + (istate2str (E,l,a,scval,scsaf,b)));*)
19.223 + val ((p,p_),ps,f,pt) =
19.224 + generate1 thy (Check_Postcond' (pI, (scval, map term2str asm)))
19.225 + (ScrState (E,l,a,scval,scsaf,b)) (pp,Res) pt;
19.226 + (*val _=writeln("### solve Check_postc, is(pt')= "^
19.227 + (istate2str (get_istate pt ([3],Res))));
19.228 + val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) sc
19.229 + (ScrState (E,l,a,scval,scsaf,b));*)
19.230 + in ("ok",(*((pp,Res),is',nx), f, tac_2tac nx, scsaf,*)
19.231 + ([(Check_Postcond pI, Check_Postcond'(pI,(scval, map term2str asm)),
19.232 + ((pp,Res), ScrState (E,l,a,scval,scsaf,b)))],ps,(pt,(p,p_))))
19.233 + end
19.234 + end
19.235 +(* val (msg, cs') =
19.236 + ("ok",([(Check_Postcond pI,Check_Postcond'(pI, (scval, map term2str asm))),
19.237 + ((pp,Res),(ScrState (E,l,a,scval,scsaf,b)))], (pt,(p,p_))));
19.238 + val (_,(pt',p')) = cs';
19.239 + (writeln o istate2str) (get_istate pt' p');
19.240 + (term2str o fst) (get_obj g_result pt' (fst p'));
19.241 + *)
19.242 +
19.243 +(* writeln(istate2str(get_istate pt (p,p_)));
19.244 + *)
19.245 + | solve (_,End_Proof'') (pt, (p,p_)) =
19.246 + ("end-proof",
19.247 + ((*(([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe,*)
19.248 + [(Empty_Tac,Empty_Tac_,(([],Res),Uistate))],[],(pt,(p,p_))))
19.249 +
19.250 +(*-----------vvvvvvvvvvv could be done by generate1 ?!?*)
19.251 + | solve (_,End_Detail' t) (pt,(p,p_)) =
19.252 + let val pr as (p',_) = (lev_up p, Res)
19.253 + val pp = par_pblobj pt p
19.254 + val r = (fst o (get_obj g_result pt)) p'
19.255 + (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*)
19.256 + val thy' = get_obj g_domID pt pp
19.257 + val (srls, is, sc) = from_pblobj' thy' pr pt
19.258 + val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is
19.259 + in ("ok", ((*((pp,Frm(*???*)),is,tac_),
19.260 + Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)),
19.261 + tac_2tac tac_, Sundef,*)
19.262 + [(End_Detail, End_Detail' t ,
19.263 + ((p,p_), get_istate pt (p,p_)))], [], (pt,pr))) end
19.264 +
19.265 + | solve (mI,m) (pt, po as (p,p_)) =
19.266 +(* val ((mI,m), (pt, po as (p,p_))) = (m, (pt, pos));
19.267 + *)
19.268 + if e_metID = get_obj g_metID pt (par_pblobj pt p)(*29.8.02:
19.269 + could be detail, too !!*)
19.270 + then let val ((p,p_),ps,f,pt) =
19.271 + generate1 (assoc_thy (get_obj g_domID pt (par_pblobj pt p)))
19.272 + m e_istate (p,p_) pt;
19.273 + in ("no-method-specified", (*Free_Solve*)
19.274 + ((*((p,p_),Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*)
19.275 + [(Empty_Tac,Empty_Tac_, ((p,p_),Uistate))], ps, (pt,(p,p_)))) end
19.276 + else
19.277 + let
19.278 + val thy' = get_obj g_domID pt (par_pblobj pt p);
19.279 + val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt;
19.280 +(*val _= writeln("### solve, before locate_gen p="^(pos'2str(p,p_)));*)
19.281 + val d = e_rls; (*FIXME: canon.simplifier for domain is missing
19.282 + 8.01: generate from domID?*)
19.283 + in case locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is of
19.284 + Steps (is', ss as (m',f',pt',p',c')::_) =>
19.285 +(* val Steps (is', ss as (m',f',pt',p',c')::_) =
19.286 + locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is;
19.287 + *)
19.288 + let (*val _= writeln("### solve, after locate_gen: is= ")
19.289 + val _= writeln(istate2str is')*)
19.290 + (*val nxt_ =
19.291 + case p' of (*change from solve to model subpbl*)
19.292 + (_,Pbl) => nxt_model_pbl m' (pt',p')
19.293 + | _ => fst3 (next_tac (thy',srls) (pt',p') sc is');*)
19.294 + (*27.8.02:next_tac may change to other branches in pt FIXXXXME*)
19.295 + in ("ok", ((*(p',is',nxt_), f', tac_2tac nxt_, safe is',*)
19.296 + map step2taci ss, c', (pt',p'))) end
19.297 + | NotLocatable =>
19.298 + let val (p,ps,f,pt) =
19.299 + generate_hard (assoc_thy "Isac.thy") m (p,p_) pt;
19.300 + in ("not-found-in-script",
19.301 + ((*(p,Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*)
19.302 + [(tac_2tac m, m, (po,is))], ps, (pt,p))) end
19.303 + end;
19.304 +
19.305 +
19.306 +(*FIXME.WN050821 compare solve ... nxt_solv*)
19.307 +(* nxt_solv (Apply_Method' vvv FIXME: get args in applicable_in *)
19.308 +fun nxt_solv (Apply_Method' (mI,_,_)) _ (pt:ptree, pos as (p,_)) =
19.309 +(* val ((Apply_Method' (mI,_,_)), _, (pt:ptree, pos as (p,_))) =
19.310 + ((Apply_Method' (mI, NONE, e_istate)), e_istate, ptp);
19.311 + *)
19.312 + let val {srls,ppc,...} = get_met mI;
19.313 + val PblObj{meth=itms,origin=(oris,_,_),probl,...} = get_obj I pt p;
19.314 + val itms = if itms <> [] then itms
19.315 + else complete_metitms oris probl [] ppc
19.316 + val thy' = get_obj g_domID pt p;
19.317 + val thy = assoc_thy thy';
19.318 + val (is as ScrState (env,_,_,_,_,_), scr) = init_scrstate thy itms mI;
19.319 + val ini = init_form thy scr env;
19.320 + in
19.321 + case ini of
19.322 + SOME t => (* val SOME t = ini;
19.323 + *)
19.324 + let val pos = ((lev_on o lev_dn) p, Frm)
19.325 + val tac_ = Apply_Method' (mI, SOME t, is);
19.326 + val (pos,c,_,pt) = (*implicit Take*)
19.327 + generate1 thy tac_ is pos pt
19.328 + (*val _= ("### nxt_solv Apply_Method, pos= "^pos'2str (lev_on p,Frm));*)
19.329 + in ([(Apply_Method mI, tac_, (pos, is))], c, (pt, pos)):calcstate' end
19.330 + | NONE =>
19.331 + let val pt = update_env pt (fst pos) (SOME is)
19.332 + val (tacis, c, ptp) = nxt_solve_ (pt, pos)
19.333 + in (tacis @
19.334 + [(Apply_Method mI, Apply_Method' (mI, NONE, e_istate), (pos, is))],
19.335 + c, ptp) end
19.336 + end
19.337 +(* val ("Check_Postcond",Check_Postcond' (pI,_)) = (mI,m);
19.338 + val (Check_Postcond' (pI,_), _, (pt, pos as (p,p_))) =
19.339 + (tac_, is, ptp);
19.340 + *)
19.341 + (*TODO.WN050913 remove unnecessary code below*)
19.342 + | nxt_solv (Check_Postcond' (pI,_)) _ (pt, pos as (p,p_)) =
19.343 + let (*val _=writeln"###solve Check_Postcond";*)
19.344 + val pp = par_pblobj pt p
19.345 + val asm = (case get_obj g_tac pt p of
19.346 + Check_elementwise _ => (*collects and instantiates asms*)
19.347 + (snd o (get_obj g_result pt)) p
19.348 + | _ => ((map fst) o (get_assumptions_ pt)) (p,p_))
19.349 + handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*)
19.350 + val metID = get_obj g_metID pt pp;
19.351 + val {srls=srls,scr=sc,...} = get_met metID;
19.352 + val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_);
19.353 + (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_)));
19.354 + val _= writeln("### solve Check_postc, is= "^(istate2str is));*)
19.355 + val thy' = get_obj g_domID pt pp;
19.356 + val thy = assoc_thy thy';
19.357 + val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is;
19.358 + (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*)
19.359 + in if pp = [] then
19.360 + let val is = ScrState (E,l,a,scval,scsaf,b)
19.361 + val tac_ = Check_Postcond'(pI,(scval, map term2str asm))
19.362 + (*val _= writeln"### nxt_solv2 Apply_Method: stored is =";
19.363 + val _= writeln(istate2str is);*)
19.364 + val ((p,p_),ps,f,pt) =
19.365 + generate1 thy tac_ is (pp,Res) pt;
19.366 + in ([(Check_Postcond pI, tac_, ((pp,Res), is))],ps,(pt, (p,p_))) end
19.367 + else
19.368 + let
19.369 + (*resume script of parpbl, transfer value of subpbl-script*)
19.370 + val ppp = par_pblobj pt (lev_up p);
19.371 + val thy' = get_obj g_domID pt ppp;
19.372 + val thy = assoc_thy thy';
19.373 + val metID = get_obj g_metID pt ppp;
19.374 + val {scr,...} = get_met metID;
19.375 + val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm)
19.376 + val tac_ = Check_Postcond' (pI, (scval, map term2str asm))
19.377 + val is = ScrState (E,l,a,scval,scsaf,b)
19.378 + (*val _= writeln"### nxt_solv3 Apply_Method: stored is =";
19.379 + val _= writeln(istate2str is);*)
19.380 + val ((p,p_),ps,f,pt) = generate1 thy tac_ is (pp, Res) pt;
19.381 + (*val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) scr is;WN050913*)
19.382 + in ([(Check_Postcond pI, tac_, ((pp, Res), is))], ps, (pt, (p,p_))) end
19.383 + end
19.384 +(* writeln(istate2str(get_istate pt (p,p_)));
19.385 + *)
19.386 +
19.387 +(*.start interpreter and do one rewrite.*)
19.388 +(* val (_,Detail_Set'(thy',rls,t)) = (mI,m); val p = (p,p_);
19.389 + solve ("",Detail_Set'(thy', rls, t)) p pt;
19.390 + | nxt_solv (Detail_Set'(thy', rls, t)) _ (pt, p) = **********
19.391 +---> Frontend/sml.sml
19.392 +
19.393 + | nxt_solv (End_Detail' t) _ (pt, (p,p_)) = **********
19.394 + let val pr as (p',_) = (lev_up p, Res)
19.395 + val pp = par_pblobj pt p
19.396 + val r = (fst o (get_obj g_result pt)) p'
19.397 + (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*)
19.398 + val thy' = get_obj g_domID pt pp
19.399 + val (srls, is, sc) = from_pblobj' thy' pr pt
19.400 + val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is
19.401 + in (pr, ((pp,Frm(*???*)),is,tac_),
19.402 + Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)),
19.403 + tac_2tac tac_, Sundef, pt) end
19.404 +*)
19.405 + | nxt_solv (End_Proof'') _ ptp = ([], [], ptp)
19.406 +
19.407 + | nxt_solv tac_ is (pt, pos as (p,p_)) =
19.408 +(* val (pt, pos as (p,p_)) = ptp;
19.409 + *)
19.410 + let val pos = case pos of
19.411 + (p, Met) => ((lev_on o lev_dn) p, Frm)(*begin script*)
19.412 + | (p, Res) => (lev_on p,Res) (*somewhere in script*)
19.413 + | _ => pos (*somewhere in script*)
19.414 + (*val _= writeln"### nxt_solv4 Apply_Method: stored is =";
19.415 + val _= writeln(istate2str is);*)
19.416 + val (pos',c,_,pt) = generate1 (assoc_thy "Isac.thy") tac_ is pos pt;
19.417 + in ([(tac_2tac tac_, tac_, (pos,is))], c, (pt, pos')) end
19.418 +
19.419 +
19.420 + (*(p,p_), (([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe, pt*)
19.421 +
19.422 +
19.423 +(*.find the next tac from the script, nxt_solv will update the ptree.*)
19.424 +(* val (ptp as (pt,pos as (p,p_))) = ptp';
19.425 + val (ptp as (pt, pos as (p,p_))) = ptp'';
19.426 + val (ptp as (pt, pos as (p,p_))) = ptp;
19.427 + val (ptp as (pt, pos as (p,p_))) = (pt,ip);
19.428 + val (ptp as (pt, pos as (p,p_))) = (pt, pos);
19.429 + *)
19.430 +and nxt_solve_ (ptp as (pt, pos as (p,p_))) =
19.431 + if e_metID = get_obj g_metID pt (par_pblobj pt p)
19.432 + then ([], [], (pt,(p,p_))):calcstate'
19.433 + else let val thy' = get_obj g_domID pt (par_pblobj pt p);
19.434 + val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt;
19.435 + val (tac_,is,(t,_)) = next_tac (thy',srls) (pt,pos) sc is;
19.436 + (*TODO here ^^^ return finished/helpless/ok !*)
19.437 + (* val (tac_',is',(t',_)) = next_tac (thy',srls) (pt,pos) sc is;
19.438 + *)
19.439 + in case tac_ of
19.440 + End_Detail' _ => ([(End_Detail,
19.441 + End_Detail' (t,[(*FIXME.040215*)]),
19.442 + (pos, is))], [], (pt, pos))
19.443 + | _ => nxt_solv tac_ is ptp end;
19.444 +
19.445 +(*.says how may steps of a calculation should be done by "fun autocalc".*)
19.446 +(*TODO.WN0512 redesign togehter with autocalc ?*)
19.447 +datatype auto =
19.448 + Step of int (*1 do #int steps; may stop in model/specify:
19.449 + IS VERY INEFFICIENT IN MODEL/SPECIY*)
19.450 +| CompleteModel (*2 complete modeling
19.451 + if model complete, finish specifying + start solving*)
19.452 +| CompleteCalcHead (*3 complete model/specify in one go + start solving*)
19.453 +| CompleteToSubpbl (*4 stop at the next begin of a subproblem,
19.454 + if none, complete the actual (sub)problem*)
19.455 +| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*)
19.456 +| CompleteCalc; (*6 complete the calculation as a whole*)
19.457 +fun autoord (Step _ ) = 1
19.458 + | autoord CompleteModel = 2
19.459 + | autoord CompleteCalcHead = 3
19.460 + | autoord CompleteToSubpbl = 4
19.461 + | autoord CompleteSubpbl = 5
19.462 + | autoord CompleteCalc = 6;
19.463 +
19.464 +(* val (auto, c, (ptp as (_, p))) = (auto, (c@c'), ptp);
19.465 + *)
19.466 +fun complete_solve auto c (ptp as (_, p): ptree * pos') =
19.467 + if p = ([], Res) then ("end-of-calculation", [], ptp) else
19.468 + case nxt_solve_ ptp of
19.469 + ((Subproblem _, tac_, (_, is))::_, c', ptp') =>
19.470 +(* val ptp' = ptp''';
19.471 + *)
19.472 + if autoord auto < 5 then ("ok", c@c', ptp)
19.473 + else let val ptp = all_modspec ptp';
19.474 + val (_, c'', ptp) = all_solve auto (c@c') ptp;
19.475 + in complete_solve auto (c@c'@c'') ptp end
19.476 + | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) =>
19.477 + if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp')
19.478 + else complete_solve auto (c@c') ptp'
19.479 + | ((End_Detail, _, _)::_, c', ptp') =>
19.480 + if autoord auto < 6 then ("ok", c@c', ptp')
19.481 + else complete_solve auto (c@c') ptp'
19.482 + | (_, c', ptp') => complete_solve auto (c@c') ptp'
19.483 +(* val (tacis, c', ptp') = nxt_solve_ ptp;
19.484 + val (tacis, c', ptp'') = nxt_solve_ ptp';
19.485 + val (tacis, c', ptp''') = nxt_solve_ ptp'';
19.486 + val (tacis, c', ptp'''') = nxt_solve_ ptp''';
19.487 + val (tacis, c', ptp''''') = nxt_solve_ ptp'''';
19.488 + *)
19.489 +and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') =
19.490 +(* val (ptp as (pt, (p,_))) = ptp;
19.491 + val (ptp as (pt, (p,_))) = ptp';
19.492 + val (ptp as (pt, (p,_))) = (pt, pos);
19.493 + *)
19.494 + let val (_,_,mI) = get_obj g_spec pt p;
19.495 + val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate))
19.496 + e_istate ptp;
19.497 + in complete_solve auto (c@c') ptp end;
19.498 +(*@@@ vvv @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
19.499 +fun complete_solve auto c (ptp as (_, p as (_,p_)): ptree * pos') =
19.500 + if p = ([], Res) then ("end-of-calculation", [], ptp) else
19.501 + if member op = [Pbl,Met] p_
19.502 + then let val ptp = all_modspec ptp
19.503 + val (_, c', ptp) = all_solve auto c ptp
19.504 + in complete_solve auto (c@c') ptp end
19.505 + else case nxt_solve_ ptp of
19.506 + ((Subproblem _, tac_, (_, is))::_, c', ptp') =>
19.507 + if autoord auto < 5 then ("ok", c@c', ptp)
19.508 + else let val ptp = all_modspec ptp'
19.509 + val (_, c'', ptp) = all_solve auto (c@c') ptp
19.510 + in complete_solve auto (c@c'@c'') ptp end
19.511 + | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) =>
19.512 + if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp')
19.513 + else complete_solve auto (c@c') ptp'
19.514 + | ((End_Detail, _, _)::_, c', ptp') =>
19.515 + if autoord auto < 6 then ("ok", c@c', ptp')
19.516 + else complete_solve auto (c@c') ptp'
19.517 + | (_, c', ptp') => complete_solve auto (c@c') ptp'
19.518 +and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') =
19.519 + let val (_,_,mI) = get_obj g_spec pt p
19.520 + val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate))
19.521 + e_istate ptp
19.522 + in complete_solve auto (c@c') ptp end;
19.523 +
19.524 +(*.aux.fun for detailrls with Rrls, reverse rewriting.*)
19.525 +(* val (nds, t, ((rule, (t', asm)) :: rts)) = ([], t, rul_terms);
19.526 + *)
19.527 +fun rul_terms_2nds nds t [] = nds
19.528 + | rul_terms_2nds nds t ((rule, res as (t', _)) :: rts) =
19.529 + (append_atomic [] e_istate t (rule2tac [] rule) res Complete EmptyPtree) ::
19.530 + (rul_terms_2nds nds t' rts);
19.531 +
19.532 +
19.533 +(*. detail steps done internally by Rewrite_Set*
19.534 + into ctree by use of a script .*)
19.535 +(* val (pt, (p,p_)) = (pt, pos);
19.536 + *)
19.537 +fun detailrls pt ((p,p_):pos') =
19.538 + let val t = get_obj g_form pt p
19.539 + val tac = get_obj g_tac pt p
19.540 + val rls = (assoc_rls o rls_of) tac
19.541 + in case rls of
19.542 +(* val Rrls {scr = Rfuns {init_state,...},...} = rls;
19.543 + *)
19.544 + Rrls {scr = Rfuns {init_state,...},...} =>
19.545 + let val (_,_,_,rul_terms) = init_state t
19.546 + val newnds = rul_terms_2nds [] t rul_terms
19.547 + val pt''' = ins_chn newnds pt p
19.548 + in ("detailrls", pt''', (p @ [length newnds], Res):pos') end
19.549 + | _ =>
19.550 + let val is = init_istate tac t
19.551 + (*TODO.WN060602 ScrState (["(t_, Problem (Isac,[equation,univar]))"]
19.552 + is wrong for simpl, but working ?!? *)
19.553 + val tac_ = Apply_Method' (e_metID(*WN0402: see generate1 !?!*),
19.554 + SOME t, is)
19.555 + val pos' = ((lev_on o lev_dn) p, Frm)
19.556 + val thy = assoc_thy "Isac.thy"
19.557 + val (_,_,_,pt') = (*implicit Take*)generate1 thy tac_ is pos' pt
19.558 + val (_,_,(pt'',_)) = complete_solve CompleteSubpbl [] (pt',pos')
19.559 + val newnds = children (get_nd pt'' p)
19.560 + val pt''' = ins_chn newnds pt p
19.561 + (*complete_solve cuts branches after*)
19.562 + in ("detailrls", pt'''(*, get_formress [] ((lev_on o lev_dn) p)cn*),
19.563 + (p @ [length newnds], Res):pos') end
19.564 + end;
19.565 +
19.566 +
19.567 +
19.568 +(* val(mI,m)=m;val ppp=p;(*!!!*)val(p,p_)=pos;val(_,pt,_)=ppp(*!!!*);
19.569 + get_form ((mI,m):tac'_) ((p,p_):pos') ppp;
19.570 + *)
19.571 +fun get_form ((mI,m):tac'_) ((p,p_):pos') pt =
19.572 + case applicable_in (p,p_) pt m of
19.573 + Notappl e => Error' (Error_ e)
19.574 + | Appl m =>
19.575 + (* val Appl m=applicable_in (p,p_) pt m;
19.576 + *)
19.577 + if member op = specsteps mI
19.578 + then let val (_,_,f,_,_,_) = specify m (p,p_) [] pt
19.579 + in f end
19.580 + else let val (*_,_,f,_,_,_*)_ = solve (mI,m) (pt,(p,p_))
19.581 + in (*f*) EmptyMout end;
19.582 +
20.1 --- a/src/Tools/isac/IsacKnowledge/AlgEin.ML Wed Aug 25 15:15:01 2010 +0200
20.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
20.3 @@ -1,141 +0,0 @@
20.4 -(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt
20.5 - author: Walther Neuper 2007
20.6 - (c) due to copyright terms
20.7 -
20.8 -use"IsacKnowledge/AlgEin.ML";
20.9 -use"AlgEin.ML";
20.10 -
20.11 -remove_thy"Typefix";
20.12 -remove_thy"AlgEin";
20.13 -use_thy"IsacKnowledge/Isac";
20.14 -*)
20.15 -
20.16 -(** interface isabelle -- isac **)
20.17 -
20.18 -theory' := overwritel (!theory', [("AlgEin.thy",AlgEin.thy)]);
20.19 -
20.20 -(** problems **)
20.21 -
20.22 -store_pbt
20.23 - (prep_pbt AlgEin.thy "pbl_algein" [] e_pblID
20.24 - (["Berechnung"], [], e_rls, NONE,
20.25 - []));
20.26 -(* WN070405
20.27 -store_pbt
20.28 - (prep_pbt AlgEin.thy "pbl_algein_num" [] e_pblID
20.29 - (["numerische", "Berechnung"],
20.30 - [("#Given" ,["KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]),
20.31 - ("#Find" ,["GesamtLaenge l_"])
20.32 - ],
20.33 - append_rls "e_rls" e_rls [],
20.34 - NONE,
20.35 - []));
20.36 -*)
20.37 -store_pbt
20.38 - (prep_pbt AlgEin.thy "pbl_algein_numsym" [] e_pblID
20.39 - (["numerischSymbolische", "Berechnung"],
20.40 - [("#Given" ,["KantenLaenge k_","Querschnitt q__"(*q_ in Biegelinie.thy*),
20.41 - "KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]),
20.42 - ("#Find" ,["GesamtLaenge l_"])
20.43 - ],
20.44 - e_rls,
20.45 - NONE,
20.46 - [["Berechnung","erstNumerisch"],["Berechnung","erstSymbolisch"]]));
20.47 -
20.48 -(* show_ptyps();
20.49 - *)
20.50 -
20.51 -
20.52 -(** methods **)
20.53 -
20.54 -store_met
20.55 - (prep_met AlgEin.thy "met_algein" [] e_metID
20.56 - (["Berechnung"],
20.57 - [],
20.58 - {rew_ord'="tless_true", rls'= Erls, calc = [],
20.59 - srls = Erls, prls = Erls,
20.60 - crls =Erls , nrls = Erls},
20.61 -"empty_script"
20.62 -));
20.63 -
20.64 -store_met
20.65 - (prep_met AlgEin.thy "met_algein_numsym" [] e_metID
20.66 - (["Berechnung","erstNumerisch"],
20.67 - [],
20.68 - {rew_ord'="tless_true", rls'= Erls, calc = [],
20.69 - srls = Erls, prls = Erls,
20.70 - crls =Erls , nrls = Erls},
20.71 -"empty_script"
20.72 -));
20.73 -
20.74 -store_met
20.75 - (prep_met AlgEin.thy "met_algein_numsym" [] e_metID
20.76 - (["Berechnung","erstNumerisch"],
20.77 - [("#Given" ,["KantenLaenge k_","Querschnitt q__",
20.78 - "KantenUnten u_", "KantenSenkrecht s_",
20.79 - "KantenOben o_"]),
20.80 - ("#Find" ,["GesamtLaenge l_"])
20.81 - ],
20.82 - {rew_ord'="tless_true", rls'= e_rls, calc = [],
20.83 - srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls
20.84 - [Calc ("Atools.boollist2sum",
20.85 - eval_boollist2sum "")],
20.86 - prls = e_rls, crls =e_rls , nrls = norm_Rational},
20.87 -"Script RechnenSymbolScript (k_::bool) (q__::bool) \
20.88 -\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\
20.89 -\ (let t_ = Take (l_ = oben + senkrecht + unten); \
20.90 -\ sum_ = boollist2sum o_;\
20.91 -\ t_ = Substitute [oben = sum_] t_;\
20.92 -\ t_ = Substitute o_ t_;\
20.93 -\ t_ = Substitute [k_, q__] t_;\
20.94 -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
20.95 -\ sum_ = boollist2sum s_;\
20.96 -\ t_ = Substitute [senkrecht = sum_] t_;\
20.97 -\ t_ = Substitute s_ t_;\
20.98 -\ t_ = Substitute [k_, q__] t_;\
20.99 -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
20.100 -\ sum_ = boollist2sum u_;\
20.101 -\ t_ = Substitute [unten = sum_] t_;\
20.102 -\ t_ = Substitute u_ t_;\
20.103 -\ t_ = Substitute [k_, q__] t_;\
20.104 -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_\
20.105 -\ in (Try (Rewrite_Set norm_Poly False)) t_)"
20.106 -));
20.107 -
20.108 -store_met
20.109 - (prep_met AlgEin.thy "met_algein_symnum" [] e_metID
20.110 - (["Berechnung","erstSymbolisch"],
20.111 - [("#Given" ,["KantenLaenge k_","Querschnitt q__",
20.112 - "KantenUnten u_", "KantenSenkrecht s_",
20.113 - "KantenOben o_"]),
20.114 - ("#Find" ,["GesamtLaenge l_"])
20.115 - ],
20.116 - {rew_ord'="tless_true", rls'= e_rls, calc = [],
20.117 - srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls
20.118 - [Calc ("Atools.boollist2sum",
20.119 - eval_boollist2sum "")],
20.120 - prls = e_rls,
20.121 - crls =e_rls , nrls = norm_Rational},
20.122 -"Script RechnenSymbolScript (k_::bool) (q__::bool) \
20.123 -\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\
20.124 -\ (let t_ = Take (l_ = oben + senkrecht + unten); \
20.125 -\ sum_ = boollist2sum o_;\
20.126 -\ t_ = Substitute [oben = sum_] t_;\
20.127 -\ t_ = Substitute o_ t_;\
20.128 -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
20.129 -\ sum_ = boollist2sum s_;\
20.130 -\ t_ = Substitute [senkrecht = sum_] t_;\
20.131 -\ t_ = Substitute s_ t_;\
20.132 -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
20.133 -\ sum_ = boollist2sum u_;\
20.134 -\ t_ = Substitute [unten = sum_] t_;\
20.135 -\ t_ = Substitute u_ t_;\
20.136 -\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
20.137 -\ t_ = Substitute [k_, q__] t_\
20.138 -\ in (Try (Rewrite_Set norm_Poly False)) t_)"
20.139 -));
20.140 -
20.141 -(* show_mets();
20.142 - *)
20.143 -(* use"IsacKnowledge/AlgEin.ML";
20.144 - *)
20.145 \ No newline at end of file
21.1 --- a/src/Tools/isac/IsacKnowledge/AlgEin.thy Wed Aug 25 15:15:01 2010 +0200
21.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3 @@ -1,37 +0,0 @@
21.4 -(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt
21.5 - author: Walther Neuper 2007
21.6 - (c) due to copyright terms
21.7 -
21.8 -remove_thy"AlgEin";
21.9 -use_thy"IsacKnowledge/AlgEin";
21.10 -use_thy_only"IsacKnowledge/AlgEin";
21.11 -
21.12 -remove_thy"AlgEin";
21.13 -use_thy"IsacKnowledge/Isac";
21.14 -*)
21.15 -
21.16 -AlgEin = Rational +
21.17 -(*Poly + ..shouldbe sufficient, but norm_Poly *)
21.18 -
21.19 -consts
21.20 -
21.21 - (*new Descriptions in the related problems*)
21.22 - KantenUnten :: bool list => una
21.23 - KantenSenkrecht :: bool list => una
21.24 - KantenOben :: bool list => una
21.25 - KantenLaenge :: bool => una
21.26 - Querschnitt :: bool => una
21.27 - GesamtLaenge :: real => una
21.28 -
21.29 - (*Script-names*)
21.30 - RechnenSymbolScript :: "[bool,bool,bool list,bool list,bool list,real,
21.31 - bool] => bool"
21.32 - ("((Script RechnenSymbolScript (_ _ _ _ _ _ =))// (_))" 9)
21.33 -
21.34 -(*
21.35 -rules
21.36 - (*this axiom creates a contradictory formal system,
21.37 - see problem TOOODO *)
21.38 -*)
21.39 -
21.40 -end
22.1 --- a/src/Tools/isac/IsacKnowledge/Atools.ML Wed Aug 25 15:15:01 2010 +0200
22.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3 @@ -1,645 +0,0 @@
22.4 -(* tools for arithmetic
22.5 - WN.8.3.01
22.6 - use"../IsacKnowledge/Atools.ML";
22.7 - use"IsacKnowledge/Atools.ML";
22.8 - use"Atools.ML";
22.9 - *)
22.10 -
22.11 -(*
22.12 -copy from doc/math-eng.tex WN.28.3.03
22.13 -WN071228 extended
22.14 -
22.15 -\section{Coding standards}
22.16 -
22.17 -%WN071228 extended -----vvv
22.18 -\subsection{Identifiers}
22.19 -Naming is particularily crucial, because Isabelles name space is global, and isac does not yet use the novel locale features introduces by Isar. For instance, {\tt probe} sounds reasonable as (1) a description in the model of a problem-pattern, (2) as an element of the problem hierarchies key, (3) as a socalled CAS-command, (4) as the name of a related script etc. However, all the cases (1)..(4) require different typing for one and the same identifier {\tt probe} which is impossible, and actually leads to strange errors (for instance (1) is used as string, except in a script addressing a Subproblem).
22.20 -
22.21 -This are the preliminary rules for naming identifiers>
22.22 -\begin{description}
22.23 -\item [elements of a key] into the hierarchy of problems or methods must not contain capital letters and may contain underscrores, e.g. {\tt probe, for_polynomials}.
22.24 -\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}.
22.25 -\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~!
22.26 -\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}.
22.27 -\item [???] ???
22.28 -\item [???] ???
22.29 -\end{description}
22.30 -%WN071228 extended -----^^^
22.31 -
22.32 -
22.33 -\subsection{Rule sets}
22.34 -The actual version of the coding standards for rulesets is in {\tt /IsacKnowledge/Atools.ML where it can be viewed using the knowledge browsers.
22.35 -
22.36 -There are rulesets visible to the student, and there are rulesets visible (in general) only for math authors. There are also rulesets which {\em must} exist for {\em each} theory; these contain the identifier of the respective theory (including all capital letters) as indicated by {\it Thy} below.
22.37 -\begin{description}
22.38 -
22.39 -\item [norm\_{\it Thy}] exists for each theory, and {\em efficiently} calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents).
22.40 -
22.41 -\item [simplify\_{\it Thy}] exists for each theory, and calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents) such, that the rewrites can be presented to the student.
22.42 -
22.43 -\item [calculate\_{\it Thy}] exists for each theory, and evaluates terms with numerical constants only (i.e. all terms which can be expressed by the definitions of the respective theory and the respective parent theories). In particular, this ruleset includes evaluating in/equalities with numerical constants only.
22.44 -WN.3.7.03: may be dropped due to more generality: numericals and non-numericals are logically equivalent, where the latter often add to the assumptions (e.g. in Check_elementwise).
22.45 -
22.46 -\end{description}
22.47 -The above rulesets are all visible to the user, and also may be input; thus they must be contained in the global associationlist {\tt ruleset':= }~! All these rulesets must undergo a preparation using the function {\tt prep_rls}, which generates a script for stepwise rewriting etc.
22.48 -The following rulesets are used for internal purposes and usually invisible to the (naive) user:
22.49 -\begin{description}
22.50 -
22.51 -\item [*\_erls]
22.52 -\item [*\_prls]
22.53 -\item [*\_srls]
22.54 -
22.55 -\end{description}
22.56 -{\tt append_rls, merge_rls, remove_rls}
22.57 -*)
22.58 -
22.59 -"******* Atools.ML begin *******";
22.60 -theory' := overwritel (!theory', [("Atools.thy",Atools.thy)]);
22.61 -
22.62 -(** evaluation of numerals and special predicates on the meta-level **)
22.63 -(*-------------------------functions---------------------*)
22.64 -local (* rlang 09.02 *)
22.65 - (*.a 'c is coefficient of v' if v does occur in c.*)
22.66 - fun coeff_in v c = member op = (vars c) v;
22.67 -in
22.68 - fun occurs_in v t = coeff_in v t;
22.69 -end;
22.70 -
22.71 -(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*)
22.72 -fun eval_occurs_in _ "Atools.occurs'_in"
22.73 - (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ =
22.74 - ((*writeln("@@@ eval_occurs_in: v= "^(term2str v));
22.75 - writeln("@@@ eval_occurs_in: t= "^(term2str t));*)
22.76 - if occurs_in v t
22.77 - then SOME ((term2str p) ^ " = True",
22.78 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
22.79 - else SOME ((term2str p) ^ " = False",
22.80 - Trueprop $ (mk_equality (p, HOLogic.false_const))))
22.81 - | eval_occurs_in _ _ _ _ = NONE;
22.82 -
22.83 -(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*)
22.84 -fun some_occur_in vs t =
22.85 - let fun occurs_in' a b = occurs_in b a
22.86 - in foldl or_ (false, map (occurs_in' t) vs) end;
22.87 -
22.88 -(*("some_occur_in", ("Atools.some'_occur'_in",
22.89 - eval_some_occur_in "#eval_some_occur_in_"))*)
22.90 -fun eval_some_occur_in _ "Atools.some'_occur'_in"
22.91 - (p as (Const ("Atools.some'_occur'_in",_)
22.92 - $ vs $ t)) _ =
22.93 - if some_occur_in (isalist2list vs) t
22.94 - then SOME ((term2str p) ^ " = True",
22.95 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
22.96 - else SOME ((term2str p) ^ " = False",
22.97 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
22.98 - | eval_some_occur_in _ _ _ _ = NONE;
22.99 -
22.100 -
22.101 -
22.102 -
22.103 -(*evaluate 'is_atom'*)
22.104 -(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*)
22.105 -fun eval_is_atom (thmid:string) "Atools.is'_atom"
22.106 - (t as (Const(op0,_) $ arg)) thy =
22.107 - (case arg of
22.108 - Free (n,_) => SOME (mk_thmid thmid op0 n "",
22.109 - Trueprop $ (mk_equality (t, true_as_term)))
22.110 - | _ => SOME (mk_thmid thmid op0 "" "",
22.111 - Trueprop $ (mk_equality (t, false_as_term))))
22.112 - | eval_is_atom _ _ _ _ = NONE;
22.113 -
22.114 -(*evaluate 'is_even'*)
22.115 -fun even i = (i div 2) * 2 = i;
22.116 -(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*)
22.117 -fun eval_is_even (thmid:string) "Atools.is'_even"
22.118 - (t as (Const(op0,_) $ arg)) thy =
22.119 - (case arg of
22.120 - Free (n,_) =>
22.121 - (case int_of_str n of
22.122 - SOME i =>
22.123 - if even i then SOME (mk_thmid thmid op0 n "",
22.124 - Trueprop $ (mk_equality (t, true_as_term)))
22.125 - else SOME (mk_thmid thmid op0 "" "",
22.126 - Trueprop $ (mk_equality (t, false_as_term)))
22.127 - | _ => NONE)
22.128 - | _ => NONE)
22.129 - | eval_is_even _ _ _ _ = NONE;
22.130 -
22.131 -(*evaluate 'is_const'*)
22.132 -(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*)
22.133 -fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*)
22.134 - (t as (Const(op0,t0) $ arg)) (thy:theory) =
22.135 - (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*)
22.136 - (case arg of
22.137 - Const (n1,_) =>
22.138 - SOME (mk_thmid thmid op0 n1 "",
22.139 - Trueprop $ (mk_equality (t, false_as_term)))
22.140 - | Free (n1,_) =>
22.141 - if is_numeral n1
22.142 - then SOME (mk_thmid thmid op0 n1 "",
22.143 - Trueprop $ (mk_equality (t, true_as_term)))
22.144 - else SOME (mk_thmid thmid op0 n1 "",
22.145 - Trueprop $ (mk_equality (t, false_as_term)))
22.146 - | Const ("Float.Float",_) =>
22.147 - SOME (mk_thmid thmid op0 (term2str arg) "",
22.148 - Trueprop $ (mk_equality (t, true_as_term)))
22.149 - | _ => (*NONE*)
22.150 - SOME (mk_thmid thmid op0 (term2str arg) "",
22.151 - Trueprop $ (mk_equality (t, false_as_term))))
22.152 - | eval_const _ _ _ _ = NONE;
22.153 -
22.154 -(*. evaluate binary, associative, commutative operators: *,+,^ .*)
22.155 -(*("PLUS" ,("op +" ,eval_binop "#add_")),
22.156 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
22.157 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*)
22.158 -
22.159 -(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) =
22.160 - ("xxxxxx",op_,t,thy);
22.161 - *)
22.162 -fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) =
22.163 - thmid ^ "Float ((" ^
22.164 - (string_of_int v11)^","^(string_of_int v12)^"), ("^
22.165 - (string_of_int p11)^","^(string_of_int p12)^")) __ (("^
22.166 - (string_of_int v21)^","^(string_of_int v22)^"), ("^
22.167 - (string_of_int p21)^","^(string_of_int p22)^"))";
22.168 -
22.169 -(*.convert int and float to internal floatingpoint prepresentation.*)
22.170 -fun numeral (Free (str, T)) =
22.171 - (case int_of_str str of
22.172 - SOME i => SOME ((i, 0), (0, 0))
22.173 - | NONE => NONE)
22.174 - | numeral (Const ("Float.Float", _) $
22.175 - (Const ("Pair", _) $
22.176 - (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $
22.177 - (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))=
22.178 - (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of
22.179 - (SOME v1', SOME v2', SOME p1', SOME p2') =>
22.180 - SOME ((v1', v2'), (p1', p2'))
22.181 - | _ => NONE)
22.182 - | numeral _ = NONE;
22.183 -
22.184 -(*.evaluate binary associative operations.*)
22.185 -fun eval_binop (thmid:string) (op_:string)
22.186 - (t as ( Const(op0,t0) $
22.187 - (Const(op0',t0') $ v $ t1) $ t2))
22.188 - thy = (*binary . (v.n1).n2*)
22.189 - if op0 = op0' then
22.190 - case (numeral t1, numeral t2) of
22.191 - (SOME n1, SOME n2) =>
22.192 - let val (T1,T2,Trange) = dest_binop_typ t0
22.193 - val res = calc (if op0 = "op -" then "op +" else op0) n1 n2
22.194 - (*WN071229 "HOL.divide" never tried*)
22.195 - val rhs = var_op_float v op_ t0 T1 res
22.196 - val prop = Trueprop $ (mk_equality (t, rhs))
22.197 - in SOME (mk_thmid_f thmid n1 n2, prop) end
22.198 - | _ => NONE
22.199 - else NONE
22.200 - | eval_binop (thmid:string) (op_:string)
22.201 - (t as
22.202 - (Const (op0, t0) $ t1 $
22.203 - (Const (op0', t0') $ t2 $ v)))
22.204 - thy = (*binary . n1.(n2.v)*)
22.205 - if op0 = op0' then
22.206 - case (numeral t1, numeral t2) of
22.207 - (SOME n1, SOME n2) =>
22.208 - if op0 = "op -" then NONE else
22.209 - let val (T1,T2,Trange) = dest_binop_typ t0
22.210 - val res = calc op0 n1 n2
22.211 - val rhs = float_op_var v op_ t0 T1 res
22.212 - val prop = Trueprop $ (mk_equality (t, rhs))
22.213 - in SOME (mk_thmid_f thmid n1 n2, prop) end
22.214 - | _ => NONE
22.215 - else NONE
22.216 -
22.217 - | eval_binop (thmid:string) (op_:string)
22.218 - (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*)
22.219 - (case (numeral t1, numeral t2) of
22.220 - (SOME n1, SOME n2) =>
22.221 - let val (T1,T2,Trange) = dest_binop_typ t0;
22.222 - val res = calc op0 n1 n2;
22.223 - val rhs = term_of_float Trange res;
22.224 - val prop = Trueprop $ (mk_equality (t, rhs));
22.225 - in SOME (mk_thmid_f thmid n1 n2, prop) end
22.226 - | _ => NONE)
22.227 - | eval_binop _ _ _ _ = NONE;
22.228 -(*
22.229 -> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy;
22.230 -> term2str t;
22.231 -val it = "-1 + 2 = 1"
22.232 -> val t = str2term "-1 * (-1 * a)";
22.233 -> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy;
22.234 -> term2str t;
22.235 -val it = "-1 * (-1 * a) = 1 * a"*)
22.236 -
22.237 -
22.238 -
22.239 -(*.evaluate < and <= for numerals.*)
22.240 -(*("le" ,("op <" ,eval_equ "#less_")),
22.241 - ("leq" ,("op <=" ,eval_equ "#less_equal_"))*)
22.242 -fun eval_equ (thmid:string) (op_:string) (t as
22.243 - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
22.244 - (case (int_of_str n1, int_of_str n2) of
22.245 - (SOME n1', SOME n2') =>
22.246 - if calc_equ (strip_thy op0) (n1', n2')
22.247 - then SOME (mk_thmid thmid op0 n1 n2,
22.248 - Trueprop $ (mk_equality (t, true_as_term)))
22.249 - else SOME (mk_thmid thmid op0 n1 n2,
22.250 - Trueprop $ (mk_equality (t, false_as_term)))
22.251 - | _ => NONE)
22.252 -
22.253 - | eval_equ _ _ _ _ = NONE;
22.254 -
22.255 -
22.256 -(*evaluate identity
22.257 -> reflI;
22.258 -val it = "(?t = ?t) = True"
22.259 -> val t = str2term "x = 0";
22.260 -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
22.261 -
22.262 -> val t = str2term "1 = 0";
22.263 -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
22.264 ------------ thus needs Calc !
22.265 -> val t = str2term "0 = 0";
22.266 -> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t;
22.267 -> term2str t';
22.268 -val it = "True"
22.269 -
22.270 -val t = str2term "Not (x = 0)";
22.271 -atomt t; term2str t;
22.272 -*** -------------
22.273 -*** Const ( Not)
22.274 -*** . Const ( op =)
22.275 -*** . . Free ( x, )
22.276 -*** . . Free ( 0, )
22.277 -val it = "x ~= 0" : string*)
22.278 -
22.279 -(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of
22.280 - the arguments: thus special handling by 'fun eval_binop'*)
22.281 -(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*)
22.282 -fun eval_ident (thmid:string) "Atools.ident" (t as
22.283 - (Const (op0,t0) $ t1 $ t2 )) thy =
22.284 - if t1 = t2
22.285 - then SOME (mk_thmid thmid op0
22.286 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
22.287 - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
22.288 - Trueprop $ (mk_equality (t, true_as_term)))
22.289 - else SOME (mk_thmid thmid op0
22.290 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
22.291 - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
22.292 - Trueprop $ (mk_equality (t, false_as_term)))
22.293 - | eval_ident _ _ _ _ = NONE;
22.294 -(* TODO
22.295 -> val t = str2term "x =!= 0";
22.296 -> val SOME (str, t') = eval_ident "ident_" "b" t thy;
22.297 -> term2str t';
22.298 -val str = "ident_(x)_(0)" : string
22.299 -val it = "(x =!= 0) = False" : string
22.300 -> val t = str2term "1 =!= 0";
22.301 -> val SOME (str, t') = eval_ident "ident_" "b" t thy;
22.302 -> term2str t';
22.303 -val str = "ident_(1)_(0)" : string
22.304 -val it = "(1 =!= 0) = False" : string
22.305 -> val t = str2term "0 =!= 0";
22.306 -> val SOME (str, t') = eval_ident "ident_" "b" t thy;
22.307 -> term2str t';
22.308 -val str = "ident_(0)_(0)" : string
22.309 -val it = "(0 =!= 0) = True" : string
22.310 -*)
22.311 -
22.312 -(*.evaluate identity of terms, which stay ready for evaluation in turn;
22.313 - thus returns False only for atoms.*)
22.314 -(*("equal" ,("op =",eval_equal "#equal_")):calc*)
22.315 -fun eval_equal (thmid:string) "op =" (t as
22.316 - (Const (op0,t0) $ t1 $ t2 )) thy =
22.317 - if t1 = t2
22.318 - then ((*writeln"... eval_equal: t1 = t2 --> True";*)
22.319 - SOME (mk_thmid thmid op0
22.320 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
22.321 - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
22.322 - Trueprop $ (mk_equality (t, true_as_term)))
22.323 - )
22.324 - else (case (is_atom t1, is_atom t2) of
22.325 - (true, true) =>
22.326 - ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*)
22.327 - SOME (mk_thmid thmid op0
22.328 - ("("^(term2str t1)^")") ("("^(term2str t2)^")"),
22.329 - Trueprop $ (mk_equality (t, false_as_term)))
22.330 - )
22.331 - | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*)
22.332 - NONE))
22.333 - | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit";
22.334 - NONE);
22.335 -(*
22.336 -val t = str2term "x ~= 0";
22.337 -val NONE = eval_equal "equal_" "b" t thy;
22.338 -
22.339 -
22.340 -> val t = str2term "(x + 1) = (x + 1)";
22.341 -> val SOME (str, t') = eval_equal "equal_" "b" t thy;
22.342 -> term2str t';
22.343 -val str = "equal_(x + 1)_(x + 1)" : string
22.344 -val it = "(x + 1 = x + 1) = True" : string
22.345 -> val t = str2term "x = 0";
22.346 -> val NONE = eval_equal "equal_" "b" t thy;
22.347 -
22.348 -> val t = str2term "1 = 0";
22.349 -> val SOME (str, t') = eval_equal "equal_" "b" t thy;
22.350 -> term2str t';
22.351 -val str = "equal_(1)_(0)" : string
22.352 -val it = "(1 = 0) = False" : string
22.353 -> val t = str2term "0 = 0";
22.354 -> val SOME (str, t') = eval_equal "equal_" "b" t thy;
22.355 -> term2str t';
22.356 -val str = "equal_(0)_(0)" : string
22.357 -val it = "(0 = 0) = True" : string
22.358 -*)
22.359 -
22.360 -
22.361 -(** evaluation on the metalevel **)
22.362 -
22.363 -(*. evaluate HOL.divide .*)
22.364 -(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*)
22.365 -fun eval_cancel (thmid:string) "HOL.divide" (t as
22.366 - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
22.367 - (case (int_of_str n1, int_of_str n2) of
22.368 - (SOME n1', SOME n2') =>
22.369 - let
22.370 - val sg = sign2 n1' n2';
22.371 - val (T1,T2,Trange) = dest_binop_typ t0;
22.372 - val gcd' = gcd (abs n1') (abs n2');
22.373 - in if gcd' = abs n2'
22.374 - then let val rhs = term_of_num Trange (sg * (abs n1') div gcd')
22.375 - val prop = Trueprop $ (mk_equality (t, rhs))
22.376 - in SOME (mk_thmid thmid op0 n1 n2, prop) end
22.377 - else if 0 < n2' andalso gcd' = 1 then NONE
22.378 - else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd')
22.379 - ((abs n2') div gcd')
22.380 - val prop = Trueprop $ (mk_equality (t, rhs))
22.381 - in SOME (mk_thmid thmid op0 n1 n2, prop) end
22.382 - end
22.383 - | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE))
22.384 -
22.385 - | eval_cancel _ _ _ _ = NONE;
22.386 -
22.387 -(*. get the argument from a function-definition.*)
22.388 -(*("argument_in" ,("Atools.argument'_in",
22.389 - eval_argument_in "Atools.argument'_in"))*)
22.390 -fun eval_argument_in _ "Atools.argument'_in"
22.391 - (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ =
22.392 - if is_Free arg (*could be something to be simplified before*)
22.393 - then SOME (term2str t ^ " = " ^ term2str arg,
22.394 - Trueprop $ (mk_equality (t, arg)))
22.395 - else NONE
22.396 - | eval_argument_in _ _ _ _ = NONE;
22.397 -
22.398 -(*.check if the function-identifier of the first argument matches
22.399 - the function-identifier of the lhs of the second argument.*)
22.400 -(*("sameFunId" ,("Atools.sameFunId",
22.401 - eval_same_funid "Atools.sameFunId"))*)
22.402 -fun eval_sameFunId _ "Atools.sameFunId"
22.403 - (p as Const ("Atools.sameFunId",_) $
22.404 - (f1 $ _) $
22.405 - (Const ("op =", _) $ (f2 $ _) $ _)) _ =
22.406 - if f1 = f2
22.407 - then SOME ((term2str p) ^ " = True",
22.408 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
22.409 - else SOME ((term2str p) ^ " = False",
22.410 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
22.411 -| eval_sameFunId _ _ _ _ = NONE;
22.412 -
22.413 -
22.414 -(*.from a list of fun-definitions "f x = ..." as 2nd argument
22.415 - filter the elements with the same fun-identfier in "f y"
22.416 - as the fst argument;
22.417 - this is, because Isabelles filter takes more than 1 sec.*)
22.418 -fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2
22.419 - | same_funid f1 t = raise error ("same_funid called with t = ("
22.420 - ^term2str f1^") ("^term2str t^")");
22.421 -(*("filter_sameFunId" ,("Atools.filter'_sameFunId",
22.422 - eval_filter_sameFunId "Atools.filter'_sameFunId"))*)
22.423 -fun eval_filter_sameFunId _ "Atools.filter'_sameFunId"
22.424 - (p as Const ("Atools.filter'_sameFunId",_) $
22.425 - (fid $ _) $ fs) _ =
22.426 - let val fs' = ((list2isalist HOLogic.boolT) o
22.427 - (filter (same_funid fid))) (isalist2list fs)
22.428 - in SOME (term2str (mk_equality (p, fs')),
22.429 - Trueprop $ (mk_equality (p, fs'))) end
22.430 -| eval_filter_sameFunId _ _ _ _ = NONE;
22.431 -
22.432 -
22.433 -(*make a list of terms to a sum*)
22.434 -fun list2sum [] = error ("list2sum called with []")
22.435 - | list2sum [s] = s
22.436 - | list2sum (s::ss) =
22.437 - let fun sum su [s'] =
22.438 - Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
22.439 - $ su $ s'
22.440 - | sum su (s'::ss') =
22.441 - sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
22.442 - $ su $ s') ss'
22.443 - in sum s ss end;
22.444 -
22.445 -(*make a list of equalities to the sum of the lhs*)
22.446 -(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*)
22.447 -fun eval_boollist2sum _ "Atools.boollist2sum"
22.448 - (p as Const ("Atools.boollist2sum", _) $
22.449 - (l as Const ("List.list.Cons", _) $ _ $ _)) _ =
22.450 - let val isal = isalist2list l
22.451 - val lhss = map lhs isal
22.452 - val sum = list2sum lhss
22.453 - in SOME ((term2str p) ^ " = " ^ (term2str sum),
22.454 - Trueprop $ (mk_equality (p, sum)))
22.455 - end
22.456 -| eval_boollist2sum _ _ _ _ = NONE;
22.457 -
22.458 -
22.459 -
22.460 -local
22.461 -
22.462 -open Term;
22.463 -
22.464 -in
22.465 -fun termlessI (_:subst) uv = termless uv;
22.466 -fun term_ordI (_:subst) uv = term_ord uv;
22.467 -end;
22.468 -
22.469 -
22.470 -(** rule set, for evaluating list-expressions in scripts 8.01.02 **)
22.471 -
22.472 -
22.473 -val list_rls =
22.474 - append_rls "list_rls" list_rls
22.475 - [Calc ("op *",eval_binop "#mult_"),
22.476 - Calc ("op +", eval_binop "#add_"),
22.477 - Calc ("op <",eval_equ "#less_"),
22.478 - Calc ("op <=",eval_equ "#less_equal_"),
22.479 - Calc ("Atools.ident",eval_ident "#ident_"),
22.480 - Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*)
22.481 -
22.482 - Calc ("Tools.Vars",eval_var "#Vars_"),
22.483 -
22.484 - Thm ("if_True",num_str if_True),
22.485 - Thm ("if_False",num_str if_False)
22.486 - ];
22.487 -
22.488 -ruleset' := overwritelthy thy (!ruleset',
22.489 - [("list_rls",list_rls)
22.490 - ]);
22.491 -
22.492 -(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*)
22.493 -val tless_true = dummy_ord;
22.494 -rew_ord' := overwritel (!rew_ord',
22.495 - [("tless_true", tless_true),
22.496 - ("e_rew_ord'", tless_true),
22.497 - ("dummy_ord", dummy_ord)]);
22.498 -
22.499 -val calculate_Atools =
22.500 - append_rls "calculate_Atools" e_rls
22.501 - [Calc ("op <",eval_equ "#less_"),
22.502 - Calc ("op <=",eval_equ "#less_equal_"),
22.503 - Calc ("op =",eval_equal "#equal_"),
22.504 -
22.505 - Thm ("real_unari_minus",num_str real_unari_minus),
22.506 - Calc ("op +",eval_binop "#add_"),
22.507 - Calc ("op -",eval_binop "#sub_"),
22.508 - Calc ("op *",eval_binop "#mult_")
22.509 - ];
22.510 -
22.511 -val Atools_erls =
22.512 - append_rls "Atools_erls" e_rls
22.513 - [Calc ("op =",eval_equal "#equal_"),
22.514 - Thm ("not_true",num_str not_true),
22.515 - (*"(~ True) = False"*)
22.516 - Thm ("not_false",num_str not_false),
22.517 - (*"(~ False) = True"*)
22.518 - Thm ("and_true",and_true),
22.519 - (*"(?a & True) = ?a"*)
22.520 - Thm ("and_false",and_false),
22.521 - (*"(?a & False) = False"*)
22.522 - Thm ("or_true",or_true),
22.523 - (*"(?a | True) = True"*)
22.524 - Thm ("or_false",or_false),
22.525 - (*"(?a | False) = ?a"*)
22.526 -
22.527 - Thm ("rat_leq1",rat_leq1),
22.528 - Thm ("rat_leq2",rat_leq2),
22.529 - Thm ("rat_leq3",rat_leq3),
22.530 - Thm ("refl",num_str refl),
22.531 - Thm ("le_refl",num_str le_refl),
22.532 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
22.533 -
22.534 - Calc ("op <",eval_equ "#less_"),
22.535 - Calc ("op <=",eval_equ "#less_equal_"),
22.536 -
22.537 - Calc ("Atools.ident",eval_ident "#ident_"),
22.538 - Calc ("Atools.is'_const",eval_const "#is_const_"),
22.539 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
22.540 - Calc ("Tools.matches",eval_matches "")
22.541 - ];
22.542 -
22.543 -val Atools_crls =
22.544 - append_rls "Atools_crls" e_rls
22.545 - [Calc ("op =",eval_equal "#equal_"),
22.546 - Thm ("not_true",num_str not_true),
22.547 - Thm ("not_false",num_str not_false),
22.548 - Thm ("and_true",and_true),
22.549 - Thm ("and_false",and_false),
22.550 - Thm ("or_true",or_true),
22.551 - Thm ("or_false",or_false),
22.552 -
22.553 - Thm ("rat_leq1",rat_leq1),
22.554 - Thm ("rat_leq2",rat_leq2),
22.555 - Thm ("rat_leq3",rat_leq3),
22.556 - Thm ("refl",num_str refl),
22.557 - Thm ("le_refl",num_str le_refl),
22.558 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
22.559 -
22.560 - Calc ("op <",eval_equ "#less_"),
22.561 - Calc ("op <=",eval_equ "#less_equal_"),
22.562 -
22.563 - Calc ("Atools.ident",eval_ident "#ident_"),
22.564 - Calc ("Atools.is'_const",eval_const "#is_const_"),
22.565 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
22.566 - Calc ("Tools.matches",eval_matches "")
22.567 - ];
22.568 -
22.569 -(*val atools_erls = ... waere zu testen ...
22.570 - merge_rls calculate_Atools
22.571 - (append_rls Atools_erls (*i.A. zu viele rules*)
22.572 - [Calc ("Atools.ident",eval_ident "#ident_"),
22.573 - Calc ("Atools.is'_const",eval_const "#is_const_"),
22.574 - Calc ("Atools.occurs'_in",
22.575 - eval_occurs_in "#occurs_in"),
22.576 - Calc ("Tools.matches",eval_matches "#matches")
22.577 - ] (*i.A. zu viele rules*)
22.578 - );*)
22.579 -(* val atools_erls = prep_rls(
22.580 - Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI),
22.581 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
22.582 - rules = [Thm ("refl",num_str refl),
22.583 - Thm ("le_refl",num_str le_refl),
22.584 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
22.585 - Thm ("not_true",num_str not_true),
22.586 - Thm ("not_false",num_str not_false),
22.587 - Thm ("and_true",and_true),
22.588 - Thm ("and_false",and_false),
22.589 - Thm ("or_true",or_true),
22.590 - Thm ("or_false",or_false),
22.591 - Thm ("and_commute",num_str and_commute),
22.592 - Thm ("or_commute",num_str or_commute),
22.593 -
22.594 - Calc ("op <",eval_equ "#less_"),
22.595 - Calc ("op <=",eval_equ "#less_equal_"),
22.596 -
22.597 - Calc ("Atools.ident",eval_ident "#ident_"),
22.598 - Calc ("Atools.is'_const",eval_const "#is_const_"),
22.599 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
22.600 - Calc ("Tools.matches",eval_matches "")
22.601 - ],
22.602 - scr = Script ((term_of o the o (parse thy))
22.603 - "empty_script")
22.604 - }:rls);
22.605 -ruleset' := overwritelth thy
22.606 - (!ruleset',
22.607 - [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*)
22.608 - ]);
22.609 -*)
22.610 -"******* Atools.ML end *******";
22.611 -
22.612 -calclist':= overwritel (!calclist',
22.613 - [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")),
22.614 - ("some_occur_in",
22.615 - ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")),
22.616 - ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")),
22.617 - ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")),
22.618 - ("is_const" ,("Atools.is'_const",eval_const "#is_const_")),
22.619 - ("le" ,("op <" ,eval_equ "#less_")),
22.620 - ("leq" ,("op <=" ,eval_equ "#less_equal_")),
22.621 - ("ident" ,("Atools.ident",eval_ident "#ident_")),
22.622 - ("equal" ,("op =",eval_equal "#equal_")),
22.623 - ("PLUS" ,("op +" ,eval_binop "#add_")),
22.624 - ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls
22.625 - no script with "minus"*)
22.626 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
22.627 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
22.628 - ("POWER" ,("Atools.pow" ,eval_binop "#power_")),
22.629 - ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum ""))
22.630 - ]);
22.631 -
22.632 -val list_rls = prep_rls(
22.633 - merge_rls "list_erls"
22.634 - (Rls {id="replaced",preconds = [],
22.635 - rew_ord = ("termlessI", termlessI),
22.636 - erls = Rls {id="list_elrs", preconds = [],
22.637 - rew_ord = ("termlessI",termlessI),
22.638 - erls = e_rls,
22.639 - srls = Erls, calc = [], (*asm_thm = [],*)
22.640 - rules = [Calc ("op +", eval_binop "#add_"),
22.641 - Calc ("op <",eval_equ "#less_")
22.642 - (* ~~~~~~ for nth_Cons_*)
22.643 - ],
22.644 - scr = EmptyScr},
22.645 - srls = Erls, calc = [], (*asm_thm = [], *)
22.646 - rules = [], scr = EmptyScr})
22.647 - list_rls);
22.648 -ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]);
23.1 --- a/src/Tools/isac/IsacKnowledge/Atools.thy Wed Aug 25 15:15:01 2010 +0200
23.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3 @@ -1,711 +0,0 @@
23.4 -(* Title: tools for arithmetic
23.5 - Author: Walther Neuper 010308
23.6 - (c) due to copyright terms
23.7 -
23.8 -remove_thy"Atools";
23.9 -use_thy"IsacKnowledge/Atools";
23.10 -use_thy"IsacKnowledge/Isac";
23.11 -
23.12 -use_thy_only"IsacKnowledge/Atools";
23.13 -use_thy"IsacKnowledge/Isac";
23.14 -*)
23.15 -
23.16 -theory Atools imports Descript Typefix begin
23.17 -
23.18 -consts
23.19 -
23.20 - Arbfix :: "real"
23.21 - Undef :: "real"
23.22 - dummy :: "real"
23.23 -
23.24 - some'_occur'_in :: "[real list, 'a] => bool" ("some'_of _ occur'_in _")
23.25 - occurs'_in :: "[real , 'a] => bool" ("_ occurs'_in _")
23.26 -
23.27 - pow :: "[real, real] => real" (infixr "^^^" 80)
23.28 -(* ~~~ power doesn't allow Free("2",real) ^ Free("2",nat)
23.29 - ~~~~ ~~~~ ~~~~ ~~~*)
23.30 -(*WN0603 at FE-interface encoded strings to '^',
23.31 - see 'fun encode', fun 'decode'*)
23.32 -
23.33 - abs :: "real => real" ("(|| _ ||)")
23.34 -(* ~~~ FIXXXME Isabelle2002 has abs already !!!*)
23.35 - absset :: "real set => real" ("(||| _ |||)")
23.36 - (*is numeral constant ?*)
23.37 - is'_const :: "real => bool" ("_ is'_const" 10)
23.38 - (*is_const rename to is_num FIXXXME.WN.16.5.03 *)
23.39 - is'_atom :: "real => bool" ("_ is'_atom" 10)
23.40 - is'_even :: "real => bool" ("_ is'_even" 10)
23.41 -
23.42 - (* identity on term level*)
23.43 - ident :: "['a, 'a] => bool" ("(_ =!=/ _)" [51, 51] 50)
23.44 -
23.45 - argument'_in :: "real => real" ("argument'_in _" 10)
23.46 - sameFunId :: "[real, bool] => bool" (**"same'_funid _ _" 10
23.47 - WN0609 changed the id, because ".. _ _" inhibits currying**)
23.48 - filter'_sameFunId:: "[real, bool list] => bool list"
23.49 - ("filter'_sameFunId _ _" 10)
23.50 - boollist2sum :: "bool list => real"
23.51 -
23.52 -axioms (*for evaluating the assumptions of conditional rules*)
23.53 -
23.54 - last_thmI "lastI (x#xs) = (if xs =!= [] then x else lastI xs)"
23.55 - real_unari_minus "- a = (-1) * a" (*Isa!*)
23.56 -
23.57 - rle_refl "(n::real) <= n"
23.58 -(*reflI "(t = t) = True"*)
23.59 - radd_left_cancel_le "((k::real) + m <= k + n) = (m <= n)"
23.60 - not_true "(~ True) = False"
23.61 - not_false "(~ False) = True"
23.62 - and_true "(a & True) = a"
23.63 - and_false "(a & False) = False"
23.64 - or_true "(a | True) = True"
23.65 - or_false "(a | False) = a"
23.66 - and_commute "(a & b) = (b & a)"
23.67 - or_commute "(a | b) = (b | a)"
23.68 -
23.69 - (*.should be in Rational.thy, but:
23.70 - needed for asms in e.g. d2_pqformula1 in PolyEq.ML, RootEq.ML.*)
23.71 - rat_leq1 "[| b ~= 0; d ~= 0 |] ==> \
23.72 - \((a / b) <= (c / d)) = ((a*d) <= (b*c))"(*Isa?*)
23.73 - rat_leq2 "d ~= 0 ==> \
23.74 - \( a <= (c / d)) = ((a*d) <= c )"(*Isa?*)
23.75 - rat_leq3 "b ~= 0 ==> \
23.76 - \((a / b) <= c ) = ( a <= (b*c))"(*Isa?*)
23.77 -
23.78 -text {*copy from doc/math-eng.tex WN.28.3.03
23.79 -WN071228 extended *}
23.80 -
23.81 -
23.82 -section {*Coding standards*}
23.83 -subsection {*Identifiers*}
23.84 -text {*Naming is particularily crucial, because Isabelles name space is global, and isac does not yet use the novel locale features introduces by Isar. For instance, {\tt probe} sounds reasonable as (1) a description in the model of a problem-pattern, (2) as an element of the problem hierarchies key, (3) as a socalled CAS-command, (4) as the name of a related script etc. However, all the cases (1)..(4) require different typing for one and the same identifier {\tt probe} which is impossible, and actually leads to strange errors (for instance (1) is used as string, except in a script addressing a Subproblem).
23.85 -
23.86 -This are the preliminary rules for naming identifiers>
23.87 -\begin{description}
23.88 -\item [elements of a key] into the hierarchy of problems or methods must not contain capital letters and may contain underscrores, e.g. {\tt probe, for_polynomials}.
23.89 -\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}.
23.90 -\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~!
23.91 -\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}.
23.92 -\item [???] ???
23.93 -\item [???] ???
23.94 -\end{description}
23.95 -%WN071228 extended *}
23.96 -
23.97 -subsection {*Rule sets*}
23.98 -text {*The actual version of the coding standards for rulesets is in {\tt /IsacKnowledge/Atools.ML where it can be viewed using the knowledge browsers.
23.99 -
23.100 -There are rulesets visible to the student, and there are rulesets visible (in general) only for math authors. There are also rulesets which {\em must} exist for {\em each} theory; these contain the identifier of the respective theory (including all capital letters) as indicated by {\it Thy} below.
23.101 -\begin{description}
23.102 -
23.103 -\item [norm\_{\it Thy}] exists for each theory, and {\em efficiently} calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents).
23.104 -
23.105 -\item [simplify\_{\it Thy}] exists for each theory, and calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents) such, that the rewrites can be presented to the student.
23.106 -
23.107 -\item [calculate\_{\it Thy}] exists for each theory, and evaluates terms with numerical constants only (i.e. all terms which can be expressed by the definitions of the respective theory and the respective parent theories). In particular, this ruleset includes evaluating in/equalities with numerical constants only.
23.108 -WN.3.7.03: may be dropped due to more generality: numericals and non-numericals are logically equivalent, where the latter often add to the assumptions (e.g. in Check_elementwise).
23.109 -\end{description}
23.110 -
23.111 -The above rulesets are all visible to the user, and also may be input; thus they must be contained in the global associationlist {\tt ruleset':= }~! All these rulesets must undergo a preparation using the function {\tt prep_rls}, which generates a script for stepwise rewriting etc.
23.112 -The following rulesets are used for internal purposes and usually invisible to the (naive) user:
23.113 -\begin{description}
23.114 -
23.115 -\item [*\_erls]
23.116 -\item [*\_prls]
23.117 -\item [*\_srls]
23.118 -
23.119 -\end{description}
23.120 -{\tt append_rls, merge_rls, remove_rls}
23.121 -*}
23.122 -
23.123 -ML {*
23.124 -
23.125 -(** evaluation of numerals and special predicates on the meta-level **)
23.126 -(*-------------------------functions---------------------*)
23.127 -local (* rlang 09.02 *)
23.128 - (*.a 'c is coefficient of v' if v does occur in c.*)
23.129 - fun coeff_in v c = member op = (vars c) v;
23.130 -in
23.131 - fun occurs_in v t = coeff_in v t;
23.132 -end;
23.133 -
23.134 -(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*)
23.135 -fun eval_occurs_in _ "Atools.occurs'_in"
23.136 - (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ =
23.137 - ((*writeln("@@@ eval_occurs_in: v= "^(term2str v));
23.138 - writeln("@@@ eval_occurs_in: t= "^(term2str t));*)
23.139 - if occurs_in v t
23.140 - then SOME ((term2str p) ^ " = True",
23.141 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
23.142 - else SOME ((term2str p) ^ " = False",
23.143 - Trueprop $ (mk_equality (p, HOLogic.false_const))))
23.144 - | eval_occurs_in _ _ _ _ = NONE;
23.145 -
23.146 -(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*)
23.147 -fun some_occur_in vs t =
23.148 - let fun occurs_in' a b = occurs_in b a
23.149 - in foldl or_ (false, map (occurs_in' t) vs) end;
23.150 -
23.151 -(*("some_occur_in", ("Atools.some'_occur'_in",
23.152 - eval_some_occur_in "#eval_some_occur_in_"))*)
23.153 -fun eval_some_occur_in _ "Atools.some'_occur'_in"
23.154 - (p as (Const ("Atools.some'_occur'_in",_)
23.155 - $ vs $ t)) _ =
23.156 - if some_occur_in (isalist2list vs) t
23.157 - then SOME ((term2str p) ^ " = True",
23.158 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
23.159 - else SOME ((term2str p) ^ " = False",
23.160 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
23.161 - | eval_some_occur_in _ _ _ _ = NONE;
23.162 -
23.163 -
23.164 -
23.165 -
23.166 -(*evaluate 'is_atom'*)
23.167 -(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*)
23.168 -fun eval_is_atom (thmid:string) "Atools.is'_atom"
23.169 - (t as (Const(op0,_) $ arg)) thy =
23.170 - (case arg of
23.171 - Free (n,_) => SOME (mk_thmid thmid op0 n "",
23.172 - Trueprop $ (mk_equality (t, true_as_term)))
23.173 - | _ => SOME (mk_thmid thmid op0 "" "",
23.174 - Trueprop $ (mk_equality (t, false_as_term))))
23.175 - | eval_is_atom _ _ _ _ = NONE;
23.176 -
23.177 -(*evaluate 'is_even'*)
23.178 -fun even i = (i div 2) * 2 = i;
23.179 -(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*)
23.180 -fun eval_is_even (thmid:string) "Atools.is'_even"
23.181 - (t as (Const(op0,_) $ arg)) thy =
23.182 - (case arg of
23.183 - Free (n,_) =>
23.184 - (case int_of_str n of
23.185 - SOME i =>
23.186 - if even i then SOME (mk_thmid thmid op0 n "",
23.187 - Trueprop $ (mk_equality (t, true_as_term)))
23.188 - else SOME (mk_thmid thmid op0 "" "",
23.189 - Trueprop $ (mk_equality (t, false_as_term)))
23.190 - | _ => NONE)
23.191 - | _ => NONE)
23.192 - | eval_is_even _ _ _ _ = NONE;
23.193 -
23.194 -(*evaluate 'is_const'*)
23.195 -(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*)
23.196 -fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*)
23.197 - (t as (Const(op0,t0) $ arg)) (thy:theory) =
23.198 - (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*)
23.199 - (case arg of
23.200 - Const (n1,_) =>
23.201 - SOME (mk_thmid thmid op0 n1 "",
23.202 - Trueprop $ (mk_equality (t, false_as_term)))
23.203 - | Free (n1,_) =>
23.204 - if is_numeral n1
23.205 - then SOME (mk_thmid thmid op0 n1 "",
23.206 - Trueprop $ (mk_equality (t, true_as_term)))
23.207 - else SOME (mk_thmid thmid op0 n1 "",
23.208 - Trueprop $ (mk_equality (t, false_as_term)))
23.209 - | Const ("Float.Float",_) =>
23.210 - SOME (mk_thmid thmid op0 (term2str arg) "",
23.211 - Trueprop $ (mk_equality (t, true_as_term)))
23.212 - | _ => (*NONE*)
23.213 - SOME (mk_thmid thmid op0 (term2str arg) "",
23.214 - Trueprop $ (mk_equality (t, false_as_term))))
23.215 - | eval_const _ _ _ _ = NONE;
23.216 -
23.217 -(*. evaluate binary, associative, commutative operators: *,+,^ .*)
23.218 -(*("PLUS" ,("op +" ,eval_binop "#add_")),
23.219 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
23.220 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*)
23.221 -
23.222 -(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) =
23.223 - ("xxxxxx",op_,t,thy);
23.224 - *)
23.225 -fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) =
23.226 - thmid ^ "Float ((" ^
23.227 - (string_of_int v11)^","^(string_of_int v12)^"), ("^
23.228 - (string_of_int p11)^","^(string_of_int p12)^")) __ (("^
23.229 - (string_of_int v21)^","^(string_of_int v22)^"), ("^
23.230 - (string_of_int p21)^","^(string_of_int p22)^"))";
23.231 -
23.232 -(*.convert int and float to internal floatingpoint prepresentation.*)
23.233 -fun numeral (Free (str, T)) =
23.234 - (case int_of_str str of
23.235 - SOME i => SOME ((i, 0), (0, 0))
23.236 - | NONE => NONE)
23.237 - | numeral (Const ("Float.Float", _) $
23.238 - (Const ("Pair", _) $
23.239 - (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $
23.240 - (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))=
23.241 - (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of
23.242 - (SOME v1', SOME v2', SOME p1', SOME p2') =>
23.243 - SOME ((v1', v2'), (p1', p2'))
23.244 - | _ => NONE)
23.245 - | numeral _ = NONE;
23.246 -
23.247 -(*.evaluate binary associative operations.*)
23.248 -fun eval_binop (thmid:string) (op_:string)
23.249 - (t as ( Const(op0,t0) $
23.250 - (Const(op0',t0') $ v $ t1) $ t2))
23.251 - thy = (*binary . (v.n1).n2*)
23.252 - if op0 = op0' then
23.253 - case (numeral t1, numeral t2) of
23.254 - (SOME n1, SOME n2) =>
23.255 - let val (T1,T2,Trange) = dest_binop_typ t0
23.256 - val res = calc (if op0 = "op -" then "op +" else op0) n1 n2
23.257 - (*WN071229 "HOL.divide" never tried*)
23.258 - val rhs = var_op_float v op_ t0 T1 res
23.259 - val prop = Trueprop $ (mk_equality (t, rhs))
23.260 - in SOME (mk_thmid_f thmid n1 n2, prop) end
23.261 - | _ => NONE
23.262 - else NONE
23.263 - | eval_binop (thmid:string) (op_:string)
23.264 - (t as
23.265 - (Const (op0, t0) $ t1 $
23.266 - (Const (op0', t0') $ t2 $ v)))
23.267 - thy = (*binary . n1.(n2.v)*)
23.268 - if op0 = op0' then
23.269 - case (numeral t1, numeral t2) of
23.270 - (SOME n1, SOME n2) =>
23.271 - if op0 = "op -" then NONE else
23.272 - let val (T1,T2,Trange) = dest_binop_typ t0
23.273 - val res = calc op0 n1 n2
23.274 - val rhs = float_op_var v op_ t0 T1 res
23.275 - val prop = Trueprop $ (mk_equality (t, rhs))
23.276 - in SOME (mk_thmid_f thmid n1 n2, prop) end
23.277 - | _ => NONE
23.278 - else NONE
23.279 -
23.280 - | eval_binop (thmid:string) (op_:string)
23.281 - (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*)
23.282 - (case (numeral t1, numeral t2) of
23.283 - (SOME n1, SOME n2) =>
23.284 - let val (T1,T2,Trange) = dest_binop_typ t0;
23.285 - val res = calc op0 n1 n2;
23.286 - val rhs = term_of_float Trange res;
23.287 - val prop = Trueprop $ (mk_equality (t, rhs));
23.288 - in SOME (mk_thmid_f thmid n1 n2, prop) end
23.289 - | _ => NONE)
23.290 - | eval_binop _ _ _ _ = NONE;
23.291 -(*
23.292 -> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy;
23.293 -> term2str t;
23.294 -val it = "-1 + 2 = 1"
23.295 -> val t = str2term "-1 * (-1 * a)";
23.296 -> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy;
23.297 -> term2str t;
23.298 -val it = "-1 * (-1 * a) = 1 * a"*)
23.299 -
23.300 -
23.301 -
23.302 -(*.evaluate < and <= for numerals.*)
23.303 -(*("le" ,("op <" ,eval_equ "#less_")),
23.304 - ("leq" ,("op <=" ,eval_equ "#less_equal_"))*)
23.305 -fun eval_equ (thmid:string) (op_:string) (t as
23.306 - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
23.307 - (case (int_of_str n1, int_of_str n2) of
23.308 - (SOME n1', SOME n2') =>
23.309 - if calc_equ (strip_thy op0) (n1', n2')
23.310 - then SOME (mk_thmid thmid op0 n1 n2,
23.311 - Trueprop $ (mk_equality (t, true_as_term)))
23.312 - else SOME (mk_thmid thmid op0 n1 n2,
23.313 - Trueprop $ (mk_equality (t, false_as_term)))
23.314 - | _ => NONE)
23.315 -
23.316 - | eval_equ _ _ _ _ = NONE;
23.317 -
23.318 -
23.319 -(*evaluate identity
23.320 -> reflI;
23.321 -val it = "(?t = ?t) = True"
23.322 -> val t = str2term "x = 0";
23.323 -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
23.324 -
23.325 -> val t = str2term "1 = 0";
23.326 -> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
23.327 ------------ thus needs Calc !
23.328 -> val t = str2term "0 = 0";
23.329 -> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t;
23.330 -> term2str t';
23.331 -val it = "True"
23.332 -
23.333 -val t = str2term "Not (x = 0)";
23.334 -atomt t; term2str t;
23.335 -*** -------------
23.336 -*** Const ( Not)
23.337 -*** . Const ( op =)
23.338 -*** . . Free ( x, )
23.339 -*** . . Free ( 0, )
23.340 -val it = "x ~= 0" : string*)
23.341 -
23.342 -(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of
23.343 - the arguments: thus special handling by 'fun eval_binop'*)
23.344 -(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*)
23.345 -fun eval_ident (thmid:string) "Atools.ident" (t as
23.346 - (Const (op0,t0) $ t1 $ t2 )) thy =
23.347 - if t1 = t2
23.348 - then SOME (mk_thmid thmid op0
23.349 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
23.350 - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
23.351 - Trueprop $ (mk_equality (t, true_as_term)))
23.352 - else SOME (mk_thmid thmid op0
23.353 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
23.354 - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
23.355 - Trueprop $ (mk_equality (t, false_as_term)))
23.356 - | eval_ident _ _ _ _ = NONE;
23.357 -(* TODO
23.358 -> val t = str2term "x =!= 0";
23.359 -> val SOME (str, t') = eval_ident "ident_" "b" t thy;
23.360 -> term2str t';
23.361 -val str = "ident_(x)_(0)" : string
23.362 -val it = "(x =!= 0) = False" : string
23.363 -> val t = str2term "1 =!= 0";
23.364 -> val SOME (str, t') = eval_ident "ident_" "b" t thy;
23.365 -> term2str t';
23.366 -val str = "ident_(1)_(0)" : string
23.367 -val it = "(1 =!= 0) = False" : string
23.368 -> val t = str2term "0 =!= 0";
23.369 -> val SOME (str, t') = eval_ident "ident_" "b" t thy;
23.370 -> term2str t';
23.371 -val str = "ident_(0)_(0)" : string
23.372 -val it = "(0 =!= 0) = True" : string
23.373 -*)
23.374 -
23.375 -(*.evaluate identity of terms, which stay ready for evaluation in turn;
23.376 - thus returns False only for atoms.*)
23.377 -(*("equal" ,("op =",eval_equal "#equal_")):calc*)
23.378 -fun eval_equal (thmid:string) "op =" (t as
23.379 - (Const (op0,t0) $ t1 $ t2 )) thy =
23.380 - if t1 = t2
23.381 - then ((*writeln"... eval_equal: t1 = t2 --> True";*)
23.382 - SOME (mk_thmid thmid op0
23.383 - ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
23.384 - ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
23.385 - Trueprop $ (mk_equality (t, true_as_term)))
23.386 - )
23.387 - else (case (is_atom t1, is_atom t2) of
23.388 - (true, true) =>
23.389 - ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*)
23.390 - SOME (mk_thmid thmid op0
23.391 - ("("^(term2str t1)^")") ("("^(term2str t2)^")"),
23.392 - Trueprop $ (mk_equality (t, false_as_term)))
23.393 - )
23.394 - | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*)
23.395 - NONE))
23.396 - | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit";
23.397 - NONE);
23.398 -(*
23.399 -val t = str2term "x ~= 0";
23.400 -val NONE = eval_equal "equal_" "b" t thy;
23.401 -
23.402 -
23.403 -> val t = str2term "(x + 1) = (x + 1)";
23.404 -> val SOME (str, t') = eval_equal "equal_" "b" t thy;
23.405 -> term2str t';
23.406 -val str = "equal_(x + 1)_(x + 1)" : string
23.407 -val it = "(x + 1 = x + 1) = True" : string
23.408 -> val t = str2term "x = 0";
23.409 -> val NONE = eval_equal "equal_" "b" t thy;
23.410 -
23.411 -> val t = str2term "1 = 0";
23.412 -> val SOME (str, t') = eval_equal "equal_" "b" t thy;
23.413 -> term2str t';
23.414 -val str = "equal_(1)_(0)" : string
23.415 -val it = "(1 = 0) = False" : string
23.416 -> val t = str2term "0 = 0";
23.417 -> val SOME (str, t') = eval_equal "equal_" "b" t thy;
23.418 -> term2str t';
23.419 -val str = "equal_(0)_(0)" : string
23.420 -val it = "(0 = 0) = True" : string
23.421 -*)
23.422 -
23.423 -
23.424 -(** evaluation on the metalevel **)
23.425 -
23.426 -(*. evaluate HOL.divide .*)
23.427 -(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*)
23.428 -fun eval_cancel (thmid:string) "HOL.divide" (t as
23.429 - (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
23.430 - (case (int_of_str n1, int_of_str n2) of
23.431 - (SOME n1', SOME n2') =>
23.432 - let
23.433 - val sg = sign2 n1' n2';
23.434 - val (T1,T2,Trange) = dest_binop_typ t0;
23.435 - val gcd' = gcd (abs n1') (abs n2');
23.436 - in if gcd' = abs n2'
23.437 - then let val rhs = term_of_num Trange (sg * (abs n1') div gcd')
23.438 - val prop = Trueprop $ (mk_equality (t, rhs))
23.439 - in SOME (mk_thmid thmid op0 n1 n2, prop) end
23.440 - else if 0 < n2' andalso gcd' = 1 then NONE
23.441 - else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd')
23.442 - ((abs n2') div gcd')
23.443 - val prop = Trueprop $ (mk_equality (t, rhs))
23.444 - in SOME (mk_thmid thmid op0 n1 n2, prop) end
23.445 - end
23.446 - | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE))
23.447 -
23.448 - | eval_cancel _ _ _ _ = NONE;
23.449 -
23.450 -(*. get the argument from a function-definition.*)
23.451 -(*("argument_in" ,("Atools.argument'_in",
23.452 - eval_argument_in "Atools.argument'_in"))*)
23.453 -fun eval_argument_in _ "Atools.argument'_in"
23.454 - (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ =
23.455 - if is_Free arg (*could be something to be simplified before*)
23.456 - then SOME (term2str t ^ " = " ^ term2str arg,
23.457 - Trueprop $ (mk_equality (t, arg)))
23.458 - else NONE
23.459 - | eval_argument_in _ _ _ _ = NONE;
23.460 -
23.461 -(*.check if the function-identifier of the first argument matches
23.462 - the function-identifier of the lhs of the second argument.*)
23.463 -(*("sameFunId" ,("Atools.sameFunId",
23.464 - eval_same_funid "Atools.sameFunId"))*)
23.465 -fun eval_sameFunId _ "Atools.sameFunId"
23.466 - (p as Const ("Atools.sameFunId",_) $
23.467 - (f1 $ _) $
23.468 - (Const ("op =", _) $ (f2 $ _) $ _)) _ =
23.469 - if f1 = f2
23.470 - then SOME ((term2str p) ^ " = True",
23.471 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
23.472 - else SOME ((term2str p) ^ " = False",
23.473 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
23.474 -| eval_sameFunId _ _ _ _ = NONE;
23.475 -
23.476 -
23.477 -(*.from a list of fun-definitions "f x = ..." as 2nd argument
23.478 - filter the elements with the same fun-identfier in "f y"
23.479 - as the fst argument;
23.480 - this is, because Isabelles filter takes more than 1 sec.*)
23.481 -fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2
23.482 - | same_funid f1 t = raise error ("same_funid called with t = ("
23.483 - ^term2str f1^") ("^term2str t^")");
23.484 -(*("filter_sameFunId" ,("Atools.filter'_sameFunId",
23.485 - eval_filter_sameFunId "Atools.filter'_sameFunId"))*)
23.486 -fun eval_filter_sameFunId _ "Atools.filter'_sameFunId"
23.487 - (p as Const ("Atools.filter'_sameFunId",_) $
23.488 - (fid $ _) $ fs) _ =
23.489 - let val fs' = ((list2isalist HOLogic.boolT) o
23.490 - (filter (same_funid fid))) (isalist2list fs)
23.491 - in SOME (term2str (mk_equality (p, fs')),
23.492 - Trueprop $ (mk_equality (p, fs'))) end
23.493 -| eval_filter_sameFunId _ _ _ _ = NONE;
23.494 -
23.495 -
23.496 -(*make a list of terms to a sum*)
23.497 -fun list2sum [] = error ("list2sum called with []")
23.498 - | list2sum [s] = s
23.499 - | list2sum (s::ss) =
23.500 - let fun sum su [s'] =
23.501 - Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
23.502 - $ su $ s'
23.503 - | sum su (s'::ss') =
23.504 - sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
23.505 - $ su $ s') ss'
23.506 - in sum s ss end;
23.507 -
23.508 -(*make a list of equalities to the sum of the lhs*)
23.509 -(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*)
23.510 -fun eval_boollist2sum _ "Atools.boollist2sum"
23.511 - (p as Const ("Atools.boollist2sum", _) $
23.512 - (l as Const ("List.list.Cons", _) $ _ $ _)) _ =
23.513 - let val isal = isalist2list l
23.514 - val lhss = map lhs isal
23.515 - val sum = list2sum lhss
23.516 - in SOME ((term2str p) ^ " = " ^ (term2str sum),
23.517 - Trueprop $ (mk_equality (p, sum)))
23.518 - end
23.519 -| eval_boollist2sum _ _ _ _ = NONE;
23.520 -
23.521 -
23.522 -
23.523 -local
23.524 -
23.525 -open Term;
23.526 -
23.527 -in
23.528 -fun termlessI (_:subst) uv = termless uv;
23.529 -fun term_ordI (_:subst) uv = term_ord uv;
23.530 -end;
23.531 -
23.532 -
23.533 -(** rule set, for evaluating list-expressions in scripts 8.01.02 **)
23.534 -
23.535 -
23.536 -val list_rls =
23.537 - append_rls "list_rls" list_rls
23.538 - [Calc ("op *",eval_binop "#mult_"),
23.539 - Calc ("op +", eval_binop "#add_"),
23.540 - Calc ("op <",eval_equ "#less_"),
23.541 - Calc ("op <=",eval_equ "#less_equal_"),
23.542 - Calc ("Atools.ident",eval_ident "#ident_"),
23.543 - Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*)
23.544 -
23.545 - Calc ("Tools.Vars",eval_var "#Vars_"),
23.546 -
23.547 - Thm ("if_True",num_str if_True),
23.548 - Thm ("if_False",num_str if_False)
23.549 - ];
23.550 -
23.551 -ruleset' := overwritelthy thy (!ruleset',
23.552 - [("list_rls",list_rls)
23.553 - ]);
23.554 -
23.555 -(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*)
23.556 -val tless_true = dummy_ord;
23.557 -rew_ord' := overwritel (!rew_ord',
23.558 - [("tless_true", tless_true),
23.559 - ("e_rew_ord'", tless_true),
23.560 - ("dummy_ord", dummy_ord)]);
23.561 -
23.562 -val calculate_Atools =
23.563 - append_rls "calculate_Atools" e_rls
23.564 - [Calc ("op <",eval_equ "#less_"),
23.565 - Calc ("op <=",eval_equ "#less_equal_"),
23.566 - Calc ("op =",eval_equal "#equal_"),
23.567 -
23.568 - Thm ("real_unari_minus",num_str real_unari_minus),
23.569 - Calc ("op +",eval_binop "#add_"),
23.570 - Calc ("op -",eval_binop "#sub_"),
23.571 - Calc ("op *",eval_binop "#mult_")
23.572 - ];
23.573 -
23.574 -val Atools_erls =
23.575 - append_rls "Atools_erls" e_rls
23.576 - [Calc ("op =",eval_equal "#equal_"),
23.577 - Thm ("not_true",num_str not_true),
23.578 - (*"(~ True) = False"*)
23.579 - Thm ("not_false",num_str not_false),
23.580 - (*"(~ False) = True"*)
23.581 - Thm ("and_true",and_true),
23.582 - (*"(?a & True) = ?a"*)
23.583 - Thm ("and_false",and_false),
23.584 - (*"(?a & False) = False"*)
23.585 - Thm ("or_true",or_true),
23.586 - (*"(?a | True) = True"*)
23.587 - Thm ("or_false",or_false),
23.588 - (*"(?a | False) = ?a"*)
23.589 -
23.590 - Thm ("rat_leq1",rat_leq1),
23.591 - Thm ("rat_leq2",rat_leq2),
23.592 - Thm ("rat_leq3",rat_leq3),
23.593 - Thm ("refl",num_str refl),
23.594 - Thm ("le_refl",num_str le_refl),
23.595 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
23.596 -
23.597 - Calc ("op <",eval_equ "#less_"),
23.598 - Calc ("op <=",eval_equ "#less_equal_"),
23.599 -
23.600 - Calc ("Atools.ident",eval_ident "#ident_"),
23.601 - Calc ("Atools.is'_const",eval_const "#is_const_"),
23.602 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
23.603 - Calc ("Tools.matches",eval_matches "")
23.604 - ];
23.605 -
23.606 -val Atools_crls =
23.607 - append_rls "Atools_crls" e_rls
23.608 - [Calc ("op =",eval_equal "#equal_"),
23.609 - Thm ("not_true",num_str not_true),
23.610 - Thm ("not_false",num_str not_false),
23.611 - Thm ("and_true",and_true),
23.612 - Thm ("and_false",and_false),
23.613 - Thm ("or_true",or_true),
23.614 - Thm ("or_false",or_false),
23.615 -
23.616 - Thm ("rat_leq1",rat_leq1),
23.617 - Thm ("rat_leq2",rat_leq2),
23.618 - Thm ("rat_leq3",rat_leq3),
23.619 - Thm ("refl",num_str refl),
23.620 - Thm ("le_refl",num_str le_refl),
23.621 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
23.622 -
23.623 - Calc ("op <",eval_equ "#less_"),
23.624 - Calc ("op <=",eval_equ "#less_equal_"),
23.625 -
23.626 - Calc ("Atools.ident",eval_ident "#ident_"),
23.627 - Calc ("Atools.is'_const",eval_const "#is_const_"),
23.628 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
23.629 - Calc ("Tools.matches",eval_matches "")
23.630 - ];
23.631 -
23.632 -(*val atools_erls = ... waere zu testen ...
23.633 - merge_rls calculate_Atools
23.634 - (append_rls Atools_erls (*i.A. zu viele rules*)
23.635 - [Calc ("Atools.ident",eval_ident "#ident_"),
23.636 - Calc ("Atools.is'_const",eval_const "#is_const_"),
23.637 - Calc ("Atools.occurs'_in",
23.638 - eval_occurs_in "#occurs_in"),
23.639 - Calc ("Tools.matches",eval_matches "#matches")
23.640 - ] (*i.A. zu viele rules*)
23.641 - );*)
23.642 -(* val atools_erls = prep_rls(
23.643 - Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI),
23.644 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
23.645 - rules = [Thm ("refl",num_str refl),
23.646 - Thm ("le_refl",num_str le_refl),
23.647 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
23.648 - Thm ("not_true",num_str not_true),
23.649 - Thm ("not_false",num_str not_false),
23.650 - Thm ("and_true",and_true),
23.651 - Thm ("and_false",and_false),
23.652 - Thm ("or_true",or_true),
23.653 - Thm ("or_false",or_false),
23.654 - Thm ("and_commute",num_str and_commute),
23.655 - Thm ("or_commute",num_str or_commute),
23.656 -
23.657 - Calc ("op <",eval_equ "#less_"),
23.658 - Calc ("op <=",eval_equ "#less_equal_"),
23.659 -
23.660 - Calc ("Atools.ident",eval_ident "#ident_"),
23.661 - Calc ("Atools.is'_const",eval_const "#is_const_"),
23.662 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
23.663 - Calc ("Tools.matches",eval_matches "")
23.664 - ],
23.665 - scr = Script ((term_of o the o (parse thy))
23.666 - "empty_script")
23.667 - }:rls);
23.668 -ruleset' := overwritelth thy
23.669 - (!ruleset',
23.670 - [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*)
23.671 - ]);
23.672 -*)
23.673 -"******* Atools.ML end *******";
23.674 -
23.675 -calclist':= overwritel (!calclist',
23.676 - [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")),
23.677 - ("some_occur_in",
23.678 - ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")),
23.679 - ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")),
23.680 - ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")),
23.681 - ("is_const" ,("Atools.is'_const",eval_const "#is_const_")),
23.682 - ("le" ,("op <" ,eval_equ "#less_")),
23.683 - ("leq" ,("op <=" ,eval_equ "#less_equal_")),
23.684 - ("ident" ,("Atools.ident",eval_ident "#ident_")),
23.685 - ("equal" ,("op =",eval_equal "#equal_")),
23.686 - ("PLUS" ,("op +" ,eval_binop "#add_")),
23.687 - ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls
23.688 - no script with "minus"*)
23.689 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
23.690 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
23.691 - ("POWER" ,("Atools.pow" ,eval_binop "#power_")),
23.692 - ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum ""))
23.693 - ]);
23.694 -
23.695 -val list_rls = prep_rls(
23.696 - merge_rls "list_erls"
23.697 - (Rls {id="replaced",preconds = [],
23.698 - rew_ord = ("termlessI", termlessI),
23.699 - erls = Rls {id="list_elrs", preconds = [],
23.700 - rew_ord = ("termlessI",termlessI),
23.701 - erls = e_rls,
23.702 - srls = Erls, calc = [], (*asm_thm = [],*)
23.703 - rules = [Calc ("op +", eval_binop "#add_"),
23.704 - Calc ("op <",eval_equ "#less_")
23.705 - (* ~~~~~~ for nth_Cons_*)
23.706 - ],
23.707 - scr = EmptyScr},
23.708 - srls = Erls, calc = [], (*asm_thm = [], *)
23.709 - rules = [], scr = EmptyScr})
23.710 - list_rls);
23.711 -ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]);
23.712 -*}
23.713 -
23.714 -end
24.1 --- a/src/Tools/isac/IsacKnowledge/Biegelinie.ML Wed Aug 25 15:15:01 2010 +0200
24.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
24.3 @@ -1,468 +0,0 @@
24.4 -(* chapter 'Biegelinie' from the textbook:
24.5 - Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271.
24.6 - authors: Walther Neuper 2005
24.7 - (c) due to copyright terms
24.8 -
24.9 -use"IsacKnowledge/Biegelinie.ML";
24.10 -use"Biegelinie.ML";
24.11 -
24.12 -remove_thy"Typefix";
24.13 -remove_thy"Biegelinie";
24.14 -use_thy"IsacKnowledge/Isac";
24.15 -*)
24.16 -
24.17 -(** interface isabelle -- isac **)
24.18 -
24.19 -theory' := overwritel (!theory', [("Biegelinie.thy",Biegelinie.thy)]);
24.20 -
24.21 -(** theory elements **)
24.22 -
24.23 -store_isa ["IsacKnowledge"] [];
24.24 -store_thy Biegelinie.thy
24.25 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.26 -store_isa ["IsacKnowledge", theory2thyID Biegelinie.thy, "Theorems"]
24.27 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.28 -store_thm Biegelinie.thy ("Belastung_Querkraft", Belastung_Querkraft)
24.29 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.30 -store_thm Biegelinie.thy ("Moment_Neigung", Moment_Neigung)
24.31 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.32 -store_thm Biegelinie.thy ("Moment_Querkraft", Moment_Querkraft)
24.33 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.34 -store_thm Biegelinie.thy ("Neigung_Moment", Neigung_Moment)
24.35 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.36 -store_thm Biegelinie.thy ("Querkraft_Belastung", Querkraft_Belastung)
24.37 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.38 -store_thm Biegelinie.thy ("Querkraft_Moment", Querkraft_Moment)
24.39 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.40 -store_thm Biegelinie.thy ("make_fun_explicit", make_fun_explicit)
24.41 - ["Walther Neuper 2005 supported by a grant from NMI Austria"];
24.42 -
24.43 -
24.44 -(** problems **)
24.45 -
24.46 -store_pbt
24.47 - (prep_pbt Biegelinie.thy "pbl_bieg" [] e_pblID
24.48 - (["Biegelinien"],
24.49 - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]),
24.50 - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
24.51 - ("#Find" ,["Biegelinie b_"]),
24.52 - ("#Relate",["Randbedingungen rb_"])
24.53 - ],
24.54 - append_rls "e_rls" e_rls [],
24.55 - NONE,
24.56 - [["IntegrierenUndKonstanteBestimmen2"]]));
24.57 -
24.58 -store_pbt
24.59 - (prep_pbt Biegelinie.thy "pbl_bieg_mom" [] e_pblID
24.60 - (["MomentBestimmte","Biegelinien"],
24.61 - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]),
24.62 - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
24.63 - ("#Find" ,["Biegelinie b_"]),
24.64 - ("#Relate",["RandbedingungenBiegung rb_","RandbedingungenMoment rm_"])
24.65 - ],
24.66 - append_rls "e_rls" e_rls [],
24.67 - NONE,
24.68 - [["IntegrierenUndKonstanteBestimmen"]]));
24.69 -
24.70 -store_pbt
24.71 - (prep_pbt Biegelinie.thy "pbl_bieg_momg" [] e_pblID
24.72 - (["MomentGegebene","Biegelinien"],
24.73 - [],
24.74 - append_rls "e_rls" e_rls [],
24.75 - NONE,
24.76 - [["IntegrierenUndKonstanteBestimmen","2xIntegrieren"]]));
24.77 -
24.78 -store_pbt
24.79 - (prep_pbt Biegelinie.thy "pbl_bieg_einf" [] e_pblID
24.80 - (["einfache","Biegelinien"],
24.81 - [],
24.82 - append_rls "e_rls" e_rls [],
24.83 - NONE,
24.84 - [["IntegrierenUndKonstanteBestimmen","4x4System"]]));
24.85 -
24.86 -store_pbt
24.87 - (prep_pbt Biegelinie.thy "pbl_bieg_momquer" [] e_pblID
24.88 - (["QuerkraftUndMomentBestimmte","Biegelinien"],
24.89 - [],
24.90 - append_rls "e_rls" e_rls [],
24.91 - NONE,
24.92 - [["IntegrierenUndKonstanteBestimmen","1xIntegrieren"]]));
24.93 -
24.94 -store_pbt
24.95 - (prep_pbt Biegelinie.thy "pbl_bieg_vonq" [] e_pblID
24.96 - (["vonBelastungZu","Biegelinien"],
24.97 - [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]),
24.98 - ("#Find" ,["Funktionen funs___"])],
24.99 - append_rls "e_rls" e_rls [],
24.100 - NONE,
24.101 - [["Biegelinien","ausBelastung"]]));
24.102 -
24.103 -store_pbt
24.104 - (prep_pbt Biegelinie.thy "pbl_bieg_randbed" [] e_pblID
24.105 - (["setzeRandbedingungen","Biegelinien"],
24.106 - [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]),
24.107 - ("#Find" ,["Gleichungen equs___"])],
24.108 - append_rls "e_rls" e_rls [],
24.109 - NONE,
24.110 - [["Biegelinien","setzeRandbedingungenEin"]]));
24.111 -
24.112 -store_pbt
24.113 - (prep_pbt Biegelinie.thy "pbl_equ_fromfun" [] e_pblID
24.114 - (["makeFunctionTo","equation"],
24.115 - [("#Given" ,["functionEq fun_","substitution sub_"]),
24.116 - ("#Find" ,["equality equ___"])],
24.117 - append_rls "e_rls" e_rls [],
24.118 - NONE,
24.119 - [["Equation","fromFunction"]]));
24.120 -
24.121 -
24.122 -
24.123 -(** methods **)
24.124 -
24.125 -val srls = Rls {id="srls_IntegrierenUnd..",
24.126 - preconds = [],
24.127 - rew_ord = ("termlessI",termlessI),
24.128 - erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls
24.129 - [(*for asm in nth_Cons_ ...*)
24.130 - Calc ("op <",eval_equ "#less_"),
24.131 - (*2nd nth_Cons_ pushes n+-1 into asms*)
24.132 - Calc("op +", eval_binop "#add_")
24.133 - ],
24.134 - srls = Erls, calc = [],
24.135 - rules = [Thm ("nth_Cons_",num_str nth_Cons_),
24.136 - Calc("op +", eval_binop "#add_"),
24.137 - Thm ("nth_Nil_",num_str nth_Nil_),
24.138 - Calc("Tools.lhs", eval_lhs"eval_lhs_"),
24.139 - Calc("Tools.rhs", eval_rhs"eval_rhs_"),
24.140 - Calc("Atools.argument'_in",
24.141 - eval_argument_in "Atools.argument'_in")
24.142 - ],
24.143 - scr = EmptyScr};
24.144 -
24.145 -val srls2 =
24.146 - Rls {id="srls_IntegrierenUnd..",
24.147 - preconds = [],
24.148 - rew_ord = ("termlessI",termlessI),
24.149 - erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls
24.150 - [(*for asm in nth_Cons_ ...*)
24.151 - Calc ("op <",eval_equ "#less_"),
24.152 - (*2nd nth_Cons_ pushes n+-1 into asms*)
24.153 - Calc("op +", eval_binop "#add_")
24.154 - ],
24.155 - srls = Erls, calc = [],
24.156 - rules = [Thm ("nth_Cons_",num_str nth_Cons_),
24.157 - Calc("op +", eval_binop "#add_"),
24.158 - Thm ("nth_Nil_", num_str nth_Nil_),
24.159 - Calc("Tools.lhs", eval_lhs "eval_lhs_"),
24.160 - Calc("Atools.filter'_sameFunId",
24.161 - eval_filter_sameFunId "Atools.filter'_sameFunId"),
24.162 - (*WN070514 just for smltest/../biegelinie.sml ...*)
24.163 - Calc("Atools.sameFunId", eval_sameFunId "Atools.sameFunId"),
24.164 - Thm ("filter_Cons", num_str filter_Cons),
24.165 - Thm ("filter_Nil", num_str filter_Nil),
24.166 - Thm ("if_True", num_str if_True),
24.167 - Thm ("if_False", num_str if_False),
24.168 - Thm ("hd_thm", num_str hd_thm)
24.169 - ],
24.170 - scr = EmptyScr};
24.171 -(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
24.172 -(* use"IsacKnowledge/Biegelinie.ML";
24.173 - *)
24.174 -
24.175 -store_met
24.176 - (prep_met Biegelinie.thy "met_biege" [] e_metID
24.177 - (["IntegrierenUndKonstanteBestimmen"],
24.178 - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__",
24.179 - "FunktionsVariable v_"]),
24.180 - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
24.181 - ("#Find" ,["Biegelinie b_"]),
24.182 - ("#Relate",["RandbedingungenBiegung rb_",
24.183 - "RandbedingungenMoment rm_"])
24.184 - ],
24.185 - {rew_ord'="tless_true",
24.186 - rls' = append_rls "erls_IntegrierenUndK.." e_rls
24.187 - [Calc ("Atools.ident",eval_ident "#ident_"),
24.188 - Thm ("not_true",num_str not_true),
24.189 - Thm ("not_false",num_str not_false)],
24.190 - calc = [], srls = srls, prls = Erls,
24.191 - crls = Atools_erls, nrls = Erls},
24.192 -"Script BiegelinieScript \
24.193 -\(l_::real) (q__::real) (v_::real) (b_::real=>real) \
24.194 -\(rb_::bool list) (rm_::bool list) = \
24.195 -\ (let q___ = Take (q_ v_ = q__); \
24.196 -\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \
24.197 -\ (Rewrite Belastung_Querkraft True)) q___; \
24.198 -\ (Q__:: bool) = \
24.199 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.200 -\ [diff,integration,named]) \
24.201 -\ [real_ (rhs q___), real_ v_, real_real_ Q]); \
24.202 -\ Q__ = Rewrite Querkraft_Moment True Q__; \
24.203 -\ (M__::bool) = \
24.204 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.205 -\ [diff,integration,named]) \
24.206 -\ [real_ (rhs Q__), real_ v_, real_real_ M_b]); \
24.207 -\ e1__ = nth_ 1 rm_; \
24.208 -\ (x1__::real) = argument_in (lhs e1__); \
24.209 -\ (M1__::bool) = (Substitute [v_ = x1__]) M__; \
24.210 -\ M1__ = (Substitute [e1__]) M1__ ; \
24.211 -\ M2__ = Take M__; "^
24.212 -(*without this Take 'Substitute [v_ = x2__]' takes _last formula from ctree_*)
24.213 -" e2__ = nth_ 2 rm_; \
24.214 -\ (x2__::real) = argument_in (lhs e2__); \
24.215 -\ (M2__::bool) = ((Substitute [v_ = x2__]) @@ \
24.216 -\ (Substitute [e2__])) M2__; \
24.217 -\ (c_1_2__::bool list) = \
24.218 -\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \
24.219 -\ [booll_ [M1__, M2__], reall [c,c_2]]); \
24.220 -\ M__ = Take M__; \
24.221 -\ M__ = ((Substitute c_1_2__) @@ \
24.222 -\ (Try (Rewrite_Set_Inst [(bdv_1, c),(bdv_2, c_2)]\
24.223 -\ simplify_System False)) @@ \
24.224 -\ (Rewrite Moment_Neigung False) @@ \
24.225 -\ (Rewrite make_fun_explicit False)) M__; "^
24.226 -(*----------------------- and the same once more ------------------------*)
24.227 -" (N__:: bool) = \
24.228 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.229 -\ [diff,integration,named]) \
24.230 -\ [real_ (rhs M__), real_ v_, real_real_ y']); \
24.231 -\ (B__:: bool) = \
24.232 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.233 -\ [diff,integration,named]) \
24.234 -\ [real_ (rhs N__), real_ v_, real_real_ y]); \
24.235 -\ e1__ = nth_ 1 rb_; \
24.236 -\ (x1__::real) = argument_in (lhs e1__); \
24.237 -\ (B1__::bool) = (Substitute [v_ = x1__]) B__; \
24.238 -\ B1__ = (Substitute [e1__]) B1__ ; \
24.239 -\ B2__ = Take B__; \
24.240 -\ e2__ = nth_ 2 rb_; \
24.241 -\ (x2__::real) = argument_in (lhs e2__); \
24.242 -\ (B2__::bool) = ((Substitute [v_ = x2__]) @@ \
24.243 -\ (Substitute [e2__])) B2__; \
24.244 -\ (c_1_2__::bool list) = \
24.245 -\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \
24.246 -\ [booll_ [B1__, B2__], reall [c,c_2]]); \
24.247 -\ B__ = Take B__; \
24.248 -\ B__ = ((Substitute c_1_2__) @@ \
24.249 -\ (Rewrite_Set_Inst [(bdv, x)] make_ratpoly_in False)) B__ \
24.250 -\ in B__)"
24.251 -));
24.252 -
24.253 -store_met
24.254 - (prep_met Biegelinie.thy "met_biege_2" [] e_metID
24.255 - (["IntegrierenUndKonstanteBestimmen2"],
24.256 - [("#Given" ,["Traegerlaenge l_", "Streckenlast q__",
24.257 - "FunktionsVariable v_"]),
24.258 - (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
24.259 - ("#Find" ,["Biegelinie b_"]),
24.260 - ("#Relate",["Randbedingungen rb_"])
24.261 - ],
24.262 - {rew_ord'="tless_true",
24.263 - rls' = append_rls "erls_IntegrierenUndK.." e_rls
24.264 - [Calc ("Atools.ident",eval_ident "#ident_"),
24.265 - Thm ("not_true",num_str not_true),
24.266 - Thm ("not_false",num_str not_false)],
24.267 - calc = [],
24.268 - srls = append_rls "erls_IntegrierenUndK.." e_rls
24.269 - [Calc("Tools.rhs", eval_rhs"eval_rhs_"),
24.270 - Calc ("Atools.ident",eval_ident "#ident_"),
24.271 - Thm ("last_thmI",num_str last_thmI),
24.272 - Thm ("if_True",num_str if_True),
24.273 - Thm ("if_False",num_str if_False)
24.274 - ],
24.275 - prls = Erls, crls = Atools_erls, nrls = Erls},
24.276 -"Script Biegelinie2Script \
24.277 -\(l_::real) (q__::real) (v_::real) (b_::real=>real) (rb_::bool list) = \
24.278 -\ (let \
24.279 -\ (funs_:: bool list) = \
24.280 -\ (SubProblem (Biegelinie_,[vonBelastungZu,Biegelinien], \
24.281 -\ [Biegelinien,ausBelastung]) \
24.282 -\ [real_ q__, real_ v_]); \
24.283 -\ (equs_::bool list) = \
24.284 -\ (SubProblem (Biegelinie_,[setzeRandbedingungen,Biegelinien],\
24.285 -\ [Biegelinien,setzeRandbedingungenEin]) \
24.286 -\ [booll_ funs_, booll_ rb_]); \
24.287 -\ (cons_::bool list) = \
24.288 -\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \
24.289 -\ [booll_ equs_, reall [c,c_2,c_3,c_4]]); \
24.290 -\ B_ = Take (lastI funs_); \
24.291 -\ B_ = ((Substitute cons_) @@ \
24.292 -\ (Rewrite_Set_Inst [(bdv, v_)] make_ratpoly_in False)) B_ \
24.293 -\ in B_)"
24.294 -));
24.295 -
24.296 -store_met
24.297 - (prep_met Biegelinie.thy "met_biege_intconst_2" [] e_metID
24.298 - (["IntegrierenUndKonstanteBestimmen","2xIntegrieren"],
24.299 - [],
24.300 - {rew_ord'="tless_true", rls'=Erls, calc = [],
24.301 - srls = e_rls,
24.302 - prls=e_rls,
24.303 - crls = Atools_erls, nrls = e_rls},
24.304 -"empty_script"
24.305 -));
24.306 -
24.307 -store_met
24.308 - (prep_met Biegelinie.thy "met_biege_intconst_4" [] e_metID
24.309 - (["IntegrierenUndKonstanteBestimmen","4x4System"],
24.310 - [],
24.311 - {rew_ord'="tless_true", rls'=Erls, calc = [],
24.312 - srls = e_rls,
24.313 - prls=e_rls,
24.314 - crls = Atools_erls, nrls = e_rls},
24.315 -"empty_script"
24.316 -));
24.317 -
24.318 -store_met
24.319 - (prep_met Biegelinie.thy "met_biege_intconst_1" [] e_metID
24.320 - (["IntegrierenUndKonstanteBestimmen","1xIntegrieren"],
24.321 - [],
24.322 - {rew_ord'="tless_true", rls'=Erls, calc = [],
24.323 - srls = e_rls,
24.324 - prls=e_rls,
24.325 - crls = Atools_erls, nrls = e_rls},
24.326 -"empty_script"
24.327 -));
24.328 -
24.329 -store_met
24.330 - (prep_met Biegelinie.thy "met_biege2" [] e_metID
24.331 - (["Biegelinien"],
24.332 - [],
24.333 - {rew_ord'="tless_true", rls'=Erls, calc = [],
24.334 - srls = e_rls,
24.335 - prls=e_rls,
24.336 - crls = Atools_erls, nrls = e_rls},
24.337 -"empty_script"
24.338 -));
24.339 -
24.340 -store_met
24.341 - (prep_met Biegelinie.thy "met_biege_ausbelast" [] e_metID
24.342 - (["Biegelinien","ausBelastung"],
24.343 - [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]),
24.344 - ("#Find" ,["Funktionen funs_"])],
24.345 - {rew_ord'="tless_true",
24.346 - rls' = append_rls "erls_ausBelastung" e_rls
24.347 - [Calc ("Atools.ident",eval_ident "#ident_"),
24.348 - Thm ("not_true",num_str not_true),
24.349 - Thm ("not_false",num_str not_false)],
24.350 - calc = [],
24.351 - srls = append_rls "srls_ausBelastung" e_rls
24.352 - [Calc("Tools.rhs", eval_rhs"eval_rhs_")],
24.353 - prls = e_rls, crls = Atools_erls, nrls = e_rls},
24.354 -"Script Belastung2BiegelScript (q__::real) (v_::real) = \
24.355 -\ (let q___ = Take (q_ v_ = q__); \
24.356 -\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \
24.357 -\ (Rewrite Belastung_Querkraft True)) q___; \
24.358 -\ (Q__:: bool) = \
24.359 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.360 -\ [diff,integration,named]) \
24.361 -\ [real_ (rhs q___), real_ v_, real_real_ Q]); \
24.362 -\ M__ = Rewrite Querkraft_Moment True Q__; \
24.363 -\ (M__::bool) = \
24.364 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.365 -\ [diff,integration,named]) \
24.366 -\ [real_ (rhs M__), real_ v_, real_real_ M_b]); \
24.367 -\ N__ = ((Rewrite Moment_Neigung False) @@ \
24.368 -\ (Rewrite make_fun_explicit False)) M__; \
24.369 -\ (N__:: bool) = \
24.370 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.371 -\ [diff,integration,named]) \
24.372 -\ [real_ (rhs N__), real_ v_, real_real_ y']); \
24.373 -\ (B__:: bool) = \
24.374 -\ (SubProblem (Biegelinie_,[named,integrate,function], \
24.375 -\ [diff,integration,named]) \
24.376 -\ [real_ (rhs N__), real_ v_, real_real_ y]) \
24.377 -\ in [Q__, M__, N__, B__])"
24.378 -));
24.379 -
24.380 -store_met
24.381 - (prep_met Biegelinie.thy "met_biege_setzrand" [] e_metID
24.382 - (["Biegelinien","setzeRandbedingungenEin"],
24.383 - [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]),
24.384 - ("#Find" ,["Gleichungen equs___"])],
24.385 - {rew_ord'="tless_true", rls'=Erls, calc = [],
24.386 - srls = srls2,
24.387 - prls=e_rls,
24.388 - crls = Atools_erls, nrls = e_rls},
24.389 -"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \
24.390 -\ (let b1_ = nth_ 1 rb_; \
24.391 -\ fs_ = filter_sameFunId (lhs b1_) funs_; \
24.392 -\ (e1_::bool) = \
24.393 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.394 -\ [Equation,fromFunction]) \
24.395 -\ [bool_ (hd fs_), bool_ b1_]); \
24.396 -\ b2_ = nth_ 2 rb_; \
24.397 -\ fs_ = filter_sameFunId (lhs b2_) funs_; \
24.398 -\ (e2_::bool) = \
24.399 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.400 -\ [Equation,fromFunction]) \
24.401 -\ [bool_ (hd fs_), bool_ b2_]); \
24.402 -\ b3_ = nth_ 3 rb_; \
24.403 -\ fs_ = filter_sameFunId (lhs b3_) funs_; \
24.404 -\ (e3_::bool) = \
24.405 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.406 -\ [Equation,fromFunction]) \
24.407 -\ [bool_ (hd fs_), bool_ b3_]); \
24.408 -\ b4_ = nth_ 4 rb_; \
24.409 -\ fs_ = filter_sameFunId (lhs b4_) funs_; \
24.410 -\ (e4_::bool) = \
24.411 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.412 -\ [Equation,fromFunction]) \
24.413 -\ [bool_ (hd fs_), bool_ b4_]) \
24.414 -\ in [e1_,e2_,e3_,e4_])"
24.415 -(* filter requires more than 1 sec !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
24.416 -"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \
24.417 -\ (let b1_ = nth_ 1 rb_; \
24.418 -\ fs_ = filter (sameFunId (lhs b1_)) funs_; \
24.419 -\ (e1_::bool) = \
24.420 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.421 -\ [Equation,fromFunction]) \
24.422 -\ [bool_ (hd fs_), bool_ b1_]); \
24.423 -\ b2_ = nth_ 2 rb_; \
24.424 -\ fs_ = filter (sameFunId (lhs b2_)) funs_; \
24.425 -\ (e2_::bool) = \
24.426 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.427 -\ [Equation,fromFunction]) \
24.428 -\ [bool_ (hd fs_), bool_ b2_]); \
24.429 -\ b3_ = nth_ 3 rb_; \
24.430 -\ fs_ = filter (sameFunId (lhs b3_)) funs_; \
24.431 -\ (e3_::bool) = \
24.432 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.433 -\ [Equation,fromFunction]) \
24.434 -\ [bool_ (hd fs_), bool_ b3_]); \
24.435 -\ b4_ = nth_ 4 rb_; \
24.436 -\ fs_ = filter (sameFunId (lhs b4_)) funs_; \
24.437 -\ (e4_::bool) = \
24.438 -\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
24.439 -\ [Equation,fromFunction]) \
24.440 -\ [bool_ (hd fs_), bool_ b4_]) \
24.441 -\ in [e1_,e2_,e3_,e4_])"*)
24.442 -));
24.443 -
24.444 -store_met
24.445 - (prep_met Biegelinie.thy "met_equ_fromfun" [] e_metID
24.446 - (["Equation","fromFunction"],
24.447 - [("#Given" ,["functionEq fun_","substitution sub_"]),
24.448 - ("#Find" ,["equality equ___"])],
24.449 - {rew_ord'="tless_true", rls'=Erls, calc = [],
24.450 - srls = append_rls "srls_in_EquationfromFunc" e_rls
24.451 - [Calc("Tools.lhs", eval_lhs"eval_lhs_"),
24.452 - Calc("Atools.argument'_in",
24.453 - eval_argument_in
24.454 - "Atools.argument'_in")],
24.455 - prls=e_rls,
24.456 - crls = Atools_erls, nrls = e_rls},
24.457 -(*(M_b x = c_2 + c * x + -1 * q_0 / 2 * x ^^^ 2) (M_b L = 0) -->
24.458 - 0 = c_2 + c * L + -1 * q_0 / 2 * L ^^^ 2*)
24.459 -"Script Function2Equality (fun_::bool) (sub_::bool) =\
24.460 -\ (let fun_ = Take fun_; \
24.461 -\ bdv_ = argument_in (lhs fun_); \
24.462 -\ val_ = argument_in (lhs sub_); \
24.463 -\ equ_ = (Substitute [bdv_ = val_]) fun_; \
24.464 -\ equ_ = (Substitute [sub_]) fun_ \
24.465 -\ in (Rewrite_Set norm_Rational False) equ_) "
24.466 -));
24.467 -
24.468 -
24.469 -
24.470 -(* use"IsacKnowledge/Biegelinie.ML";
24.471 - *)
24.472 \ No newline at end of file
25.1 --- a/src/Tools/isac/IsacKnowledge/Biegelinie.thy Wed Aug 25 15:15:01 2010 +0200
25.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
25.3 @@ -1,82 +0,0 @@
25.4 -(* chapter 'Biegelinie' from the textbook:
25.5 - Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271.
25.6 - author: Walther Neuper
25.7 - 050826,
25.8 - (c) due to copyright terms
25.9 -
25.10 -remove_thy"Biegelinie";
25.11 -use_thy"IsacKnowledge/Biegelinie";
25.12 -use_thy_only"IsacKnowledge/Biegelinie";
25.13 -
25.14 -remove_thy"Biegelinie";
25.15 -use_thy"IsacKnowledge/Isac";
25.16 -*)
25.17 -
25.18 -Biegelinie = Integrate + Equation + EqSystem +
25.19 -
25.20 -consts
25.21 -
25.22 - q_ :: real => real ("q'_") (* Streckenlast *)
25.23 - Q :: real => real (* Querkraft *)
25.24 - Q' :: real => real (* Ableitung der Querkraft *)
25.25 - M'_b :: real => real ("M'_b") (* Biegemoment *)
25.26 - M'_b' :: real => real ("M'_b'") (* Ableitung des Biegemoments *)
25.27 - y'' :: real => real (* 2.Ableitung der Biegeline *)
25.28 - y' :: real => real (* Neigung der Biegeline *)
25.29 -(*y :: real => real (* Biegeline *)*)
25.30 - EI :: real (* Biegesteifigkeit *)
25.31 -
25.32 - (*new Descriptions in the related problems*)
25.33 - Traegerlaenge :: real => una
25.34 - Streckenlast :: real => una
25.35 - BiegemomentVerlauf :: bool => una
25.36 - Biegelinie :: (real => real) => una
25.37 - Randbedingungen :: bool list => una
25.38 - RandbedingungenBiegung :: bool list => una
25.39 - RandbedingungenNeigung :: bool list => una
25.40 - RandbedingungenMoment :: bool list => una
25.41 - RandbedingungenQuerkraft :: bool list => una
25.42 - FunktionsVariable :: real => una
25.43 - Funktionen :: bool list => una
25.44 - Gleichungen :: bool list => una
25.45 -
25.46 - (*Script-names*)
25.47 - Biegelinie2Script :: "[real,real,real,real=>real,bool list,
25.48 - bool] => bool"
25.49 - ("((Script Biegelinie2Script (_ _ _ _ _ =))// (_))" 9)
25.50 - BiegelinieScript :: "[real,real,real,real=>real,bool list,bool list,
25.51 - bool] => bool"
25.52 - ("((Script BiegelinieScript (_ _ _ _ _ _ =))// (_))" 9)
25.53 - Biege2xIntegrierenScript :: "[real,real,real,bool,real=>real,bool list,
25.54 - bool] => bool"
25.55 - ("((Script Biege2xIntegrierenScript (_ _ _ _ _ _ =))// (_))" 9)
25.56 - Biege4x4SystemScript :: "[real,real,real,real=>real,bool list,
25.57 - bool] => bool"
25.58 - ("((Script Biege4x4SystemScript (_ _ _ _ _ =))// (_))" 9)
25.59 - Biege1xIntegrierenScript ::
25.60 - "[real,real,real,real=>real,bool list,bool list,bool list,
25.61 - bool] => bool"
25.62 - ("((Script Biege1xIntegrierenScript (_ _ _ _ _ _ _ =))// (_))" 9)
25.63 - Belastung2BiegelScript :: "[real,real,
25.64 - bool list] => bool list"
25.65 - ("((Script Belastung2BiegelScript (_ _ =))// (_))" 9)
25.66 - SetzeRandbedScript :: "[bool list,bool list,
25.67 - bool list] => bool list"
25.68 - ("((Script SetzeRandbedScript (_ _ =))// (_))" 9)
25.69 -
25.70 -rules
25.71 -
25.72 - Querkraft_Belastung "Q' x = -q_ x"
25.73 - Belastung_Querkraft "-q_ x = Q' x"
25.74 -
25.75 - Moment_Querkraft "M_b' x = Q x"
25.76 - Querkraft_Moment "Q x = M_b' x"
25.77 -
25.78 - Neigung_Moment "y'' x = -M_b x/ EI"
25.79 - Moment_Neigung "M_b x = -EI * y'' x"
25.80 -
25.81 - (*according to rls 'simplify_Integral': .. = 1/a * .. instead .. = ../ a*)
25.82 - make_fun_explicit "Not (a =!= 0) ==> (a * (f x) = b) = (f x = 1/a * b)"
25.83 -
25.84 -end
25.85 -
26.1 --- a/src/Tools/isac/IsacKnowledge/Calculus.thy Wed Aug 25 15:15:01 2010 +0200
26.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
26.3 @@ -1,4 +0,0 @@
26.4 -
26.5 -Calculus = Real +
26.6 -
26.7 -end
26.8 \ No newline at end of file
27.1 --- a/src/Tools/isac/IsacKnowledge/Descript.thy Wed Aug 25 15:15:01 2010 +0200
27.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
27.3 @@ -1,52 +0,0 @@
27.4 -(* Title: descriptions for items in model-patterns of problems and in method's
27.5 - guards
27.6 - Author: Walther Neuper 000301
27.7 - (c) due to copyright terms
27.8 - + see WN, Reactive User-Guidance ... Vers. Oct.2000 p.48 ff
27.9 -
27.10 -remove_thy"Descript";
27.11 -use_thy"IsacKnowledge/Descript";
27.12 -use_thy_only"IsacKnowledge/Descript";
27.13 -
27.14 -remove_thy"Typefix";
27.15 -use_thy"IsacKnowledge/Isac";
27.16 -*)
27.17 -
27.18 -theory Descript imports "../Scripts/Script" begin
27.19 -
27.20 -consts
27.21 -
27.22 - someList :: "'a list => unl" (*not for elementwise input, eg. inssort*)
27.23 -
27.24 - additionalRels :: "bool list => una"
27.25 - boundVariable :: "real => una"
27.26 -(*derivative :: 'a => toreal 28.11.00*)
27.27 - derivative :: "real => una"
27.28 - equalities :: "bool list => tobooll" (*WN071228 see fixedValues*)
27.29 - equality :: "bool => una"
27.30 - errorBound :: "bool => nam"
27.31 -
27.32 - fixedValues :: "bool list => nam"
27.33 - functionEq :: "bool => una" (*6.5.03: functionTerm -> functionEq*)
27.34 - antiDerivative :: "bool => una"
27.35 - functionOf :: "real => una"
27.36 -(*functionTerm :: 'a => toreal 28.11.00*)
27.37 - functionTerm :: "real => una" (*6.5.03: functionTerm -> functionEq*)
27.38 - interval :: "real set => una"
27.39 - maxArgument :: "bool => toreal"
27.40 - maximum :: "real => toreal"
27.41 -
27.42 - relations :: "bool list => una"
27.43 - solutions :: "bool list => toreall"
27.44 -(*solution :: bool => toreal WN0509 bool list=> toreall --->EqSystem*)
27.45 - solveFor :: "real => una"
27.46 - differentiateFor:: "real => una"
27.47 - unknown :: "'a => unknow"
27.48 - valuesFor :: "real list => toreall"
27.49 -
27.50 - realTestGiven :: "real => una"
27.51 - realTestFind :: "real => una"
27.52 - boolTestGiven :: "bool => una"
27.53 - boolTestFind :: "bool => una"
27.54 -
27.55 -end
27.56 \ No newline at end of file
28.1 --- a/src/Tools/isac/IsacKnowledge/Diff.ML Wed Aug 25 15:15:01 2010 +0200
28.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
28.3 @@ -1,370 +0,0 @@
28.4 -(* tools for differentiation
28.5 - WN.11.99
28.6 -
28.7 -use"IsacKnowledge/Diff.ML";
28.8 -use"Diff.ML";
28.9 - *)
28.10 -
28.11 -
28.12 -(** interface isabelle -- isac **)
28.13 -
28.14 -theory' := overwritel (!theory', [("Diff.thy",Diff.thy)]);
28.15 -
28.16 -
28.17 -(** eval functions **)
28.18 -
28.19 -fun primed (Const (id, T)) = Const (id ^ "'", T)
28.20 - | primed (Free (id, T)) = Free (id ^ "'", T)
28.21 - | primed t = raise error ("primed called with arg = '"^ term2str t ^"'");
28.22 -
28.23 -(*("primed", ("Diff.primed", eval_primed "#primed"))*)
28.24 -fun eval_primed _ _ (p as (Const ("Diff.primed",_) $ t)) _ =
28.25 - SOME ((term2str p) ^ " = " ^ term2str (primed t),
28.26 - Trueprop $ (mk_equality (p, primed t)))
28.27 - | eval_primed _ _ _ _ = NONE;
28.28 -
28.29 -calclist':= overwritel (!calclist',
28.30 - [("primed", ("Diff.primed", eval_primed "#primed"))
28.31 - ]);
28.32 -
28.33 -
28.34 -(** rulesets **)
28.35 -
28.36 -(*.converts a term such that differentiation works optimally.*)
28.37 -val diff_conv =
28.38 - Rls {id="diff_conv",
28.39 - preconds = [],
28.40 - rew_ord = ("termlessI",termlessI),
28.41 - erls = append_rls "erls_diff_conv" e_rls
28.42 - [Calc ("Atools.occurs'_in", eval_occurs_in ""),
28.43 - Thm ("not_true",num_str not_true),
28.44 - Thm ("not_false",num_str not_false),
28.45 - Calc ("op <",eval_equ "#less_"),
28.46 - Thm ("and_true",num_str and_true),
28.47 - Thm ("and_false",num_str and_false)
28.48 - ],
28.49 - srls = Erls, calc = [],
28.50 - rules = [Thm ("frac_conv", num_str frac_conv),
28.51 - Thm ("sqrt_conv_bdv", num_str sqrt_conv_bdv),
28.52 - Thm ("sqrt_conv_bdv_n", num_str sqrt_conv_bdv_n),
28.53 - Thm ("sqrt_conv", num_str sqrt_conv),
28.54 - Thm ("root_conv", num_str root_conv),
28.55 - Thm ("realpow_pow_bdv", num_str realpow_pow_bdv),
28.56 - Calc ("op *", eval_binop "#mult_"),
28.57 - Thm ("rat_mult",num_str rat_mult),
28.58 - (*a / b * (c / d) = a * c / (b * d)*)
28.59 - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
28.60 - (*?x * (?y / ?z) = ?x * ?y / ?z*)
28.61 - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq)
28.62 - (*?y / ?z * ?x = ?y * ?x / ?z*)
28.63 - (*
28.64 - Thm ("", num_str ),*)
28.65 - ],
28.66 - scr = EmptyScr};
28.67 -
28.68 -(*.beautifies a term after differentiation.*)
28.69 -val diff_sym_conv =
28.70 - Rls {id="diff_sym_conv",
28.71 - preconds = [],
28.72 - rew_ord = ("termlessI",termlessI),
28.73 - erls = append_rls "erls_diff_sym_conv" e_rls
28.74 - [Calc ("op <",eval_equ "#less_")
28.75 - ],
28.76 - srls = Erls, calc = [],
28.77 - rules = [Thm ("frac_sym_conv", num_str frac_sym_conv),
28.78 - Thm ("sqrt_sym_conv", num_str sqrt_sym_conv),
28.79 - Thm ("root_sym_conv", num_str root_sym_conv),
28.80 - Thm ("sym_real_mult_minus1",
28.81 - num_str (real_mult_minus1 RS sym)),
28.82 - (*- ?z = "-1 * ?z"*)
28.83 - Thm ("rat_mult",num_str rat_mult),
28.84 - (*a / b * (c / d) = a * c / (b * d)*)
28.85 - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
28.86 - (*?x * (?y / ?z) = ?x * ?y / ?z*)
28.87 - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
28.88 - (*?y / ?z * ?x = ?y * ?x / ?z*)
28.89 - Calc ("op *", eval_binop "#mult_")
28.90 - ],
28.91 - scr = EmptyScr};
28.92 -
28.93 -(*..*)
28.94 -val srls_diff =
28.95 - Rls {id="srls_differentiate..",
28.96 - preconds = [],
28.97 - rew_ord = ("termlessI",termlessI),
28.98 - erls = e_rls,
28.99 - srls = Erls, calc = [],
28.100 - rules = [Calc("Tools.lhs", eval_lhs "eval_lhs_"),
28.101 - Calc("Tools.rhs", eval_rhs "eval_rhs_"),
28.102 - Calc("Diff.primed", eval_primed "Diff.primed")
28.103 - ],
28.104 - scr = EmptyScr};
28.105 -
28.106 -(*..*)
28.107 -val erls_diff =
28.108 - append_rls "erls_differentiate.." e_rls
28.109 - [Thm ("not_true",num_str not_true),
28.110 - Thm ("not_false",num_str not_false),
28.111 -
28.112 - Calc ("Atools.ident",eval_ident "#ident_"),
28.113 - Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"),
28.114 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
28.115 - Calc ("Atools.is'_const",eval_const "#is_const_")
28.116 - ];
28.117 -
28.118 -(*.rules for differentiation, _no_ simplification.*)
28.119 -val diff_rules =
28.120 - Rls {id="diff_rules", preconds = [], rew_ord = ("termlessI",termlessI),
28.121 - erls = erls_diff, srls = Erls, calc = [],
28.122 - rules = [Thm ("diff_sum",num_str diff_sum),
28.123 - Thm ("diff_dif",num_str diff_dif),
28.124 - Thm ("diff_prod_const",num_str diff_prod_const),
28.125 - Thm ("diff_prod",num_str diff_prod),
28.126 - Thm ("diff_quot",num_str diff_quot),
28.127 - Thm ("diff_sin",num_str diff_sin),
28.128 - Thm ("diff_sin_chain",num_str diff_sin_chain),
28.129 - Thm ("diff_cos",num_str diff_cos),
28.130 - Thm ("diff_cos_chain",num_str diff_cos_chain),
28.131 - Thm ("diff_pow",num_str diff_pow),
28.132 - Thm ("diff_pow_chain",num_str diff_pow_chain),
28.133 - Thm ("diff_ln",num_str diff_ln),
28.134 - Thm ("diff_ln_chain",num_str diff_ln_chain),
28.135 - Thm ("diff_exp",num_str diff_exp),
28.136 - Thm ("diff_exp_chain",num_str diff_exp_chain),
28.137 -(*
28.138 - Thm ("diff_sqrt",num_str diff_sqrt),
28.139 - Thm ("diff_sqrt_chain",num_str diff_sqrt_chain),
28.140 -*)
28.141 - Thm ("diff_const",num_str diff_const),
28.142 - Thm ("diff_var",num_str diff_var)
28.143 - ],
28.144 - scr = EmptyScr};
28.145 -
28.146 -(*.normalisation for checking user-input.*)
28.147 -val norm_diff =
28.148 - Rls {id="diff_rls", preconds = [], rew_ord = ("termlessI",termlessI),
28.149 - erls = Erls, srls = Erls, calc = [],
28.150 - rules = [Rls_ diff_rules,
28.151 - Rls_ norm_Poly
28.152 - ],
28.153 - scr = EmptyScr};
28.154 -ruleset' :=
28.155 -overwritelthy thy (!ruleset',
28.156 - [("diff_rules", prep_rls norm_diff),
28.157 - ("norm_diff", prep_rls norm_diff),
28.158 - ("diff_conv", prep_rls diff_conv),
28.159 - ("diff_sym_conv", prep_rls diff_sym_conv)
28.160 - ]);
28.161 -
28.162 -
28.163 -(** problem types **)
28.164 -
28.165 -store_pbt
28.166 - (prep_pbt Diff.thy "pbl_fun" [] e_pblID
28.167 - (["function"], [], e_rls, NONE, []));
28.168 -
28.169 -store_pbt
28.170 - (prep_pbt Diff.thy "pbl_fun_deriv" [] e_pblID
28.171 - (["derivative_of","function"],
28.172 - [("#Given" ,["functionTerm f_","differentiateFor v_"]),
28.173 - ("#Find" ,["derivative f_'_"])
28.174 - ],
28.175 - append_rls "e_rls" e_rls [],
28.176 - SOME "Diff (f_, v_)", [["diff","differentiate_on_R"],
28.177 - ["diff","after_simplification"]]));
28.178 -
28.179 -(*here "named" is used differently from Integration"*)
28.180 -store_pbt
28.181 - (prep_pbt Diff.thy "pbl_fun_deriv_nam" [] e_pblID
28.182 - (["named","derivative_of","function"],
28.183 - [("#Given" ,["functionEq f_","differentiateFor v_"]),
28.184 - ("#Find" ,["derivativeEq f_'_"])
28.185 - ],
28.186 - append_rls "e_rls" e_rls [],
28.187 - SOME "Differentiate (f_, v_)", [["diff","differentiate_equality"]]));
28.188 -
28.189 -
28.190 -(** methods **)
28.191 -
28.192 -store_met
28.193 - (prep_met Diff.thy "met_diff" [] e_metID
28.194 - (["diff"], [],
28.195 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
28.196 - crls = Atools_erls, nrls = norm_diff}, "empty_script"));
28.197 -
28.198 -store_met
28.199 - (prep_met Diff.thy "met_diff_onR" [] e_metID
28.200 - (["diff","differentiate_on_R"],
28.201 - [("#Given" ,["functionTerm f_","differentiateFor v_"]),
28.202 - ("#Find" ,["derivative f_'_"])
28.203 - ],
28.204 - {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls,
28.205 - prls=e_rls, crls = Atools_erls, nrls = norm_diff},
28.206 -"Script DiffScr (f_::real) (v_::real) = \
28.207 -\ (let f'_ = Take (d_d v_ f_) \
28.208 -\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \
28.209 -\ (Repeat \
28.210 -\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
28.211 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
28.212 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
28.213 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
28.214 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
28.215 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
28.216 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
28.217 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
28.218 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
28.219 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
28.220 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
28.221 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
28.222 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
28.223 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
28.224 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
28.225 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
28.226 -\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \
28.227 -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)"
28.228 -));
28.229 -
28.230 -store_met
28.231 - (prep_met Diff.thy "met_diff_simpl" [] e_metID
28.232 - (["diff","diff_simpl"],
28.233 - [("#Given" ,["functionTerm f_","differentiateFor v_"]),
28.234 - ("#Find" ,["derivative f_'_"])
28.235 - ],
28.236 - {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls,
28.237 - prls=e_rls, crls = Atools_erls, nrls = norm_diff},
28.238 -"Script DiffScr (f_::real) (v_::real) = \
28.239 -\ (let f'_ = Take (d_d v_ f_) \
28.240 -\ in (( \
28.241 -\ (Repeat \
28.242 -\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
28.243 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
28.244 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
28.245 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
28.246 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
28.247 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
28.248 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
28.249 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
28.250 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
28.251 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
28.252 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
28.253 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
28.254 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
28.255 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
28.256 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
28.257 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
28.258 -\ (Repeat (Rewrite_Set make_polynomial False)))) \
28.259 -\ )) f'_)"
28.260 - ));
28.261 -
28.262 -(*-----------------------------------------------------------------
28.263 - "Script DiffScr (f_::real) (v_::real) = \
28.264 - \(Repeat \
28.265 - \ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
28.266 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
28.267 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
28.268 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
28.269 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
28.270 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
28.271 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
28.272 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
28.273 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
28.274 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
28.275 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
28.276 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
28.277 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
28.278 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
28.279 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
28.280 - \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
28.281 - \ (Repeat (Rewrite_Set make_polynomial False)))) \
28.282 - \ (f_::real)"
28.283 -*)
28.284 -
28.285 -store_met
28.286 - (prep_met Diff.thy "met_diff_equ" [] e_metID
28.287 - (["diff","differentiate_equality"],
28.288 - [("#Given" ,["functionEq f_","differentiateFor v_"]),
28.289 - ("#Find" ,["derivativeEq f_'_"])
28.290 - ],
28.291 - {rew_ord'="tless_true", rls' = erls_diff, calc = [],
28.292 - srls = srls_diff, prls=e_rls, crls=Atools_erls, nrls = norm_diff},
28.293 -"Script DiffEqScr (f_::bool) (v_::real) = \
28.294 -\ (let f'_ = Take ((primed (lhs f_)) = d_d v_ (rhs f_)) \
28.295 -\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \
28.296 -\ (Repeat \
28.297 -\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
28.298 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_dif False)) Or \
28.299 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
28.300 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
28.301 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
28.302 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
28.303 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
28.304 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
28.305 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
28.306 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
28.307 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
28.308 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
28.309 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
28.310 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
28.311 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
28.312 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
28.313 -\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
28.314 -\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \
28.315 -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)"
28.316 -));
28.317 -
28.318 -
28.319 -store_met
28.320 - (prep_met Diff.thy "met_diff_after_simp" [] e_metID
28.321 - (["diff","after_simplification"],
28.322 - [("#Given" ,["functionTerm f_","differentiateFor v_"]),
28.323 - ("#Find" ,["derivative f_'_"])
28.324 - ],
28.325 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, prls=e_rls,
28.326 - crls=Atools_erls, nrls = norm_Rational},
28.327 -"Script DiffScr (f_::real) (v_::real) = \
28.328 -\ (let f'_ = Take (d_d v_ f_) \
28.329 -\ in ((Try (Rewrite_Set norm_Rational False)) @@ \
28.330 -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \
28.331 -\ (Try (Rewrite_Set_Inst [(bdv,v_)] norm_diff False)) @@ \
28.332 -\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)) @@ \
28.333 -\ (Try (Rewrite_Set norm_Rational False))) f'_)"
28.334 -));
28.335 -
28.336 -
28.337 -(** CAS-commands **)
28.338 -
28.339 -(*.handle cas-input like "Diff (a * x^3 + b, x)".*)
28.340 -(* val (t, pairl) = strip_comb (str2term "Diff (a * x^3 + b, x)");
28.341 - val [Const ("Pair", _) $ t $ bdv] = pairl;
28.342 - *)
28.343 -fun argl2dtss [Const ("Pair", _) $ t $ bdv] =
28.344 - [((term_of o the o (parse thy)) "functionTerm", [t]),
28.345 - ((term_of o the o (parse thy)) "differentiateFor", [bdv]),
28.346 - ((term_of o the o (parse thy)) "derivative",
28.347 - [(term_of o the o (parse thy)) "f_'_"])
28.348 - ]
28.349 - | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss";
28.350 -castab :=
28.351 -overwritel (!castab,
28.352 - [((term_of o the o (parse thy)) "Diff",
28.353 - (("Isac.thy", ["derivative_of","function"], ["no_met"]),
28.354 - argl2dtss))
28.355 - ]);
28.356 -
28.357 -(*.handle cas-input like "Differentiate (A = s * (a - s), s)".*)
28.358 -(* val (t, pairl) = strip_comb (str2term "Differentiate (A = s * (a - s), s)");
28.359 - val [Const ("Pair", _) $ t $ bdv] = pairl;
28.360 - *)
28.361 -fun argl2dtss [Const ("Pair", _) $ t $ bdv] =
28.362 - [((term_of o the o (parse thy)) "functionEq", [t]),
28.363 - ((term_of o the o (parse thy)) "differentiateFor", [bdv]),
28.364 - ((term_of o the o (parse thy)) "derivativeEq",
28.365 - [(term_of o the o (parse thy)) "f_'_::bool"])
28.366 - ]
28.367 - | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss";
28.368 -castab :=
28.369 -overwritel (!castab,
28.370 - [((term_of o the o (parse thy)) "Differentiate",
28.371 - (("Isac.thy", ["named","derivative_of","function"], ["no_met"]),
28.372 - argl2dtss))
28.373 - ]);
29.1 --- a/src/Tools/isac/IsacKnowledge/Diff.thy Wed Aug 25 15:15:01 2010 +0200
29.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
29.3 @@ -1,97 +0,0 @@
29.4 -(* differentiation over the reals
29.5 - author: Walther Neuper
29.6 - 000516
29.7 -
29.8 -remove_thy"Diff";
29.9 -use_thy_only"IsacKnowledge/Diff";
29.10 -use_thy"IsacKnowledge/Isac";
29.11 - *)
29.12 -
29.13 -Diff = Calculus + Trig + LogExp + Rational + Root + Poly + Atools +
29.14 -
29.15 -consts
29.16 -
29.17 - d_d :: "[real, real]=> real"
29.18 - sin, cos :: "real => real"
29.19 -(*
29.20 - log, ln :: "real => real"
29.21 - nlog :: "[real, real] => real"
29.22 - exp :: "real => real" ("E'_ ^^^ _" 80)
29.23 -*)
29.24 - (*descriptions in the related problems*)
29.25 - derivativeEq :: bool => una
29.26 -
29.27 - (*predicates*)
29.28 - primed :: "'a => 'a" (*"primed A" -> "A'"*)
29.29 -
29.30 - (*the CAS-commands, eg. "Diff (2*x^^^3, x)",
29.31 - "Differentiate (A = s * (a - s), s)"*)
29.32 - Diff :: "[real * real] => real"
29.33 - Differentiate :: "[bool * real] => bool"
29.34 -
29.35 - (*subproblem and script-name*)
29.36 - differentiate :: "[ID * (ID list) * ID, real,real] => real"
29.37 - ("(differentiate (_)/ (_ _ ))" 9)
29.38 - DiffScr :: "[real,real, real] => real"
29.39 - ("((Script DiffScr (_ _ =))// (_))" 9)
29.40 - DiffEqScr :: "[bool,real, bool] => bool"
29.41 - ("((Script DiffEqScr (_ _ =))// (_))" 9)
29.42 -
29.43 -
29.44 -rules (*stated as axioms, todo: prove as theorems
29.45 - 'bdv' is a constant on the meta-level *)
29.46 - diff_const "[| Not (bdv occurs_in a) |] ==> d_d bdv a = 0"
29.47 - diff_var "d_d bdv bdv = 1"
29.48 - diff_prod_const"[| Not (bdv occurs_in u) |] ==> \
29.49 - \d_d bdv (u * v) = u * d_d bdv v"
29.50 -
29.51 - diff_sum "d_d bdv (u + v) = d_d bdv u + d_d bdv v"
29.52 - diff_dif "d_d bdv (u - v) = d_d bdv u - d_d bdv v"
29.53 - diff_prod "d_d bdv (u * v) = d_d bdv u * v + u * d_d bdv v"
29.54 - diff_quot "Not (v = 0) ==> (d_d bdv (u / v) = \
29.55 - \(d_d bdv u * v - u * d_d bdv v) / v ^^^ 2)"
29.56 -
29.57 - diff_sin "d_d bdv (sin bdv) = cos bdv"
29.58 - diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u"
29.59 - diff_cos "d_d bdv (cos bdv) = - sin bdv"
29.60 - diff_cos_chain "d_d bdv (cos u) = - sin u * d_d bdv u"
29.61 - diff_pow "d_d bdv (bdv ^^^ n) = n * (bdv ^^^ (n - 1))"
29.62 - diff_pow_chain "d_d bdv (u ^^^ n) = n * (u ^^^ (n - 1)) * d_d bdv u"
29.63 - diff_ln "d_d bdv (ln bdv) = 1 / bdv"
29.64 - diff_ln_chain "d_d bdv (ln u) = d_d bdv u / u"
29.65 - diff_exp "d_d bdv (exp bdv) = exp bdv"
29.66 - diff_exp_chain "d_d bdv (exp u) = exp u * d_d x u"
29.67 -(*
29.68 - diff_sqrt "d_d bdv (sqrt bdv) = 1 / (2 * sqrt bdv)"
29.69 - diff_sqrt_chain"d_d bdv (sqrt u) = d_d bdv u / (2 * sqrt u)"
29.70 -*)
29.71 - (*...*)
29.72 -
29.73 - frac_conv "[| bdv occurs_in b; 0 < n |] ==> \
29.74 - \ a / (b ^^^ n) = a * b ^^^ (-n)"
29.75 - frac_sym_conv "n < 0 ==> a * b ^^^ n = a / b ^^^ (-n)"
29.76 -
29.77 - sqrt_conv_bdv "sqrt bdv = bdv ^^^ (1 / 2)"
29.78 - sqrt_conv_bdv_n "sqrt (bdv ^^^ n) = bdv ^^^ (n / 2)"
29.79 - sqrt_conv "bdv occurs_in u ==> sqrt u = u ^^^ (1 / 2)"
29.80 - sqrt_sym_conv "u ^^^ (a / 2) = sqrt (u ^^^ a)"
29.81 -
29.82 - root_conv "bdv occurs_in u ==> nroot n u = u ^^^ (1 / n)"
29.83 - root_sym_conv "u ^^^ (a / b) = nroot b (u ^^^ a)"
29.84 -
29.85 - realpow_pow_bdv "(bdv ^^^ b) ^^^ c = bdv ^^^ (b * c)"
29.86 -
29.87 -end
29.88 -
29.89 -(* a variant of the derivatives defintion:
29.90 -
29.91 - d_d :: "(real => real) => (real => real)"
29.92 -
29.93 - advantages:
29.94 -(1) no variable 'bdv' on the meta-level required
29.95 -(2) chain_rule "d_d (%x. (u (v x))) = (%x. (d_d u)) (v x) * d_d v"
29.96 -(3) and no specialized chain-rules required like
29.97 - diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u"
29.98 -
29.99 - disadvantage: d_d (%x. 1 + x^2) = ... differs from high-school notation
29.100 -*)
30.1 --- a/src/Tools/isac/IsacKnowledge/DiffApp-oldpbl.sml Wed Aug 25 15:15:01 2010 +0200
30.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
30.3 @@ -1,369 +0,0 @@
30.4 -(*8.01: aufgehoben wegen alter preconds, postconds*)
30.5 -
30.6 -(* rectangle with maximal area, inscribed in a circle of fixed radius
30.7 -
30.8 -problem-types and methods solving the respective problem-type
30.9 -
30.10 -(1) names of the problem-types and methods and their hierarchy
30.11 - as subproblems.
30.12 - names of problem-types are string lists (diss 5.3.), not shown
30.13 - here with exception of ["equation","univariate"] in order to
30.14 - indicate, that this particular problem needs refinement to a
30.15 - more specific type of equation solvable by tan-square, etc.
30.16 -
30.17 -problem-types methods
30.18 -------------------------------- ----------------------
30.19 -maximum maximum-by-differentiation
30.20 - maximum-by-experimentation
30.21 - make-fun make-explicit-and-substitute
30.22 - introduce-a-new-variable
30.23 - max-of-fun-on-interval max-of-fun-on-interval
30.24 - derivative differentiate
30.25 - ["equation","univariate"] tan-square
30.26 -
30.27 - find-values find-values
30.28 -
30.29 -(2) specification of the problem-types
30.30 -*)
30.31 -
30.32 -(* maximum *)
30.33 -(* ------- *)
30.34 -(* problem-type *)
30.35 -{given = ["fixed_values (cs::bool list)"],
30.36 - where_= ["foldl (op &) True (map is_equality cs)",
30.37 - "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"],
30.38 - find=["maximum m","values_for (ms::real list)"],
30.39 - with_=["Ex_frees ((foldl (op &) True (r#RS)) & \
30.40 - \ (ALL m'. (subst (m,m') (foldl (op &) True (r#RS)) \
30.41 - \ --> m' <= m)))"],
30.42 - relate=["max_relation r","additional_relations RS"]};
30.43 -(* ^^^ is exponenation *)
30.44 -
30.45 -(* the functions Ex_frees, Rhs provide for the instantiation below *)
30.46 -
30.47 -(* (1) instantiation of maximum, + variant in "values_for" *)
30.48 -{given = ["fixed_values (R = #7)"],
30.49 - where_= ["is_equality (R = #7)",
30.50 - "Not (R <= #0)"],
30.51 - find =["maximum A","values_for [a,b]"],
30.52 - with_ =["EX A. A = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \
30.53 - \ (ALL A'. A' = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \
30.54 - \ --> A' <= A)))"],
30.55 - relate=["max_relation (A = a*b)",
30.56 - "additional_relations [(a//#2)^^^#2 +(b//#2)^^^#2 =R^^^#2]"]};
30.57 -(* R,a,b are bound by given, find *)
30.58 -
30.59 -(* (2) instantiation of maximum *)
30.60 -{given = ["fixed_values (R = #7)"],
30.61 - where_= ["is_equality (R = #7)",
30.62 - "Not (R <= #0)"],
30.63 - find =["maximum A","values_for [A]"],
30.64 - with_ =["EX a b alpha. A = a*b & \
30.65 - \ a = #2*R*sin alpha & b =#2*R*cos alpha &\
30.66 - \ (ALL A'. A' = a*b & a = #2*R*sin alpha & b =#2*R*cos alpha \
30.67 - \ --> A' <= A)))"],
30.68 - relate=["max_relation (A = a*b)",
30.69 - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]};
30.70 -(* R,A are bound by given, find *)
30.71 -
30.72 -
30.73 -(* make-fun *)
30.74 -(* -------- *)
30.75 -(* problem-type *)
30.76 -{given = ["equality (lhs = rhs)","bound_variable v","equalities es"],
30.77 - where_= [],
30.78 - find = ["function_term lhs_"],
30.79 - with_ = [(*???*)],
30.80 - relate= [(*???*)]};
30.81 -(*the _ in lhs is used to transfer the lhs-identifier of equality*)
30.82 -
30.83 -(* (1) instantiation for make-explicit-and-substitute *)
30.84 -{given = ["equality A = a * b","bound_variable a",
30.85 - "equalities [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"],
30.86 - where_= [],
30.87 - find = ["function_term A_"(*=(a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))*)],
30.88 - with_ = [],
30.89 - relate= []};
30.90 -
30.91 -(* (2) instantiation for introduce-a-new-variable *)
30.92 -{given = ["equality A = a * b","bound_variable alpha",
30.93 - "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
30.94 - where_= [],
30.95 - find = ["function_term A_"(*=(#2*R*sin alpha *#2*R*cos alpha)*)],
30.96 - with_ = [],
30.97 - relate= []};
30.98 -
30.99 -
30.100 -(* max-of-fun-on-interval *)
30.101 -(* ---------------------- *)
30.102 -(* problem-type *)
30.103 -{given = ["function_term t","bound_variable v",
30.104 - "domain {x::real. lower_bound <= x & x <= upper_bound}"],
30.105 - where_= [],
30.106 - find = ["maximums ms"],
30.107 - with_ = ["ALL m. m : ms --> \
30.108 - \ (ALL x::real. lower_bound <= x & x <= upper_bound \
30.109 - \ --> (%v. t) x <= m)"],
30.110 - relate= []}: string ppc;
30.111 -(* ':' is 'element', '::' is a type constraint *)
30.112 -
30.113 -(* (1) variant of instantiation *)
30.114 -{given = ["function_term (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))",
30.115 - "bound_variable a",
30.116 - "domain {x::real. #0 <= x & x <= #2*R}"],
30.117 - where_= [],
30.118 - find = ["maximums AM"],
30.119 - with_ = ["ALL am. am : AM --> \
30.120 - \ (ALL x::real. #0 <= x & x <= #2*R \
30.121 - \ --> (%a. (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))) x <= am)"],
30.122 - relate= []};
30.123 -
30.124 -(* (2) variant of instantiation *)
30.125 -{given = ["function_term (#2*R*sin alpha * #2*R*cos alpha)",
30.126 - "bound_variable alpha",
30.127 - "domain {x::real. #0 <= x & x <= pi//#2}"],
30.128 - where_= [],
30.129 - find = ["maximums AM"],
30.130 - with_ = ["ALL am. am : AM --> \
30.131 - \ (ALL x::real. #0 <= x & x <= pi//#2 \
30.132 - \ --> (%alpha. (#2*R*sin alpha * #2*R*cos alpha)) x <= am)"],
30.133 - relate= []};
30.134 -
30.135 -
30.136 -(* derivative *)
30.137 -(* ---------- *)
30.138 -(* problem-type *)
30.139 -{given = ["function_term t","bound_variable bdv"],
30.140 - where_= [],
30.141 - find = ["derivative t'"],
30.142 - with_ = ["t' is_derivative_of (%bdv. t)"],
30.143 - relate= []};
30.144 -(*the ' in t' is used to transfer the identifier from function_term*)
30.145 -
30.146 -
30.147 -(* ["equation","univariate"] *)
30.148 -(* ------------------------- *)
30.149 -(* problem-type *)
30.150 -{given = ["equality (lhs = rhs)",
30.151 - "bound_variable v","error_bound eps"],
30.152 - where_= [],
30.153 - find = ["solutions S"],
30.154 - with_ = ["ALL s. s : S --> || (%v. lhs) s - (%v. rhs) s || <= eps"],
30.155 - relate= []};
30.156 -
30.157 -
30.158 -(* find-values *)
30.159 -(* ----------- *)
30.160 -(* problem-type *)
30.161 -{given = ["max_relation r","additional_relations RS"],
30.162 - where_= [],
30.163 - find = ["values_for VS"],
30.164 - with_ = [(*???*)],
30.165 - relate= []};
30.166 -
30.167 -(* (1) variant of instantiation *)
30.168 -{given = ["max_relation (A = a*b)",
30.169 - "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]"],
30.170 - where_= [],
30.171 - find = ["values_for [a,b]"],
30.172 - with_ = [],
30.173 - relate= []};
30.174 -
30.175 -(* (2) variant of instantiation *)
30.176 -{given = ["max_relation (A = a*b)",],
30.177 - where_= [],
30.178 - find = ["values_for [A]",
30.179 - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
30.180 - with_ = [],
30.181 - relate= []};
30.182 -
30.183 -(*
30.184 -(3) data-transfer between the the hidden formalization,
30.185 - the root-problem and the sub-problems;
30.186 -
30.187 -maximum -> #given.make-fun
30.188 --------------------
30.189 -maximum.#relate "max_relation r" -> "equality (lhs = rhs)"
30.190 -formalization "bound_variable v" -> "bound_variable v"
30.191 -maximum.#relate "additional_relations RS"-> "equalities es"
30.192 -
30.193 -
30.194 -maximum + make-fun -> #given.max-of-fun-on-interval
30.195 ---------------------------------------------
30.196 -make-fun.#find "function_term lhs_" -> "function_term t"
30.197 -make-fun.#given "bound_variable v" -> "bound_variable v"
30.198 -formalization -> "domain {x::real. ...}"
30.199 -
30.200 -
30.201 -max-of-fun-on-interval -> #given.derivative
30.202 -------------------------------------
30.203 -make-fun.#find "function_term lhs_" -> "function_term t"
30.204 -make-fun.#given "bound_variable v" -> "bound_variable bdv"
30.205 -
30.206 -
30.207 -max-of-fun-on-interval + derivative ->
30.208 - #given.["equation","univariate"]
30.209 -----------------------------------------------------------------
30.210 -derivative.#find "derivative t'" -> "equality (lhs = rhs)"
30.211 - (* t'= #0 *)
30.212 -make-fun.#given "bound_variable v" -> "bound_variable v"
30.213 -formalization -> "error_bound eps"
30.214 -
30.215 -
30.216 -maximum + make-fun + max-of-fun-on-interval -> #given.find-values
30.217 -----------------------------------------------------------
30.218 -maximum.#relate "max_relation r" -> "max_relation r"
30.219 -maximum.#relate "additional_relations RS"-> "additional_relations RS"
30.220 -*)
30.221 -
30.222 -
30.223 -
30.224 -
30.225 -(* vvv--- geht nicht wegen fun-types
30.226 -parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')";
30.227 -parse thy "if maxmin = is_max then (m' <= m) else (m <= m')";
30.228 -parse thy "if a=b then a else b";
30.229 -parse thy "maxmin = is_max";
30.230 -parse thy "maxmin =!= is_max";
30.231 - ^^^--- geht nicht wegen fun-types *)
30.232 -
30.233 -"pbltyp --- maximum ---";
30.234 -val pbltyp = {given=["fixed_values (cs::bool list)"],
30.235 - where_=["foldl (op &) True (map is_equality cs)",
30.236 - "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"],
30.237 - find=["maximum m","values_for (ms::real list)"],
30.238 - with_=["Ex_frees ((foldl (op &) True (r#rs)) & \
30.239 - \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \
30.240 - \ --> m' <= m)))"],
30.241 - relate=["max_relation r","additional_relations rs"]}:string ppc;
30.242 -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
30.243 -"coil";
30.244 -val org = ["fixed_values [R=(R::real)]",
30.245 - "bound_variable a", "bound_variable b", "bound_variable alpha",
30.246 - "domain {x::real. #0 <= x & x <= #2*R}",
30.247 - "domain {x::real. #0 <= x & x <= #2*R}",
30.248 - "domain {x::real. #0 <= x & x <= pi}",
30.249 - "maximum A",
30.250 - "max_relation A=#2*a*b - a^^^#2",
30.251 - "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
30.252 - "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
30.253 - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"];
30.254 -val chkorg = map (the o (parse thy)) org;
30.255 -val pbl = {given=["fixed_values [R=(R::real)]"],where_=[],
30.256 - find=["maximum A","values_for [a,b]"],
30.257 - with_=["EX alpha. A=#2*a*b - a^^^#2 & \
30.258 - \ a=#2*R*sin alpha & b=#2*R*cos alpha & \
30.259 - \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha & b=#2*R*cos alpha \
30.260 - \ --> A' <= A)"],
30.261 - relate=["max_relation (A=#2*a*b - a^^^#2)",
30.262 - "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]
30.263 - }: string ppc;
30.264 -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
30.265 -
30.266 -"met --- maximum_by_differentiation ---";
30.267 -val met = {given=["fixed_values (cs::bool list)","bound_variable v",
30.268 - "domain {x::real. lower_bound <= x & x <= upper_bound}",
30.269 - "approximation apx"],
30.270 - where_=[],
30.271 - find=["maximum m","values_for (ms::real list)",
30.272 - "function_term t","max_argument mx"],
30.273 - with_=["Ex_frees ((foldl (op &) True (rs::bool list)) & \
30.274 - \ (ALL m'. (subst (m,m') (foldl (op &) True rs) \
30.275 - \ --> m' <= m))) & \
30.276 - \m = (%v. t) mx & \
30.277 - \( ALL x. lower_bound <= x & x <= upper_bound \
30.278 - \ --> (%v. t) x <= m)"],
30.279 - relate=["rs::bool list"]}: string ppc;
30.280 -val chkpbl = ((map (the o (parse thy))) o ppc2list) met;
30.281 -
30.282 -
30.283 -"pbltyp --- make_fun ---";
30.284 -(* subproblem [(hd #relate root, equality),
30.285 - (bound_variable formalization, bound_variable),
30.286 - (tl #relate root, equalities)] *)
30.287 -val pbltyp = {given=["equality e","bound_variable v", "equalities es"],
30.288 - where_=[],
30.289 - find=["function_term t"],with_=[(*???*)],
30.290 - relate=[(*???*)]}: string ppc;
30.291 -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
30.292 -"coil";
30.293 -val pbl = {given=["equality (A=#2*a*b - a^^^#2)","bound_variable alpha",
30.294 - "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
30.295 - where_=[],
30.296 - find=["function_term t"],
30.297 - with_=[],relate=[]}: string ppc;
30.298 -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
30.299 -
30.300 -"met --- make_explicit_and_substitute ---";
30.301 -val met = {given=["equality e","bound_variable v", "equalities es"],
30.302 - where_=[],
30.303 - find=["function_term t"],with_=[(*???*)],
30.304 - relate=[(*???*)]}: string ppc;
30.305 -val chkmet = ((map (the o (parse thy))) o ppc2list) met;
30.306 -"met --- introduce_a_new_variable ---";
30.307 -val met = {given=["equality e","bound_variable v", "substitutions es"],
30.308 - where_=[],
30.309 - find=["function_term t"],with_=[(*???*)],
30.310 - relate=[(*???*)]}: string ppc;
30.311 -val chkmet = ((map (the o (parse thy))) o ppc2list) met;
30.312 -
30.313 -
30.314 -"pbltyp --- max_of_fun_on_interval ---";
30.315 -val pbltyp = {given=["function_term t","bound_variable v",
30.316 - "domain {x::real. lower_bound <= x & x <= upper_bound}"],
30.317 - where_=[],
30.318 - find=["maximums ms"],
30.319 - with_=["ALL m. m : ms --> \
30.320 - \ (ALL x::real. lower_bound <= x & x <= upper_bound \
30.321 - \ --> (%v. t) x <= m)"],
30.322 - relate=[]}: string ppc;
30.323 -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
30.324 -"coil";
30.325 -val pbl = {given=["function_term #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \
30.326 - \ (#2*R*sin alpha)^^^#2","bound_variable alpha",
30.327 - "domain {x::real. #0 <= x & x <= pi}"],where_=[],
30.328 - find=["maximums [#1234]"],with_=[],relate=[]}: string ppc;
30.329 -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
30.330 -
30.331 -
30.332 -(* pbltyp --- max_of_fun --- *)
30.333 -(*
30.334 -{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc;
30.335 -val (SOME ct) = parse thy ;
30.336 -atomty thy (term_of ct);
30.337 -*)
30.338 -
30.339 -
30.340 -
30.341 -
30.342 -
30.343 -
30.344 -
30.345 -
30.346 -(* --- 14.1.00 --- *)
30.347 -"p.114";
30.348 -val org = {given=["[u=(#12::real)]"],where_=[],
30.349 - find=["[a,(b::real)]"],with_=[],
30.350 - relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc;
30.351 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
30.352 -"p.116";
30.353 -val org = {given=["[c=#10, h=(#4::real)]"],where_=[],
30.354 - find=["[x,(y::real)]"],with_=[],
30.355 - relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc;
30.356 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
30.357 -"p.117";
30.358 -val org = {given=["[r=#5]"],where_=[],
30.359 - find=["[x,(y::real)]"],with_=[],
30.360 - relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc;
30.361 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
30.362 -"#241";
30.363 -val org = {given=["[s=(#10::real)]"],where_=[],
30.364 - find=["[p::real]"],with_=[],
30.365 - relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc;
30.366 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
30.367 -
30.368 -(*
30.369 -{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc;
30.370 -val (SOME ct) = parse thy ;
30.371 -atomty thy (term_of ct);
30.372 -*)
31.1 --- a/src/Tools/isac/IsacKnowledge/DiffApp-oldscr.sml Wed Aug 25 15:15:01 2010 +0200
31.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
31.3 @@ -1,96 +0,0 @@
31.4 -(*8.01: alte Scripts f"ur Extremwertaufgabe gesammelt*)
31.5 -
31.6 -(* Das erste Script aus dem Maximum-Beispiel.
31.7 - parse erzeugt aus dem string 's' den
31.8 - 'cterm 's' im Isabelle-Format (pretty-printing !)*)
31.9 -
31.10 -ML> ...
31.11 -ML> val c = (the o (parse thy)) s;
31.12 -val c =
31.13 - "Script1 Maximum_value fix_ m_ rs_ v_ itv_ err_ =
31.14 - let e_ = (hd o filter (Testvar m_)) rs_;
31.15 - t_ =
31.16 - if #1 < Length rs_
31.17 - then make_fun (R, [make, function], no_met) m_ v_ rs_
31.18 - else (Lhs o hd) rs_;
31.19 - mx_ =
31.20 - max_on_interval (R, [on_interval, max_of, function],
31.21 - maximum_on_interval) t_ v_ itv_
31.22 - in find_vals (R, [find_values, tool], find_values)
31.23 - mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm
31.24 -
31.25 -ML> set show_types;
31.26 -ML> c;
31.27 -val c =
31.28 - "Script1 Maximum_value fix_::bool list m_::real rs_::bool list v_::real itv_::real set err_::bool =
31.29 - let e_::bool = (hd o filter (Testvar m_)) rs_;
31.30 - t_::real =
31.31 - if (#1::real) < Length rs_
31.32 - then make_fun (R::ID, [make::ID, function::ID], no_met::ID) m_ v_ rs_
31.33 - else (Lhs o hd) rs_;
31.34 - mx_::real =
31.35 - max_on_interval (R, [on_interval::ID, max_of::ID, function],
31.36 - maximum_on_interval::ID) t_ v_ itv_
31.37 - in find_vals (R, [find_values::ID, tool::ID], find_values)
31.38 - mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm
31.39 -
31.40 -
31.41 -
31.42 -(* Die ersten 3 Scripts aus dem Maximum-Beispiel.
31.43 - parse erzeugt aus dem string 's' den
31.44 - 'cterm 's' im Isabelle-Format (pretty-printing !)*)
31.45 -
31.46 -ML> ...
31.47 -ML> val c = (the o (parse thy)) s;
31.48 -val c =
31.49 - "Script maximum =
31.50 - Input [Bool fix_, Real m_, BoolList rs_, Real v_, RealSet itv_, Bool err_]
31.51 - Local [Bool e_, Real t_, Real mx_, RealList vs_]
31.52 - Tacs [SEQU
31.53 - [let e_ = (hd o filter (Testvar m_)) rs_
31.54 - in if #1 < Length rs_
31.55 - then Subproblem Spec (R, [make, function], no_met)
31.56 - InOut [In m_, In v_, In rs_, Out t_]
31.57 - else t_ := (Lhs o hd) rs_ ;
31.58 - Subproblem Spec (R, [on_interval, max_of, function],
31.59 - maximum_on_interval)
31.60 - InOut [In t_, In v_, In itv_, In err_, Out mx_] ;
31.61 - Subproblem Spec (R, [find_values, tool], find_values)
31.62 - InOut [In mx_, In t_, In v_, In m_, In (dropWhile (op = e_) rs_),
31.63 - Out vs_]]]
31.64 - Return []" : cterm
31.65 -
31.66 -ML> ...
31.67 -ML> val c = (the o (parse thy)) s;
31.68 -val c =
31.69 - "Script make_fun_by_new_variable =
31.70 - Input [Real f_, Real v_, BoolList eqs_]
31.71 - Local [Bool h_, BoolList es_, RealList vs_, Real v1_, Real v2_, Bool e1,
31.72 - Bool e2_, BoolList s_1, BoolList s_2]
31.73 - Tacs [SEQU
31.74 - [let h_ = (hd o filter (Testvar m_)) eqs_; es_ = eqs_ -- [h_];
31.75 - vs_ = Var h_ -- [f_]; v1_ = Nth #1 vs_; v2_ = Nth #2 vs_;
31.76 - e1_ = (hd o filter (Testvar v1_)) es_;
31.77 - e2_ = (hd o filter (Testvar v2_)) es_
31.78 - in Subproblem Spec (R, [univar, equation], no_met)
31.79 - InOut [In e1_, In v1_, Out s_1] ;
31.80 - Subproblem Spec (R, [univar, equation], no_met)
31.81 - InOut [In e2_, In v2_, Out s_2]],
31.82 - Take (Bool h_) ;
31.83 - Substitute [(v_1, (Rhs o hd) s_1), (v_2, (Rhs o hd) s_2)]]
31.84 - Return [Currform]" : cterm
31.85 -
31.86 -ML> ...
31.87 -ML> val c = (the o (parse thy)) s;
31.88 -val c =
31.89 - "Script make_fun_explicit =
31.90 - Input [Real f_, Real v_, BoolList eqs_]
31.91 - Local [Bool h_, Bool eq_, RealList vs_, Real v1_, BoolList ss_]
31.92 - Tacs [SEQU
31.93 - [let h_ = (hd o filter (Testvar m_)) eqs_; eq_ = hd (eqs_ -- [h_]);
31.94 - vs_ = Var h_ -- [f_]; v1_ = hd (vs_ -- [v_])
31.95 - in Subproblem Spec (R, [univar, equation], no_met)
31.96 - InOut [In eq_, In v1_, Out ss_]],
31.97 - Take (Bool h_) ; Substitute [(v1_, (Rhs o hd) ss_)]]
31.98 - Return [Currform]" : cterm
31.99 -ML>
32.1 --- a/src/Tools/isac/IsacKnowledge/DiffApp-scrpbl.sml Wed Aug 25 15:15:01 2010 +0200
32.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
32.3 @@ -1,429 +0,0 @@
32.4 -(* use"test-coil-kernel.sml";
32.5 - W.N.22.11.99
32.6 -
32.7 -*)
32.8 -
32.9 -(* vvv--- geht nicht wegen fun-types
32.10 -parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')";
32.11 -parse thy "if maxmin = is_max then (m' <= m) else (m <= m')";
32.12 -parse thy "if a=b then a else b";
32.13 -parse thy "maxmin = is_max";
32.14 -parse thy "maxmin =!= is_max";
32.15 - ^^^--- geht nicht wegen fun-types *)
32.16 -
32.17 -"pbltyp --- maximum ---";
32.18 -val pbltyp = {given=["fixedValues (cs::bool list)"],
32.19 - where_=[(*"foldl (op &) True (map is_equality cs)",
32.20 - "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"*)],
32.21 - find=["maximum m","values_for (ms::real list)"],
32.22 - with_=[(*"Ex_frees ((foldl (op &) True (r#rs)) & \
32.23 - \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \
32.24 - \ --> m' <= m)))"*)],
32.25 - relate=["max_relation r","additionalRels rs"]}:string ppc;
32.26 -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
32.27 -"coil";
32.28 -val org = ["fixedValues [R=(R::real)]",
32.29 - "boundVariable a","boundVariable b","boundVariable alpha",
32.30 - "domain {x::real. #0 <= x & x <= #2*R}",
32.31 - "domain {x::real. #0 <= x & x <= #2*R}",
32.32 - "domain {x::real. #0 <= x & x <= pi}",
32.33 - "errorBound (eps = #1//#1000)",
32.34 - "maximum A",
32.35 - (*"max_relation A=#2*a*b - a^^^#2",*)
32.36 - "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
32.37 - "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
32.38 - "relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"];
32.39 -val chkorg = map (the o (parse thy)) org;
32.40 -val pbl = {given=["fixedValues [R=(R::real)]"],where_=[],
32.41 - find=["maximum A","values_for [a,b]"],
32.42 - with_=[(* incompat.w. parse, ok with parseold
32.43 - "EX alpha. A=#2*a*b - a^^^#2 & \
32.44 - \ a=#2*R*sin alpha & b=#2*R*cos alpha & \
32.45 - \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha \
32.46 - \ & b=#2*R*cos alpha \
32.47 - \ --> A' <= A)"*)],
32.48 - relate=["relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"]
32.49 - }: string ppc;
32.50 -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
32.51 -
32.52 -"met --- maximum_by_differentiation ---";
32.53 -val met = {given=["fixedValues (cs::bool list)","boundVariable v",
32.54 - "domain {x::real. lower_bound <= x & x<=upper_bound}",
32.55 - "errorBound epsilon"],
32.56 - where_=[],
32.57 - find=["maximum m","valuesFor (ms::bool list)",
32.58 - "function_term t","max_argument mx"],
32.59 - with_=[(* incompat.w. parse, ok with parseold
32.60 - "Ex_frees ((foldl (op &) True (mr#ars)) & \
32.61 - \ (ALL m'. (subst (m,m') (foldl (op &) True (mr#ars))\
32.62 - \ --> m' <= m))) & \
32.63 - \m = (%v. t) mx & \
32.64 - \( ALL x. lower_bound <= x & x <= upper_bound \
32.65 - \ --> (%v. t) x <= m)"*)],
32.66 - relate=["max_relation mr",
32.67 - "additionalRels ars"]}: string ppc;
32.68 -val chkpbl = ((map (the o (parse thy))) o ppc2list) met;
32.69 -
32.70 -"data --- maximum_by_differentiation ---";
32.71 -val met = {given=["fixedValues [R=(R::real)]","boundVariable alpha",
32.72 - "domain {x::real. #0 <= x & x <= pi//#2}",
32.73 - "errorBound (eps = #1//#1000)"],
32.74 - where_=[],
32.75 - find=["maximum A","valuesFor [a=Undef]",
32.76 - "function_term t","max_argument mx"],
32.77 - with_=[(* incompat.w. parse, ok with parseold
32.78 - "EX b alpha. A = #2*a*b - a^^^#2 & \
32.79 - \ a = #2*R*sin alpha & \
32.80 - \ b = #2*R*cos alpha & \
32.81 - \ (ALL A'. A'= #2*a*b - a^^^#2 & \
32.82 - \ a = #2*R*sin alpha & \
32.83 - \ b = #2*R*cos alpha --> A' <= A) & \
32.84 - \ A = (%alpha. t) mx & \
32.85 - \ (ALL x. #0 <= x & x <= pi --> \
32.86 - \ (%alpha. t) x <= A)"*)],
32.87 - relate=["max_relation mr",
32.88 - "additionalRels ars"]}: string ppc;
32.89 -val chkpbl = ((map (the o (parse thy))) o ppc2list) met;
32.90 -
32.91 -val (SOME ct) = parseold thy "EX b. (EX alpha. A = #2*a*b - a^^^#2)";
32.92 -
32.93 -"pbltyp --- make_fun ---";
32.94 -(* subproblem [(hd #relate root, equality),
32.95 - (boundVariable formalization, boundVariable),
32.96 - (tl #relate root, equalities)] *)
32.97 -val pbltyp = {given=["equality e","boundVariable v", "equalities es"],
32.98 - where_=[],
32.99 - find=["functionTerm t"],with_=[(*???*)],
32.100 - relate=[(*???*)]}: string ppc;
32.101 -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
32.102 -"coil";
32.103 -val pbl = {given=["equality (A=#2*a*b - a^^^#2)","boundVariable alpha",
32.104 - "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
32.105 - where_=[],
32.106 - find=["functionTerm t"],
32.107 - with_=[],relate=[]}: string ppc;
32.108 -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
32.109 -
32.110 -"met --- make_explicit_and_substitute ---";
32.111 -val met = {given=["equality e","boundVariable v", "equalities es"],
32.112 - where_=[],
32.113 - find=["functionTerm t"],with_=[(*???*)],
32.114 - relate=[(*???*)]}: string ppc;
32.115 -val chkmet = ((map (the o (parse thy))) o ppc2list) met;
32.116 -"met --- introduce_a_new_variable ---";
32.117 -val met = {given=["equality e","boundVariable v", "substitutions es"],
32.118 - where_=[],
32.119 - find=["functionTerm t"],with_=[(*???*)],
32.120 - relate=[(*???*)]}: string ppc;
32.121 -val chkmet = ((map (the o (parse thy))) o ppc2list) met;
32.122 -
32.123 -
32.124 -"pbltyp --- max_of_fun_on_interval ---";
32.125 -val pbltyp = {given=["functionTerm t","boundVariable v",
32.126 - "domain {x::real. lower_bound <= x & x <= upper_bound}"],
32.127 - where_=[],
32.128 - find=["maximums ms"],
32.129 - with_=[(* incompat.w. parse, ok with parseold
32.130 - "ALL m. m : ms --> \
32.131 - \ (ALL x::real. lower_bound <= x & x <= upper_bound \
32.132 - \ --> (%v. t) x <= m)"*)],
32.133 - relate=[]}: string ppc;
32.134 -val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
32.135 -"coil";
32.136 -val pbl = {given=["functionTerm (f = #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \
32.137 - \ (#2*R*sin alpha)^^^#2)","boundVariable alpha",
32.138 - "domain {x::real. #0 <= x & x <= pi}"],where_=[],
32.139 - find=["maximums [#1234]"],with_=[],relate=[]}: string ppc;
32.140 -val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
32.141 -
32.142 -
32.143 -(* pbltyp --- max_of_fun --- *)
32.144 -(*
32.145 -{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc;
32.146 -val (SOME ct) = parse thy ;
32.147 -atomty (term_of ct);
32.148 -*)
32.149 -
32.150 -
32.151 -(* --- 14.1.00 ev. nicht ganz up to date bzg. oberem --- *)
32.152 -"p.114";
32.153 -val org = {given=["[u=(#12::real)]"],where_=[],
32.154 - find=["[a,(b::real)]"],with_=[],
32.155 - relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc;
32.156 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
32.157 -"p.116";
32.158 -val org = {given=["[c=#10, h=(#4::real)]"],where_=[],
32.159 - find=["[x,(y::real)]"],with_=[],
32.160 - relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc;
32.161 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
32.162 -"p.117";
32.163 -val org = {given=["[r=#5]"],where_=[],
32.164 - find=["[x,(y::real)]"],with_=[],
32.165 - relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc;
32.166 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
32.167 -"#241";
32.168 -val org = {given=["[s=(#10::real)]"],where_=[],
32.169 - find=["[p::real]"],with_=[],
32.170 - relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc;
32.171 -val chkorg = ((map (the o (parse thy))) o ppc2list) org;
32.172 -
32.173 -
32.174 -
32.175 -(* -------------- coil-kernel -------------- vor 19.1.00 *)
32.176 -(* --- subproblem: make-function-by-subst ~~~~~~~~~~~ *)
32.177 -(* --- subproblem: max-of-function *)
32.178 -(* --- subproblem: derivative *)
32.179 -(* --- subproblem: tan-quadrat-equation *)
32.180 -"-------------- coil-kernel --------------";
32.181 -val origin = ["A=#2*a*b - a^^^#2",
32.182 - "a::real","b::real","{x. #0<x & x<R//#2}",
32.183 - "{(a//#2)^^^#2 + (b//#2)^^^#2 = (R//#2)^^^#2}",
32.184 - "alpha::real","{alpha::real. #0<alpha & alpha<pi//#2}",
32.185 - "{a//#2 = R*(sin alpha), b//#2 = R*(cos alpha)}",
32.186 - "{R::real}"];
32.187 -(* --- for a isa-users-mail --- FIXME
32.188 -Goal "{x. x < a} = ?z";
32.189 -{x::'a. x < a} = ?z
32.190 -Goal "{x. x < #3} = {a}";
32.191 -{x::'a. x < (#3::'a)} = {a}
32.192 -Goal "{x. #3 < x} = ?z";
32.193 -Collect (op < (#3::'a)) = ?z
32.194 ----------------------------- *)
32.195 -
32.196 -val formals = map (the o (parse thy)) origin;
32.197 -
32.198 -val given = ["formula_for_max (lhs=rhs)","boundVariable bdv",
32.199 - "interval {x. low < x & x < high}",
32.200 - "additional_conds ac","constants cs"];
32.201 -val where_ = ["lhs is_const","bdv is_const","low is_const","high is_const",
32.202 - "||| Vars equ ||| = ||| VarsSet ac ||| - ||| ac ||| + #1"];
32.203 -val find = ["f::real => real","maxs::real set"];
32.204 -val with_ = [(* incompat.w. parse, ok with parseold
32.205 - "maxs = {m. low < m & m < high & \
32.206 - \ (m is_local_max_of (%bdv. f))}"*)];
32.207 -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
32.208 -val givens = map (the o (parse thy)) given;
32.209 -
32.210 -"------- 1.1 -------";
32.211 -(* 5.3.00
32.212 -val formals = map (the o (parse thy)) ["A=#2*a*b - a^^^#2",
32.213 - "a::real","{x. #0<x & x<R//#2}",
32.214 - "{(a//#2)^^^#2 + (b//#2)^^^#2 = (R//#2)^^^#2}",
32.215 - "{R::real}"];
32.216 -val tag__forms = chktyps thy (formals, givens);
32.217 -map ((atomty) o term_of) tag__forms;
32.218 -
32.219 -val formals = map (the o (parse thy)) ["A=#2*a*b - a^^^#2",
32.220 - "alpha::real","{alpha. #0<alpha & alpha<pi//#2}",
32.221 - "{a//#2 = R*(sin alpha), b//#2 = R*(cos alpha)}",
32.222 - "{R::real}"];
32.223 -val tag__forms = chktyps thy (formals, givens);
32.224 -map ((atomty) o term_of) tag__forms;
32.225 -*)
32.226 -
32.227 -" --- subproblem: make-function-by-subst --- ";
32.228 -val origin = ["A=#2*a*b - a^^^#2",
32.229 - "{a//#2 = R*(sin alpha), b//#2 = R*(cos alpha)}",
32.230 - "{R::real}"];
32.231 -val formals = map (the o (parse thy)) origin;
32.232 -
32.233 -val given = ["equation (lhs=rhs)","substitutions ss",
32.234 - "constants cs"];
32.235 -val where_ = [];
32.236 -val find = ["t::real"];
32.237 -val with_ = ["||| Vars t ||| = #1"];
32.238 -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
32.239 -val givens = map (the o (parse thy)) given;
32.240 -(* 5.3.00
32.241 -val tag__forms = chktyps thy (formals, givens);
32.242 -map ((atomty) o term_of) tag__forms;
32.243 -*)
32.244 -" --- subproblem: max-of-function --- ";
32.245 -val origin = ["A = #2*(#2*R*(sin alpha))*(#2*R*(sin alpha)) - \
32.246 - \ (#2*R*(sin alpha))^^^#2",
32.247 - "{alpha. #0<alpha & alpha<pi//#2}",
32.248 - "{R::real}"];
32.249 -val formals = map (the o (parse thy)) origin;
32.250 -
32.251 -val given = ["equation (lhs=rhs)",
32.252 - "interval {x. low < x & x < high}",
32.253 - "constants cs"];
32.254 -val where_ = ["lhs is_const","low is_const","high is_const"];
32.255 -val find = ["t::real"];
32.256 -val with_ = ["||| Vars t ||| = #1"];
32.257 -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
32.258 -val givens = map (the o (parse thy)) given;
32.259 -(* 5.3.00
32.260 -val tag__forms = chktyps thy (formals, givens);
32.261 -map ((atomty) o term_of) tag__forms;
32.262 -*)
32.263 -" --- subproblem: derivative --- ";
32.264 -val origin = ["x^^^#3-y^^^#3+#-3*x+#12*y+#10","x::real"];
32.265 -val formals = map (the o (parse thy)) origin;
32.266 -
32.267 -val given = ["functionTerm t",
32.268 - "boundVariable bdv"];
32.269 -val where_ = ["bdv is_const"];
32.270 -val find = ["t'::real"];
32.271 -val with_ = ["t' is_derivative_of (%bdv. t)"];
32.272 -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
32.273 -val givens = map (the o (parse thy)) given;
32.274 -(*
32.275 -val tag__forms = chktyps thy (formals, givens);
32.276 -map ((atomty) o term_of) tag__forms;
32.277 -*)
32.278 -" --- subproblem: tan-quadrat-equation --- ";
32.279 -val origin = ["#8*R^^^#2*(cos alpha)^^^#2 + #-8*R^^^#2* \
32.280 - \ (cos alpha)*(sin alpha) + #8*R^^^#2*(sin alpha)^^^#2 = #0",
32.281 - "alpha::real","#1//#1000"];
32.282 -val formals = map (the o (parse thy)) origin;
32.283 -
32.284 -val given = ["equation (a*(cos bdv)^^^#2 + b*(cos bdv)*(sin bdv) + \
32.285 - \ c*(sin bdv) = #0)",
32.286 - "boundVariable bdv","errorBound epsilon"];
32.287 -val where_ = ["bdv is_const","epsilon is_const_expr"];
32.288 -val find = ["L::real set"];
32.289 -val with_ = ["L = {x. || (%bdv. a*(cos bdv)^^^#2 + b*(cos bdv)*(sin bdv) + \
32.290 - \ c*(sin bdv)) x || < epsilon}"];
32.291 -(* 5.3.00
32.292 -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
32.293 -val givens = map (the o (parse thy)) given;
32.294 -val tag__forms = chktyps thy (formals, givens);
32.295 -map ((atomty) o term_of) tag__forms;
32.296 -*)
32.297 -(* use"test-coil-kernel.sml";
32.298 - *)
32.299 -
32.300 -
32.301 -" #################################################### ";
32.302 -" test specify ";
32.303 -" #################################################### ";
32.304 -
32.305 -
32.306 -val cts =
32.307 -["fixedValues [R=(R::real)]",
32.308 - "boundVariable a", "boundVariable b",
32.309 - "boundVariable alpha",
32.310 - "domain {x::real. #0 <= x & x <= #2*R}",
32.311 - "domain {x::real. #0 <= x & x <= #2*R}",
32.312 - "domain {x::real. #0 <= x & x <= pi//#2}",
32.313 - "errorBound (eps = #1//#1000)",
32.314 - "maximum A","valuesFor [a=Undef]",
32.315 - (*"functionTerm t","max_argument mx",
32.316 - "max_relation (A=#2*a*b - a^^^#2)", *)
32.317 - "additionalRels [A=#2*a*b - a^^^#2,(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
32.318 - "additionalRels [A=#2*a*b - a^^^#2,(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
32.319 - "additionalRels [A=#2*a*b - a^^^#2,a=#2*R*sin alpha, b=#2*R*cos alpha]"];
32.320 -val (dI',pI',mI')=
32.321 - ("DiffAppl.thy",["Script.thy","maximum_of","function"],e_metID);
32.322 -val c = []:cid;
32.323 -
32.324 -(*
32.325 -val pbl = {given=["fixedValues [R=(R::real)]","boundVariable alpha",
32.326 - "domain {x::real. #0 <= x & x <= pi//#2}",
32.327 - "errorBound (eps = #1//#1000)"],
32.328 - where_=[],
32.329 - find=["maximum A","valuesFor [a=Undef]"(*,
32.330 - "functionTerm t","max_argument mx"*)],
32.331 - with_=[],
32.332 - relate=["max_relation (A=#2*a*b - a^^^#2)",
32.333 - "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
32.334 - "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
32.335 - "additionalRels [a=#2*R*sin alpha, b=#2*R*cos alpha]"]
32.336 - }: string ppc;
32.337 -*)
32.338 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
32.339 - specify (Init_Proof (cts,(dI',pI',mI'))) e_pos' [] EmptyPtree;
32.340 -
32.341 -val ct = "fixedValues [R=(R::real)]";
32.342 -(*l(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify(Add_Given ct) p c pt*)
32.343 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.344 -
32.345 -val ct = "boundVariable a";
32.346 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.347 -val ct = "boundVariable alpha";
32.348 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.349 -
32.350 -val ct = "domain {x::real. #0 <= x & x <= pi//#2}";
32.351 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.352 -
32.353 -val ct = "errorBound (eps = (#1::real) // #1000)";
32.354 -val ct = "maximum A";
32.355 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.356 -
32.357 -val ct = "valuesFor [a=Undef]";
32.358 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.359 -
32.360 -val ct = "max_relation ()";
32.361 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.362 -
32.363 -val ct = "relations [A=#2*a*b - a^^^#2,(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]";
32.364 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.365 -
32.366 -(* ... nxt = Specify_Domain ...
32.367 -val ct = "additionalRels [b=#2*R*cos alpha]";
32.368 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
32.369 - specify(Add_Relation ct) p c pt;
32.370 -(*
32.371 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.372 -*)
32.373 -val ct = "additionalRels [a=#2*R*sin alpha]";
32.374 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
32.375 - specify(Add_Relation ct) p c pt;
32.376 -(*
32.377 -val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.378 -*)
32.379 -*)
32.380 -(* --- tricky case (termlist interleaving variants):
32.381 -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
32.382 - specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree;
32.383 -
32.384 -> val ct = "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2, b=#2*R*cos alpha]";
32.385 -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.386 -*)
32.387 -
32.388 -(* --- incomplete input ---
32.389 -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
32.390 - specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree;
32.391 -
32.392 -> val ct = "[R=(R::real)]";
32.393 -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.394 -
32.395 -> val ct = "R=(R::real)";
32.396 -> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
32.397 -
32.398 -> val ct = "(R::real)";
32.399 -> specify nxt p c pt;
32.400 -*)
32.401 -
32.402 -
32.403 -" #################################################### ";
32.404 -" test do_ specify ";
32.405 -" #################################################### ";
32.406 -
32.407 -
32.408 -val cts = ["fixedValues [R=(R::real)]",
32.409 - "boundVariable a", "boundVariable b",
32.410 - "boundVariable alpha",
32.411 - "domain {x::real. #0 <= x & x <= #2*R}",
32.412 - "domain {x::real. #0 <= x & x <= #2*R}",
32.413 - "domain {x::real. #0 <= x & x <= pi//#2}",
32.414 - "errorBound (eps=#1//#1000)",
32.415 - "maximum A","valuesFor [a=Undef]",
32.416 - (*"functionTerm t","max_argument mx", *)
32.417 - "max_relation (A=#2*a*b - a^^^#2)",
32.418 - "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
32.419 - "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
32.420 - "additionalRels [a=#2*R*sin alpha, b=#2*R*cos alpha]"];
32.421 -val (dI',pI',mI')=
32.422 - ("DiffAppl.thy",["DiffAppl.thy","test_maximum"],e_metID);
32.423 -val p = e_pos'; val c = [];
32.424 -
32.425 -val (mI,m) = ("Init_Proof",Init_Proof (cts, (dI',pI',mI')));
32.426 -val (pst as (sc,pt,cl):pstate) = (EmptyScr, e_ptree, []);
32.427 -val (p,_,f,nxt,_,(_,pt,_)) = do_ (mI,m) p c pst;
32.428 -(*val nxt = ("Add_Given",Add_Given "fixedValues [R = R]")*)
32.429 -
32.430 -val (p,_,Form' (PpcKF (_,_,ppc)),nxt,_,(_,pt,_)) =
32.431 - do_ nxt p c (EmptyScr,pt,[]);
32.432 -(*val nxt = ("Add_Given",Add_Given "boundVariable a") *)
33.1 --- a/src/Tools/isac/IsacKnowledge/DiffApp.ML Wed Aug 25 15:15:01 2010 +0200
33.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
33.3 @@ -1,221 +0,0 @@
33.4 -(* tools for applications of differetiation
33.5 - use"DiffApp.ML";
33.6 - use"IsacKnowledge/DiffApp.ML";
33.7 - use"../IsacKnowledge/DiffApp.ML";
33.8 -
33.9 -
33.10 -WN.6.5.03: old decisions in this file partially are being changed
33.11 - in a quick-and-dirty way to make scripts run: Maximum_value,
33.12 - Make_fun_by_new_variable, Make_fun_by_explicit.
33.13 -found to be reconsidered:
33.14 -- descriptions (Descript.thy)
33.15 -- penv: really need term list; or just rerun the whole example with num/var
33.16 -- mk_arg, itms2args ... env in script different from penv ?
33.17 -- L = SubProblem eq ... show some vars on the worksheet ? (other means for
33.18 - referencing are labels (no on worksheet))
33.19 -
33.20 -WN.6.5.03 quick-and-dirty: mk_arg, itms2args just make most convenient env
33.21 - from penv as is.
33.22 - *)
33.23 -
33.24 -
33.25 -(** interface isabelle -- isac **)
33.26 -
33.27 -theory' := overwritel (!theory', [("DiffApp.thy",DiffApp.thy)]);
33.28 -
33.29 -val eval_rls = prep_rls(
33.30 - Rls {id="eval_rls",preconds = [], rew_ord = ("termlessI",termlessI),
33.31 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
33.32 - rules = [Thm ("refl",num_str refl),
33.33 - Thm ("le_refl",num_str le_refl),
33.34 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
33.35 - Thm ("not_true",num_str not_true),
33.36 - Thm ("not_false",num_str not_false),
33.37 - Thm ("and_true",and_true),
33.38 - Thm ("and_false",and_false),
33.39 - Thm ("or_true",or_true),
33.40 - Thm ("or_false",or_false),
33.41 - Thm ("and_commute",num_str and_commute),
33.42 - Thm ("or_commute",num_str or_commute),
33.43 -
33.44 - Calc ("op <",eval_equ "#less_"),
33.45 - Calc ("op <=",eval_equ "#less_equal_"),
33.46 -
33.47 - Calc ("Atools.ident",eval_ident "#ident_"),
33.48 - Calc ("Atools.is'_const",eval_const "#is_const_"),
33.49 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
33.50 - Calc ("Tools.matches",eval_matches "")
33.51 - ],
33.52 - scr = Script ((term_of o the o (parse thy))
33.53 - "empty_script")
33.54 - }:rls);
33.55 -ruleset' := overwritelthy thy
33.56 - (!ruleset',
33.57 - [("eval_rls",Atools_erls)(*FIXXXME:del with rls.rls'*)
33.58 - ]);
33.59 -
33.60 -
33.61 -(** problem types **)
33.62 -
33.63 -store_pbt
33.64 - (prep_pbt DiffApp.thy "pbl_fun_max" [] e_pblID
33.65 - (["maximum_of","function"],
33.66 - [("#Given" ,["fixedValues fix_"]),
33.67 - ("#Find" ,["maximum m_","valuesFor vs_"]),
33.68 - ("#Relate",["relations rs_"])
33.69 - ],
33.70 - e_rls, NONE, []));
33.71 -
33.72 -store_pbt
33.73 - (prep_pbt DiffApp.thy "pbl_fun_make" [] e_pblID
33.74 - (["make","function"]:pblID,
33.75 - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
33.76 - ("#Find" ,["functionEq f_1_"])
33.77 - ],
33.78 - e_rls, NONE, []));
33.79 -store_pbt
33.80 - (prep_pbt DiffApp.thy "pbl_fun_max_expl" [] e_pblID
33.81 - (["by_explicit","make","function"]:pblID,
33.82 - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
33.83 - ("#Find" ,["functionEq f_1_"])
33.84 - ],
33.85 - e_rls, NONE, [["DiffApp","make_fun_by_explicit"]]));
33.86 -store_pbt
33.87 - (prep_pbt DiffApp.thy "pbl_fun_max_newvar" [] e_pblID
33.88 - (["by_new_variable","make","function"]:pblID,
33.89 - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
33.90 - (*WN.12.5.03: precond for distinction still missing*)
33.91 - ("#Find" ,["functionEq f_1_"])
33.92 - ],
33.93 - e_rls, NONE, [["DiffApp","make_fun_by_new_variable"]]));
33.94 -
33.95 -store_pbt
33.96 - (prep_pbt DiffApp.thy "pbl_fun_max_interv" [] e_pblID
33.97 - (["on_interval","maximum_of","function"]:pblID,
33.98 - [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"]),
33.99 - (*WN.12.5.03: precond for distinction still missing*)
33.100 - ("#Find" ,["maxArgument v_0_"])
33.101 - ],
33.102 - e_rls, NONE, []));
33.103 -
33.104 -store_pbt
33.105 - (prep_pbt DiffApp.thy "pbl_tool" [] e_pblID
33.106 - (["tool"]:pblID,
33.107 - [],
33.108 - e_rls, NONE, []));
33.109 -
33.110 -store_pbt
33.111 - (prep_pbt DiffApp.thy "pbl_tool_findvals" [] e_pblID
33.112 - (["find_values","tool"]:pblID,
33.113 - [("#Given" ,["maxArgument ma_","functionEq f_","boundVariable v_"]),
33.114 - ("#Find" ,["valuesFor vls_"]),
33.115 - ("#Relate",["additionalRels rs_"])
33.116 - ],
33.117 - e_rls, NONE, []));
33.118 -
33.119 -
33.120 -(** methods, scripts not yet implemented **)
33.121 -
33.122 -store_met
33.123 - (prep_met Diff.thy "met_diffapp" [] e_metID
33.124 - (["DiffApp"],
33.125 - [],
33.126 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
33.127 - crls = Atools_erls, nrls=norm_Rational
33.128 - (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
33.129 -store_met
33.130 - (prep_met DiffApp.thy "met_diffapp_max" [] e_metID
33.131 - (["DiffApp","max_by_calculus"]:metID,
33.132 - [("#Given" ,["fixedValues fix_","maximum m_","relations rs_",
33.133 - "boundVariable v_","interval itv_","errorBound err_"]),
33.134 - ("#Find" ,["valuesFor vs_"]),
33.135 - ("#Relate",[])
33.136 - ],
33.137 - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls,
33.138 - crls = eval_rls, nrls=norm_Rational
33.139 - (*, asm_rls=[],asm_thm=[]*)},
33.140 - "Script Maximum_value(fix_::bool list)(m_::real) (rs_::bool list)\
33.141 - \ (v_::real) (itv_::real set) (err_::bool) = \
33.142 - \ (let e_ = (hd o (filterVar m_)) rs_; \
33.143 - \ t_ = (if 1 < length_ rs_ \
33.144 - \ then (SubProblem (DiffApp_,[make,function],[no_met])\
33.145 - \ [real_ m_, real_ v_, bool_list_ rs_])\
33.146 - \ else (hd rs_)); \
33.147 - \ (mx_::real) = SubProblem(DiffApp_,[on_interval,maximum_of,function],\
33.148 - \ [DiffApp,max_on_interval_by_calculus])\
33.149 - \ [bool_ t_, real_ v_, real_set_ itv_]\
33.150 - \ in ((SubProblem (DiffApp_,[find_values,tool],[Isac,find_values]) \
33.151 - \ [real_ mx_, real_ (Rhs t_), real_ v_, real_ m_, \
33.152 - \ bool_list_ (dropWhile (ident e_) rs_)])::bool list))"
33.153 - ));
33.154 -store_met
33.155 - (prep_met DiffApp.thy "met_diffapp_funnew" [] e_metID
33.156 - (["DiffApp","make_fun_by_new_variable"]:metID,
33.157 - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
33.158 - ("#Find" ,["functionEq f_1_"])
33.159 - ],
33.160 - {rew_ord'="tless_true",rls'=eval_rls,srls=list_rls,prls=e_rls,
33.161 - calc=[], crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)},
33.162 - "Script Make_fun_by_new_variable (f_::real) (v_::real) \
33.163 - \ (eqs_::bool list) = \
33.164 - \(let h_ = (hd o (filterVar f_)) eqs_; \
33.165 - \ es_ = dropWhile (ident h_) eqs_; \
33.166 - \ vs_ = dropWhile (ident f_) (Vars h_); \
33.167 - \ v_1 = nth_ 1 vs_; \
33.168 - \ v_2 = nth_ 2 vs_; \
33.169 - \ e_1 = (hd o (filterVar v_1)) es_; \
33.170 - \ e_2 = (hd o (filterVar v_2)) es_; \
33.171 - \ (s_1::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\
33.172 - \ [bool_ e_1, real_ v_1]);\
33.173 - \ (s_2::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\
33.174 - \ [bool_ e_2, real_ v_2])\
33.175 - \in Substitute [(v_1 = (rhs o hd) s_1),(v_2 = (rhs o hd) s_2)] h_)"
33.176 -));
33.177 -store_met
33.178 -(prep_met DiffApp.thy "met_diffapp_funexp" [] e_metID
33.179 -(["DiffApp","make_fun_by_explicit"]:metID,
33.180 - [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
33.181 - ("#Find" ,["functionEq f_1_"])
33.182 - ],
33.183 - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls,
33.184 - crls = eval_rls, nrls=norm_Rational
33.185 - (*, asm_rls=[],asm_thm=[]*)},
33.186 - "Script Make_fun_by_explicit (f_::real) (v_::real) \
33.187 - \ (eqs_::bool list) = \
33.188 - \ (let h_ = (hd o (filterVar f_)) eqs_; \
33.189 - \ e_1 = hd (dropWhile (ident h_) eqs_); \
33.190 - \ vs_ = dropWhile (ident f_) (Vars h_); \
33.191 - \ v_1 = hd (dropWhile (ident v_) vs_); \
33.192 - \ (s_1::bool list)=(SubProblem(DiffApp_,[univariate,equation],[no_met])\
33.193 - \ [bool_ e_1, real_ v_1])\
33.194 - \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)"
33.195 - ));
33.196 -store_met
33.197 - (prep_met DiffApp.thy "met_diffapp_max_oninterval" [] e_metID
33.198 - (["DiffApp","max_on_interval_by_calculus"]:metID,
33.199 - [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"(*,
33.200 - "errorBound err_"*)]),
33.201 - ("#Find" ,["maxArgument v_0_"])
33.202 - ],
33.203 - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls,
33.204 - crls = eval_rls, nrls=norm_Rational
33.205 - (*, asm_rls=[],asm_thm=[]*)},
33.206 - "empty_script"
33.207 - ));
33.208 -store_met
33.209 - (prep_met DiffApp.thy "met_diffapp_findvals" [] e_metID
33.210 - (["DiffApp","find_values"]:metID,
33.211 - [],
33.212 - {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls,
33.213 - crls = eval_rls, nrls=norm_Rational(*,
33.214 - asm_rls=[],asm_thm=[]*)},
33.215 - "empty_script"));
33.216 -
33.217 -val list_rls = append_rls "list_rls" list_rls
33.218 - [Thm ("filterVar_Const", num_str filterVar_Const),
33.219 - Thm ("filterVar_Nil", num_str filterVar_Nil)
33.220 - ];
33.221 -ruleset' := overwritelthy thy (!ruleset',
33.222 - [("list_rls",list_rls)
33.223 - ]);
33.224 -
34.1 --- a/src/Tools/isac/IsacKnowledge/DiffApp.sml Wed Aug 25 15:15:01 2010 +0200
34.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
34.3 @@ -1,105 +0,0 @@
34.4 -(* = DiffAppl.ML
34.5 - +++ outcommented tests
34.6 -*)
34.7 -
34.8 -
34.9 -theory' := overwritel (!theory', [("DiffAppl.thy",DiffAppl.thy)]);
34.10 -
34.11 -(*
34.12 -> get_pbt ["DiffAppl.thy","maximum_of","function"];
34.13 -> get_met ("Script.thy","max_on_interval_by_calculus");
34.14 -> !pbltypes;
34.15 - *)
34.16 -pbltypes:= overwritel (!pbltypes,
34.17 -[
34.18 - prep_pbt DiffAppl.thy
34.19 - (["DiffAppl.thy","maximum_of","function"],
34.20 - [("#Given" ,"fixedValues fix_"),
34.21 - ("#Find" ,"maximum m_"),
34.22 - ("#Find" ,"valuesFor vs_"),
34.23 - ("#Relate","relations rs_") (*,
34.24 - ("#where" ,"foldl (op&) True (map (Not o ((op<=) #0) o Rhs) fix_)"),
34.25 - ("#with" ,"Ex_frees ((foldl (op &) True rs_) & \
34.26 - \ (ALL m'. (subst (m_,m') (foldl (op &) True rs_) \
34.27 - \ --> m' <= m_)))") *)
34.28 - ]),
34.29 -
34.30 - prep_pbt DiffAppl.thy
34.31 - (["DiffAppl.thy","make","function"]:pblID,
34.32 - [("#Given" ,"functionOf f_"),
34.33 - ("#Given" ,"boundVariable v_"),
34.34 - ("#Given" ,"equalities eqs_"),
34.35 - ("#Find" ,"functionTerm f_0_")
34.36 - ]),
34.37 -
34.38 - prep_pbt DiffAppl.thy
34.39 - (["DiffAppl.thy","on_interval","maximum_of","function"]:pblID,
34.40 - [("#Given" ,"functionTerm t_"),
34.41 - ("#Given" ,"boundVariable v_"),
34.42 - ("#Given" ,"interval itv_"),
34.43 - ("#Find" ,"maxArgument v_0_")
34.44 - ]),
34.45 -
34.46 - prep_pbt DiffAppl.thy
34.47 - (["DiffAppl.thy","find_values","tool"]:pblID,
34.48 - [("#Given" ,"maxArgument ma_"),
34.49 - ("#Given" ,"functionTerm f_"),
34.50 - ("#Given" ,"boundVariable v_"),
34.51 - ("#Find" ,"valuesFor vls_"),
34.52 - ("#Relate","additionalRels rs_")
34.53 - ])
34.54 -]);
34.55 -
34.56 -
34.57 -methods:= overwritel (!methods,
34.58 -[
34.59 - (("DiffAppl.thy","max_by_calculus"):metID,
34.60 - {ppc = prep_met DiffAppl.thy
34.61 - [("#Given" ,"fixedValues fix_"),
34.62 - ("#Given" ,"boundVariable v_"),
34.63 - ("#Given" ,"interval itv_"),
34.64 - ("#Given" ,"errorBound err_"),
34.65 - ("#Find" ,"maximum m_"),
34.66 - ("#Find" ,"valuesFor vs_"),
34.67 - ("#Relate","relations rs_")
34.68 - ],
34.69 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
34.70 - scr=EmptyScr} : met),
34.71 -
34.72 - (("DiffAppl.thy","make_fun_by_new_variable"):metID,
34.73 - {ppc = prep_met DiffAppl.thy
34.74 - [("#Given" ,"functionOf f_"),
34.75 - ("#Given" ,"boundVariable v_"),
34.76 - ("#Given" ,"equalities eqs_"),
34.77 - ("#Find" ,"functionTerm f_0_")
34.78 - ],
34.79 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
34.80 - scr=EmptyScr} : met),
34.81 -
34.82 - (("DiffAppl.thy","make_fun_by_explicit"):metID,
34.83 - {ppc = prep_met DiffAppl.thy
34.84 - [("#Given" ,"functionOf f_"),
34.85 - ("#Given" ,"boundVariable v_"),
34.86 - ("#Given" ,"equalities eqs_"),
34.87 - ("#Find" ,"functionTerm f_0_")
34.88 - ],
34.89 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
34.90 - scr=EmptyScr} : met),
34.91 -
34.92 - (("DiffAppl.thy","max_on_interval_by_calculus"):metID,
34.93 - {ppc = prep_met DiffAppl.thy
34.94 - [("#Given" ,"functionTerm t_"),
34.95 - ("#Given" ,"boundVariable v_"),
34.96 - ("#Given" ,"interval itv_"),
34.97 - ("#Given" ,"errorBound err_"),
34.98 - ("#Find" ,"maxArgument v_0_")
34.99 - ],
34.100 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
34.101 - scr=EmptyScr} : met),
34.102 -
34.103 - (("DiffAppl.thy","find_values"):metID,
34.104 - {ppc = prep_met DiffAppl.thy
34.105 - [],
34.106 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
34.107 - scr=EmptyScr} : met)
34.108 -]);
35.1 --- a/src/Tools/isac/IsacKnowledge/DiffApp.thy Wed Aug 25 15:15:01 2010 +0200
35.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
35.3 @@ -1,40 +0,0 @@
35.4 -(* application of differential calculus
35.5 - use_thy_only"../IsacKnowledge/DiffApp";
35.6 - use_thy_only"DiffApp";
35.7 -
35.8 -
35.9 -*)
35.10 -
35.11 -
35.12 -DiffApp = Diff +
35.13 -
35.14 -consts
35.15 -
35.16 - Maximum'_value
35.17 - :: "[bool list,real,bool list,real,real set,bool,\
35.18 - \ bool list] => bool list"
35.19 - ("((Script Maximum'_value (_ _ _ _ _ _ =))// (_))" 9)
35.20 -
35.21 - Make'_fun'_by'_new'_variable
35.22 - :: "[real,real,bool list, \
35.23 - \ bool] => bool"
35.24 - ("((Script Make'_fun'_by'_new'_variable (_ _ _ =))// \
35.25 - \(_))" 9)
35.26 - Make'_fun'_by'_explicit
35.27 - :: "[real,real,bool list, \
35.28 - \ bool] => bool"
35.29 - ("((Script Make'_fun'_by'_explicit (_ _ _ =))// \
35.30 - \(_))" 9)
35.31 -
35.32 - dummy :: real
35.33 -
35.34 -(*for script Maximum_value*)
35.35 - filterVar :: "[real, 'a list] => 'a list"
35.36 -
35.37 -(*primrec*)rules
35.38 - filterVar_Nil "filterVar v [] = []"
35.39 - filterVar_Const "filterVar v (x#xs) = \
35.40 - \(if (v mem (Vars x)) then x#(filterVar v xs) \
35.41 - \ else filterVar v xs) "
35.42 -
35.43 -end
35.44 \ No newline at end of file
36.1 --- a/src/Tools/isac/IsacKnowledge/EqSystem.ML Wed Aug 25 15:15:01 2010 +0200
36.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
36.3 @@ -1,673 +0,0 @@
36.4 -(* tools for systems of equations over the reals
36.5 - author: Walther Neuper 050905, 08:51
36.6 - (c) due to copyright terms
36.7 -
36.8 -use"IsacKnowledge/EqSystem.ML";
36.9 -use"EqSystem.ML";
36.10 -
36.11 -remove_thy"EqSystem";
36.12 -use_thy"IsacKnowledge/Isac";
36.13 -*)
36.14 -
36.15 -(** interface isabelle -- isac **)
36.16 -
36.17 -theory' := overwritel (!theory', [("EqSystem.thy",EqSystem.thy)]);
36.18 -
36.19 -(** eval functions **)
36.20 -
36.21 -(*certain variables of a given list occur _all_ in a term
36.22 - args: all: ..variables, which are under consideration (eg. the bound vars)
36.23 - vs: variables which must be in t,
36.24 - and none of the others in all must be in t
36.25 - t: the term under consideration
36.26 - *)
36.27 -fun occur_exactly_in vs all t =
36.28 - let fun occurs_in' a b = occurs_in b a
36.29 - in foldl and_ (true, map (occurs_in' t) vs)
36.30 - andalso not (foldl or_ (false, map (occurs_in' t) (all \\ vs)))
36.31 - end;
36.32 -
36.33 -(*("occur_exactly_in", ("EqSystem.occur'_exactly'_in",
36.34 - eval_occur_exactly_in "#eval_occur_exactly_in_"))*)
36.35 -fun eval_occur_exactly_in _ "EqSystem.occur'_exactly'_in"
36.36 - (p as (Const ("EqSystem.occur'_exactly'_in",_)
36.37 - $ vs $ all $ t)) _ =
36.38 - if occur_exactly_in (isalist2list vs) (isalist2list all) t
36.39 - then SOME ((term2str p) ^ " = True",
36.40 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
36.41 - else SOME ((term2str p) ^ " = False",
36.42 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
36.43 - | eval_occur_exactly_in _ _ _ _ = NONE;
36.44 -
36.45 -calclist':=
36.46 -overwritel (!calclist',
36.47 - [("occur_exactly_in",
36.48 - ("EqSystem.occur'_exactly'_in",
36.49 - eval_occur_exactly_in "#eval_occur_exactly_in_"))
36.50 - ]);
36.51 -
36.52 -
36.53 -(** rewrite order 'ord_simplify_System' **)
36.54 -
36.55 -(* order wrt. several linear (i.e. without exponents) variables "c","c_2",..
36.56 - which leaves the monomials containing c, c_2,... at the end of an Integral
36.57 - and puts the c, c_2,... rightmost within a monomial.
36.58 -
36.59 - WN050906 this is a quick and dirty adaption of ord_make_polynomial_in,
36.60 - which was most adequate, because it uses size_of_term*)
36.61 -(**)
36.62 -local (*. for simplify_System .*)
36.63 -(**)
36.64 -open Term; (* for type order = EQUAL | LESS | GREATER *)
36.65 -
36.66 -fun pr_ord EQUAL = "EQUAL"
36.67 - | pr_ord LESS = "LESS"
36.68 - | pr_ord GREATER = "GREATER";
36.69 -
36.70 -fun dest_hd' (Const (a, T)) = (((a, 0), T), 0)
36.71 - | dest_hd' (Free (ccc, T)) =
36.72 - (case explode ccc of
36.73 - "c"::[] => ((("|||||||||||||||||||||", 0), T), 1)(*greatest string WN*)
36.74 - | "c"::"_"::_ => ((("|||||||||||||||||||||", 0), T), 1)
36.75 - | _ => (((ccc, 0), T), 1))
36.76 - | dest_hd' (Var v) = (v, 2)
36.77 - | dest_hd' (Bound i) = ((("", i), dummyT), 3)
36.78 - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
36.79 -
36.80 -fun size_of_term' (Free (ccc, _)) =
36.81 - (case explode ccc of (*WN0510 hack for the bound variables*)
36.82 - "c"::[] => 1000
36.83 - | "c"::"_"::is => 1000 * ((str2int o implode) is)
36.84 - | _ => 1)
36.85 - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
36.86 - | size_of_term' (f$t) = size_of_term' f + size_of_term' t
36.87 - | size_of_term' _ = 1;
36.88 -
36.89 -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
36.90 - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
36.91 - | term_ord' pr thy (t, u) =
36.92 - (if pr then
36.93 - let
36.94 - val (f, ts) = strip_comb t and (g, us) = strip_comb u;
36.95 - val _=writeln("t= f@ts= \""^
36.96 - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
36.97 - (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\"");
36.98 - val _=writeln("u= g@us= \""^
36.99 - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
36.100 - (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\"");
36.101 - val _=writeln("size_of_term(t,u)= ("^
36.102 - (string_of_int(size_of_term' t))^", "^
36.103 - (string_of_int(size_of_term' u))^")");
36.104 - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
36.105 - val _=writeln("terms_ord(ts,us) = "^
36.106 - ((pr_ord o terms_ord str false)(ts,us)));
36.107 - val _=writeln("-------");
36.108 - in () end
36.109 - else ();
36.110 - case int_ord (size_of_term' t, size_of_term' u) of
36.111 - EQUAL =>
36.112 - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
36.113 - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
36.114 - | ord => ord)
36.115 - end
36.116 - | ord => ord)
36.117 -and hd_ord (f, g) = (* ~ term.ML *)
36.118 - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f,
36.119 - dest_hd' g)
36.120 -and terms_ord str pr (ts, us) =
36.121 - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
36.122 -(**)
36.123 -in
36.124 -(**)
36.125 -(*WN0510 for preliminary use in eval_order_system, see case-study mat-eng.tex
36.126 -fun ord_simplify_System_rev (pr:bool) thy subst tu =
36.127 - (term_ord' pr thy (Library.swap tu) = LESS);*)
36.128 -
36.129 -(*for the rls's*)
36.130 -fun ord_simplify_System (pr:bool) thy subst tu =
36.131 - (term_ord' pr thy tu = LESS);
36.132 -(**)
36.133 -end;
36.134 -(**)
36.135 -rew_ord' := overwritel (!rew_ord',
36.136 -[("ord_simplify_System", ord_simplify_System false thy)
36.137 - ]);
36.138 -
36.139 -
36.140 -(** rulesets **)
36.141 -
36.142 -(*.adapted from 'order_add_mult_in' by just replacing the rew_ord.*)
36.143 -val order_add_mult_System =
36.144 - Rls{id = "order_add_mult_System", preconds = [],
36.145 - rew_ord = ("ord_simplify_System",
36.146 - ord_simplify_System false Integrate.thy),
36.147 - erls = e_rls,srls = Erls, calc = [],
36.148 - rules = [Thm ("real_mult_commute",num_str real_mult_commute),
36.149 - (* z * w = w * z *)
36.150 - Thm ("real_mult_left_commute",num_str real_mult_left_commute),
36.151 - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
36.152 - Thm ("real_mult_assoc",num_str real_mult_assoc),
36.153 - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
36.154 - Thm ("real_add_commute",num_str real_add_commute),
36.155 - (*z + w = w + z*)
36.156 - Thm ("real_add_left_commute",num_str real_add_left_commute),
36.157 - (*x + (y + z) = y + (x + z)*)
36.158 - Thm ("real_add_assoc",num_str real_add_assoc)
36.159 - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
36.160 - ],
36.161 - scr = EmptyScr}:rls;
36.162 -
36.163 -(*.adapted from 'norm_Rational' by
36.164 - #1 using 'ord_simplify_System' in 'order_add_mult_System'
36.165 - #2 NOT using common_nominator_p .*)
36.166 -val norm_System_noadd_fractions =
36.167 - Rls {id = "norm_System_noadd_fractions", preconds = [],
36.168 - rew_ord = ("dummy_ord",dummy_ord),
36.169 - erls = norm_rat_erls, srls = Erls, calc = [],
36.170 - rules = [(*sequence given by operator precedence*)
36.171 - Rls_ discard_minus,
36.172 - Rls_ powers,
36.173 - Rls_ rat_mult_divide,
36.174 - Rls_ expand,
36.175 - Rls_ reduce_0_1_2,
36.176 - Rls_ (*order_add_mult #1*) order_add_mult_System,
36.177 - Rls_ collect_numerals,
36.178 - (*Rls_ add_fractions_p, #2*)
36.179 - Rls_ cancel_p
36.180 - ],
36.181 - scr = Script ((term_of o the o (parse thy))
36.182 - "empty_script")
36.183 - }:rls;
36.184 -(*.adapted from 'norm_Rational' by
36.185 - *1* using 'ord_simplify_System' in 'order_add_mult_System'.*)
36.186 -val norm_System =
36.187 - Rls {id = "norm_System", preconds = [],
36.188 - rew_ord = ("dummy_ord",dummy_ord),
36.189 - erls = norm_rat_erls, srls = Erls, calc = [],
36.190 - rules = [(*sequence given by operator precedence*)
36.191 - Rls_ discard_minus,
36.192 - Rls_ powers,
36.193 - Rls_ rat_mult_divide,
36.194 - Rls_ expand,
36.195 - Rls_ reduce_0_1_2,
36.196 - Rls_ (*order_add_mult *1*) order_add_mult_System,
36.197 - Rls_ collect_numerals,
36.198 - Rls_ add_fractions_p,
36.199 - Rls_ cancel_p
36.200 - ],
36.201 - scr = Script ((term_of o the o (parse thy))
36.202 - "empty_script")
36.203 - }:rls;
36.204 -
36.205 -(*.simplify an equational system BEFORE solving it such that parentheses are
36.206 - ( ((u0*v0)*w0) + ( ((u1*v1)*w1) * c + ... +((u4*v4)*w4) * c_4 ) )
36.207 -ATTENTION: works ONLY for bound variables c, c_1, c_2, c_3, c_4 :ATTENTION
36.208 - This is a copy from 'make_ratpoly_in' with respective reductions:
36.209 - *0* expand the term, ie. distribute * and / over +
36.210 - *1* ord_simplify_System instead of termlessI
36.211 - *2* no add_fractions_p (= common_nominator_p_rls !)
36.212 - *3* discard_parentheses only for (.*(.*.))
36.213 - analoguous to simplify_Integral .*)
36.214 -val simplify_System_parenthesized =
36.215 - Seq {id = "simplify_System_parenthesized", preconds = []:term list,
36.216 - rew_ord = ("dummy_ord", dummy_ord),
36.217 - erls = Atools_erls, srls = Erls, calc = [],
36.218 - rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib),
36.219 - (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*)
36.220 - Thm ("real_add_divide_distrib",num_str real_add_divide_distrib),
36.221 - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)
36.222 - (*^^^^^ *0* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*)
36.223 - Rls_ norm_Rational_noadd_fractions(**2**),
36.224 - Rls_ (*order_add_mult_in*) norm_System_noadd_fractions (**1**),
36.225 - Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym))
36.226 - (*Rls_ discard_parentheses *3**),
36.227 - Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*)
36.228 - Rls_ separate_bdv2,
36.229 - Calc ("HOL.divide" ,eval_cancel "#divide_")
36.230 - ],
36.231 - scr = EmptyScr}:rls;
36.232 -
36.233 -(*.simplify an equational system AFTER solving it;
36.234 - This is a copy of 'make_ratpoly_in' with the differences
36.235 - *1* ord_simplify_System instead of termlessI .*)
36.236 -(*TODO.WN051031 ^^^^^^^^^^ should be in EACH rls contained *)
36.237 -val simplify_System =
36.238 - Seq {id = "simplify_System", preconds = []:term list,
36.239 - rew_ord = ("dummy_ord", dummy_ord),
36.240 - erls = Atools_erls, srls = Erls, calc = [],
36.241 - rules = [Rls_ norm_Rational,
36.242 - Rls_ (*order_add_mult_in*) norm_System (**1**),
36.243 - Rls_ discard_parentheses,
36.244 - Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*)
36.245 - Rls_ separate_bdv2,
36.246 - Calc ("HOL.divide" ,eval_cancel "#divide_")
36.247 - ],
36.248 - scr = EmptyScr}:rls;
36.249 -(*
36.250 -val simplify_System =
36.251 - append_rls "simplify_System" simplify_System_parenthesized
36.252 - [Thm ("sym_real_add_assoc", num_str (real_add_assoc RS sym))];
36.253 -*)
36.254 -
36.255 -val isolate_bdvs =
36.256 - Rls {id="isolate_bdvs", preconds = [],
36.257 - rew_ord = ("e_rew_ord", e_rew_ord),
36.258 - erls = append_rls "erls_isolate_bdvs" e_rls
36.259 - [(Calc ("EqSystem.occur'_exactly'_in",
36.260 - eval_occur_exactly_in
36.261 - "#eval_occur_exactly_in_"))
36.262 - ],
36.263 - srls = Erls, calc = [],
36.264 - rules = [Thm ("commute_0_equality",
36.265 - num_str commute_0_equality),
36.266 - Thm ("separate_bdvs_add", num_str separate_bdvs_add),
36.267 - Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)],
36.268 - scr = EmptyScr};
36.269 -val isolate_bdvs_4x4 =
36.270 - Rls {id="isolate_bdvs_4x4", preconds = [],
36.271 - rew_ord = ("e_rew_ord", e_rew_ord),
36.272 - erls = append_rls
36.273 - "erls_isolate_bdvs_4x4" e_rls
36.274 - [Calc ("EqSystem.occur'_exactly'_in",
36.275 - eval_occur_exactly_in "#eval_occur_exactly_in_"),
36.276 - Calc ("Atools.ident",eval_ident "#ident_"),
36.277 - Calc ("Atools.some'_occur'_in",
36.278 - eval_some_occur_in "#some_occur_in_"),
36.279 - Thm ("not_true",num_str not_true),
36.280 - Thm ("not_false",num_str not_false)
36.281 - ],
36.282 - srls = Erls, calc = [],
36.283 - rules = [Thm ("commute_0_equality",
36.284 - num_str commute_0_equality),
36.285 - Thm ("separate_bdvs0", num_str separate_bdvs0),
36.286 - Thm ("separate_bdvs_add1", num_str separate_bdvs_add1),
36.287 - Thm ("separate_bdvs_add1", num_str separate_bdvs_add2),
36.288 - Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)],
36.289 - scr = EmptyScr};
36.290 -
36.291 -(*.order the equations in a system such, that a triangular system (if any)
36.292 - appears as [..c_4 = .., ..., ..., ..c_1 + ..c_2 + ..c_3 ..c_4 = ..].*)
36.293 -val order_system =
36.294 - Rls {id="order_system", preconds = [],
36.295 - rew_ord = ("ord_simplify_System",
36.296 - ord_simplify_System false thy),
36.297 - erls = Erls, srls = Erls, calc = [],
36.298 - rules = [Thm ("order_system_NxN", num_str order_system_NxN)
36.299 - ],
36.300 - scr = EmptyScr};
36.301 -
36.302 -val prls_triangular =
36.303 - Rls {id="prls_triangular", preconds = [],
36.304 - rew_ord = ("e_rew_ord", e_rew_ord),
36.305 - erls = Rls {id="erls_prls_triangular", preconds = [],
36.306 - rew_ord = ("e_rew_ord", e_rew_ord),
36.307 - erls = Erls, srls = Erls, calc = [],
36.308 - rules = [(*for precond nth_Cons_ ...*)
36.309 - Calc ("op <",eval_equ "#less_"),
36.310 - Calc ("op +", eval_binop "#add_")
36.311 - (*immediately repeated rewrite pushes
36.312 - '+' into precondition !*)
36.313 - ],
36.314 - scr = EmptyScr},
36.315 - srls = Erls, calc = [],
36.316 - rules = [Thm ("nth_Cons_",num_str nth_Cons_),
36.317 - Calc ("op +", eval_binop "#add_"),
36.318 - Thm ("nth_Nil_",num_str nth_Nil_),
36.319 - Thm ("tl_Cons",num_str tl_Cons),
36.320 - Thm ("tl_Nil",num_str tl_Nil),
36.321 - Calc ("EqSystem.occur'_exactly'_in",
36.322 - eval_occur_exactly_in
36.323 - "#eval_occur_exactly_in_")
36.324 - ],
36.325 - scr = EmptyScr};
36.326 -
36.327 -(*WN060914 quickly created for 4x4;
36.328 - more similarity to prls_triangular desirable*)
36.329 -val prls_triangular4 =
36.330 - Rls {id="prls_triangular4", preconds = [],
36.331 - rew_ord = ("e_rew_ord", e_rew_ord),
36.332 - erls = Rls {id="erls_prls_triangular4", preconds = [],
36.333 - rew_ord = ("e_rew_ord", e_rew_ord),
36.334 - erls = Erls, srls = Erls, calc = [],
36.335 - rules = [(*for precond nth_Cons_ ...*)
36.336 - Calc ("op <",eval_equ "#less_"),
36.337 - Calc ("op +", eval_binop "#add_")
36.338 - (*immediately repeated rewrite pushes
36.339 - '+' into precondition !*)
36.340 - ],
36.341 - scr = EmptyScr},
36.342 - srls = Erls, calc = [],
36.343 - rules = [Thm ("nth_Cons_",num_str nth_Cons_),
36.344 - Calc ("op +", eval_binop "#add_"),
36.345 - Thm ("nth_Nil_",num_str nth_Nil_),
36.346 - Thm ("tl_Cons",num_str tl_Cons),
36.347 - Thm ("tl_Nil",num_str tl_Nil),
36.348 - Calc ("EqSystem.occur'_exactly'_in",
36.349 - eval_occur_exactly_in
36.350 - "#eval_occur_exactly_in_")
36.351 - ],
36.352 - scr = EmptyScr};
36.353 -
36.354 -ruleset' :=
36.355 -overwritelthy thy
36.356 - (!ruleset',
36.357 -[("simplify_System_parenthesized", prep_rls simplify_System_parenthesized),
36.358 - ("simplify_System", prep_rls simplify_System),
36.359 - ("isolate_bdvs", prep_rls isolate_bdvs),
36.360 - ("isolate_bdvs_4x4", prep_rls isolate_bdvs_4x4),
36.361 - ("order_system", prep_rls order_system),
36.362 - ("order_add_mult_System", prep_rls order_add_mult_System),
36.363 - ("norm_System_noadd_fractions", prep_rls norm_System_noadd_fractions),
36.364 - ("norm_System", prep_rls norm_System)
36.365 - ]);
36.366 -
36.367 -
36.368 -(** problems **)
36.369 -
36.370 -store_pbt
36.371 - (prep_pbt EqSystem.thy "pbl_equsys" [] e_pblID
36.372 - (["system"],
36.373 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.374 - ("#Find" ,["solution ss___"](*___ is copy-named*))
36.375 - ],
36.376 - append_rls "e_rls" e_rls [(*for preds in where_*)],
36.377 - SOME "solveSystem es_ vs_",
36.378 - []));
36.379 -store_pbt
36.380 - (prep_pbt EqSystem.thy "pbl_equsys_lin" [] e_pblID
36.381 - (["linear", "system"],
36.382 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.383 - (*TODO.WN050929 check linearity*)
36.384 - ("#Find" ,["solution ss___"])
36.385 - ],
36.386 - append_rls "e_rls" e_rls [(*for preds in where_*)],
36.387 - SOME "solveSystem es_ vs_",
36.388 - []));
36.389 -store_pbt
36.390 - (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2" [] e_pblID
36.391 - (["2x2", "linear", "system"],
36.392 - (*~~~~~~~~~~~~~~~~~~~~~~~~~*)
36.393 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.394 - ("#Where" ,["length_ (es_:: bool list) = 2", "length_ vs_ = 2"]),
36.395 - ("#Find" ,["solution ss___"])
36.396 - ],
36.397 - append_rls "prls_2x2_linear_system" e_rls
36.398 - [Thm ("length_Cons_",num_str length_Cons_),
36.399 - Thm ("length_Nil_",num_str length_Nil_),
36.400 - Calc ("op +", eval_binop "#add_"),
36.401 - Calc ("op =",eval_equal "#equal_")
36.402 - ],
36.403 - SOME "solveSystem es_ vs_",
36.404 - []));
36.405 -store_pbt
36.406 - (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_tri" [] e_pblID
36.407 - (["triangular", "2x2", "linear", "system"],
36.408 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.409 - ("#Where" ,
36.410 - ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))",
36.411 - " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]),
36.412 - ("#Find" ,["solution ss___"])
36.413 - ],
36.414 - prls_triangular,
36.415 - SOME "solveSystem es_ vs_",
36.416 - [["EqSystem","top_down_substitution","2x2"]]));
36.417 -store_pbt
36.418 - (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_norm" [] e_pblID
36.419 - (["normalize", "2x2", "linear", "system"],
36.420 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.421 - ("#Find" ,["solution ss___"])
36.422 - ],
36.423 - append_rls "e_rls" e_rls [(*for preds in where_*)],
36.424 - SOME "solveSystem es_ vs_",
36.425 - [["EqSystem","normalize","2x2"]]));
36.426 -store_pbt
36.427 - (prep_pbt EqSystem.thy "pbl_equsys_lin_3x3" [] e_pblID
36.428 - (["3x3", "linear", "system"],
36.429 - (*~~~~~~~~~~~~~~~~~~~~~~~~~*)
36.430 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.431 - ("#Where" ,["length_ (es_:: bool list) = 3", "length_ vs_ = 3"]),
36.432 - ("#Find" ,["solution ss___"])
36.433 - ],
36.434 - append_rls "prls_3x3_linear_system" e_rls
36.435 - [Thm ("length_Cons_",num_str length_Cons_),
36.436 - Thm ("length_Nil_",num_str length_Nil_),
36.437 - Calc ("op +", eval_binop "#add_"),
36.438 - Calc ("op =",eval_equal "#equal_")
36.439 - ],
36.440 - SOME "solveSystem es_ vs_",
36.441 - []));
36.442 -store_pbt
36.443 - (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4" [] e_pblID
36.444 - (["4x4", "linear", "system"],
36.445 - (*~~~~~~~~~~~~~~~~~~~~~~~~~*)
36.446 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.447 - ("#Where" ,["length_ (es_:: bool list) = 4", "length_ vs_ = 4"]),
36.448 - ("#Find" ,["solution ss___"])
36.449 - ],
36.450 - append_rls "prls_4x4_linear_system" e_rls
36.451 - [Thm ("length_Cons_",num_str length_Cons_),
36.452 - Thm ("length_Nil_",num_str length_Nil_),
36.453 - Calc ("op +", eval_binop "#add_"),
36.454 - Calc ("op =",eval_equal "#equal_")
36.455 - ],
36.456 - SOME "solveSystem es_ vs_",
36.457 - []));
36.458 -store_pbt
36.459 - (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_tri" [] e_pblID
36.460 - (["triangular", "4x4", "linear", "system"],
36.461 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.462 - ("#Where" , (*accepts missing variables up to diagional form*)
36.463 - ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))",
36.464 - "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))",
36.465 - "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))",
36.466 - "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))"
36.467 - ]),
36.468 - ("#Find" ,["solution ss___"])
36.469 - ],
36.470 - append_rls "prls_tri_4x4_lin_sys" prls_triangular
36.471 - [Calc ("Atools.occurs'_in",eval_occurs_in "")],
36.472 - SOME "solveSystem es_ vs_",
36.473 - [["EqSystem","top_down_substitution","4x4"]]));
36.474 -
36.475 -store_pbt
36.476 - (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_norm" [] e_pblID
36.477 - (["normalize", "4x4", "linear", "system"],
36.478 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.479 - (*length_ is checked 1 level above*)
36.480 - ("#Find" ,["solution ss___"])
36.481 - ],
36.482 - append_rls "e_rls" e_rls [(*for preds in where_*)],
36.483 - SOME "solveSystem es_ vs_",
36.484 - [["EqSystem","normalize","4x4"]]));
36.485 -
36.486 -
36.487 -(* show_ptyps();
36.488 - *)
36.489 -
36.490 -(** methods **)
36.491 -
36.492 -store_met
36.493 - (prep_met EqSystem.thy "met_eqsys" [] e_metID
36.494 - (["EqSystem"],
36.495 - [],
36.496 - {rew_ord'="tless_true", rls' = Erls, calc = [],
36.497 - srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
36.498 - "empty_script"
36.499 - ));
36.500 -store_met
36.501 - (prep_met EqSystem.thy "met_eqsys_topdown" [] e_metID
36.502 - (["EqSystem","top_down_substitution"],
36.503 - [],
36.504 - {rew_ord'="tless_true", rls' = Erls, calc = [],
36.505 - srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
36.506 - "empty_script"
36.507 - ));
36.508 -store_met
36.509 - (prep_met EqSystem.thy "met_eqsys_topdown_2x2" [] e_metID
36.510 - (["EqSystem","top_down_substitution","2x2"],
36.511 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.512 - ("#Where" ,
36.513 - ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))",
36.514 - " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]),
36.515 - ("#Find" ,["solution ss___"])
36.516 - ],
36.517 - {rew_ord'="ord_simplify_System", rls' = Erls, calc = [],
36.518 - srls = append_rls "srls_top_down_2x2" e_rls
36.519 - [Thm ("hd_thm",num_str hd_thm),
36.520 - Thm ("tl_Cons",num_str tl_Cons),
36.521 - Thm ("tl_Nil",num_str tl_Nil)
36.522 - ],
36.523 - prls = prls_triangular, crls = Erls, nrls = Erls},
36.524 -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
36.525 -\ (let e1__ = Take (hd es_); \
36.526 -\ e1__ = ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.527 -\ isolate_bdvs False)) @@ \
36.528 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.529 -\ simplify_System False))) e1__; \
36.530 -\ e2__ = Take (hd (tl es_)); \
36.531 -\ e2__ = ((Substitute [e1__]) @@ \
36.532 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.533 -\ simplify_System_parenthesized False)) @@ \
36.534 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.535 -\ isolate_bdvs False)) @@ \
36.536 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.537 -\ simplify_System False))) e2__; \
36.538 -\ es__ = Take [e1__, e2__] \
36.539 -\ in (Try (Rewrite_Set order_system False)) es__)"
36.540 -(*---------------------------------------------------------------------------
36.541 - this script does NOT separate the equations as abolve,
36.542 - but it does not yet work due to preliminary script-interpreter,
36.543 - see eqsystem.sml 'script [EqSystem,top_down_substitution,2x2] Vers.2'
36.544 -
36.545 -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
36.546 -\ (let es__ = Take es_; \
36.547 -\ e1__ = hd es__; \
36.548 -\ e2__ = hd (tl es__); \
36.549 -\ es__ = [e1__, Substitute [e1__] e2__] \
36.550 -\ in ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.551 -\ simplify_System_parenthesized False)) @@ \
36.552 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))] \
36.553 -\ isolate_bdvs False)) @@ \
36.554 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.555 -\ simplify_System False))) es__)"
36.556 ----------------------------------------------------------------------------*)
36.557 - ));
36.558 -store_met
36.559 - (prep_met EqSystem.thy "met_eqsys_norm" [] e_metID
36.560 - (["EqSystem","normalize"],
36.561 - [],
36.562 - {rew_ord'="tless_true", rls' = Erls, calc = [],
36.563 - srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
36.564 - "empty_script"
36.565 - ));
36.566 -store_met
36.567 - (prep_met EqSystem.thy "met_eqsys_norm_2x2" [] e_metID
36.568 - (["EqSystem","normalize","2x2"],
36.569 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.570 - ("#Find" ,["solution ss___"])],
36.571 - {rew_ord'="tless_true", rls' = Erls, calc = [],
36.572 - srls = append_rls "srls_normalize_2x2" e_rls
36.573 - [Thm ("hd_thm",num_str hd_thm),
36.574 - Thm ("tl_Cons",num_str tl_Cons),
36.575 - Thm ("tl_Nil",num_str tl_Nil)
36.576 - ],
36.577 - prls = Erls, crls = Erls, nrls = Erls},
36.578 -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
36.579 -\ (let es__ = ((Try (Rewrite_Set norm_Rational False)) @@ \
36.580 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.581 -\ simplify_System_parenthesized False)) @@ \
36.582 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.583 -\ isolate_bdvs False)) @@ \
36.584 -\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
36.585 -\ simplify_System_parenthesized False)) @@ \
36.586 -\ (Try (Rewrite_Set order_system False))) es_ \
36.587 -\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \
36.588 -\ [bool_list_ es__, real_list_ vs_]))"
36.589 - ));
36.590 -
36.591 -(*this is for nth_ only*)
36.592 -val srls = Rls {id="srls_normalize_4x4",
36.593 - preconds = [],
36.594 - rew_ord = ("termlessI",termlessI),
36.595 - erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls
36.596 - [(*for asm in nth_Cons_ ...*)
36.597 - Calc ("op <",eval_equ "#less_"),
36.598 - (*2nd nth_Cons_ pushes n+-1 into asms*)
36.599 - Calc("op +", eval_binop "#add_")
36.600 - ],
36.601 - srls = Erls, calc = [],
36.602 - rules = [Thm ("nth_Cons_",num_str nth_Cons_),
36.603 - Calc("op +", eval_binop "#add_"),
36.604 - Thm ("nth_Nil_",num_str nth_Nil_)],
36.605 - scr = EmptyScr};
36.606 -store_met
36.607 - (prep_met EqSystem.thy "met_eqsys_norm_4x4" [] e_metID
36.608 - (["EqSystem","normalize","4x4"],
36.609 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.610 - ("#Find" ,["solution ss___"])],
36.611 - {rew_ord'="tless_true", rls' = Erls, calc = [],
36.612 - srls = append_rls "srls_normalize_4x4" srls
36.613 - [Thm ("hd_thm",num_str hd_thm),
36.614 - Thm ("tl_Cons",num_str tl_Cons),
36.615 - Thm ("tl_Nil",num_str tl_Nil)
36.616 - ],
36.617 - prls = Erls, crls = Erls, nrls = Erls},
36.618 -(*GOON met ["EqSystem","normalize","4x4"] @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
36.619 -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
36.620 -\ (let es__ = \
36.621 -\ ((Try (Rewrite_Set norm_Rational False)) @@ \
36.622 -\ (Repeat (Rewrite commute_0_equality False)) @@ \
36.623 -\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \
36.624 -\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \
36.625 -\ simplify_System_parenthesized False)) @@ \
36.626 -\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \
36.627 -\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \
36.628 -\ isolate_bdvs_4x4 False)) @@ \
36.629 -\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \
36.630 -\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \
36.631 -\ simplify_System_parenthesized False)) @@ \
36.632 -\ (Try (Rewrite_Set order_system False))) es_ \
36.633 -\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \
36.634 -\ [bool_list_ es__, real_list_ vs_]))"
36.635 -));
36.636 -store_met
36.637 -(prep_met EqSystem.thy "met_eqsys_topdown_4x4" [] e_metID
36.638 - (["EqSystem","top_down_substitution","4x4"],
36.639 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
36.640 - ("#Where" , (*accepts missing variables up to diagonal form*)
36.641 - ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))",
36.642 - "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))",
36.643 - "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))",
36.644 - "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))"
36.645 - ]),
36.646 - ("#Find" ,["solution ss___"])
36.647 - ],
36.648 - {rew_ord'="ord_simplify_System", rls' = Erls, calc = [],
36.649 - srls = append_rls "srls_top_down_4x4" srls [],
36.650 - prls = append_rls "prls_tri_4x4_lin_sys" prls_triangular
36.651 - [Calc ("Atools.occurs'_in",eval_occurs_in "")],
36.652 - crls = Erls, nrls = Erls},
36.653 -(*FIXXXXME.WN060916: this script works ONLY for exp 7.79 @@@@@@@@@@@@@@@@@@@@*)
36.654 -"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
36.655 -\ (let e1_ = nth_ 1 es_; \
36.656 -\ e2_ = Take (nth_ 2 es_); \
36.657 -\ e2_ = ((Substitute [e1_]) @@ \
36.658 -\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\
36.659 -\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\
36.660 -\ simplify_System_parenthesized False)) @@ \
36.661 -\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\
36.662 -\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\
36.663 -\ isolate_bdvs False)) @@ \
36.664 -\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\
36.665 -\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\
36.666 -\ norm_Rational False))) e2_ \
36.667 -\ in [e1_, e2_, nth_ 3 es_, nth_ 4 es_])"
36.668 -));
36.669 -
36.670 -(* show_mets();
36.671 - *)
36.672 -
36.673 -(*
36.674 -use"IsacKnowledge/EqSystem.ML";
36.675 -use"EqSystem.ML";
36.676 -*)
37.1 --- a/src/Tools/isac/IsacKnowledge/EqSystem.thy Wed Aug 25 15:15:01 2010 +0200
37.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
37.3 @@ -1,72 +0,0 @@
37.4 -(* equational systems, minimal -- for use in Biegelinie
37.5 - author: Walther Neuper
37.6 - 050826,
37.7 - (c) due to copyright terms
37.8 -
37.9 -remove_thy"EqSystem";
37.10 -use_thy"IsacKnowledge/EqSystem";
37.11 -
37.12 -use_thy_only"IsacKnowledge/EqSystem";
37.13 -
37.14 -remove_thy"Typefix";
37.15 -use_thy"IsacKnowledge/Isac";
37.16 -*)
37.17 -
37.18 -EqSystem = Rational + Root +
37.19 -
37.20 -consts
37.21 -
37.22 - occur'_exactly'_in ::
37.23 - "[real list, real list, 'a] => bool" ("_ from'_ _ occur'_exactly'_in _")
37.24 -
37.25 - (*descriptions in the related problems*)
37.26 - solveForVars :: real list => toreall
37.27 - solution :: bool list => toreall
37.28 -
37.29 - (*the CAS-command, eg. "solveSystem [x+y=1,y=2] [x,y]"*)
37.30 - solveSystem :: "[bool list, real list] => bool list"
37.31 -
37.32 - (*Script-names*)
37.33 - SolveSystemScript :: "[bool list, real list, bool list] \
37.34 - \=> bool list"
37.35 - ("((Script SolveSystemScript (_ _ =))// (_))" 9)
37.36 -
37.37 -rules
37.38 -(*stated as axioms, todo: prove as theorems
37.39 - 'bdv' is a constant handled on the meta-level
37.40 - specifically as a 'bound variable' *)
37.41 -
37.42 - commute_0_equality "(0 = a) = (a = 0)"
37.43 -
37.44 - (*WN0510 see simliar rules 'isolate_' 'separate_' (by RL)
37.45 - [bdv_1,bdv_2,bdv_3,bdv_4] work also for 2 and 3 bdvs, ugly !*)
37.46 - separate_bdvs_add
37.47 - "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a |]\
37.48 - \ ==> (a + b = c) = (b = c + -1*a)"
37.49 - separate_bdvs0
37.50 - "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in b; Not (b=!=0) |]\
37.51 - \ ==> (a = b) = (a + -1*b = 0)"
37.52 - separate_bdvs_add1
37.53 - "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in c |]\
37.54 - \ ==> (a = b + c) = (a + -1*c = b)"
37.55 - separate_bdvs_add2
37.56 - "[| Not (some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in a) |]\
37.57 - \ ==> (a + b = c) = (b = -1*a + c)"
37.58 -
37.59 -
37.60 -
37.61 - separate_bdvs_mult
37.62 - "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a; Not (a=!=0) |]\
37.63 - \ ==>(a * b = c) = (b = c / a)"
37.64 -
37.65 - (*requires rew_ord for termination, eg. ord_simplify_Integral;
37.66 - works for lists of any length, interestingly !?!*)
37.67 - order_system_NxN "[a,b] = [b,a]"
37.68 -
37.69 -(*
37.70 -remove_thy"EqSystem";
37.71 -use_thy_only"IsacKnowledge/EqSystem";
37.72 -use_thy"IsacKnowledge/EqSystem";
37.73 -use"IsacKnowledge/EqSystem.ML";
37.74 - *)
37.75 -end
37.76 \ No newline at end of file
38.1 --- a/src/Tools/isac/IsacKnowledge/Equation.ML Wed Aug 25 15:15:01 2010 +0200
38.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
38.3 @@ -1,85 +0,0 @@
38.4 -(*.(c) by Richard Lang, 2003 .*)
38.5 -(* defines equation and univariate-equation
38.6 - created by: rlang
38.7 - date: 02.09
38.8 - changed by: rlang
38.9 - last change by: rlang
38.10 - date: 02.11.29
38.11 -*)
38.12 -
38.13 -(* use_thy_only"IsacKnowledge/Equation";
38.14 - use_thy"IsacKnowledge/Equation";
38.15 - use"IsacKnowledge/Equation.ML";
38.16 - use"Equation.ML";
38.17 - *)
38.18 -
38.19 -theory' := overwritel (!theory', [("Equation.thy",Equation.thy)]);
38.20 -
38.21 -val univariate_equation_prls =
38.22 - append_rls "univariate_equation_prls" e_rls
38.23 - [Calc ("Tools.matches",eval_matches "")];
38.24 -ruleset' :=
38.25 -overwritelthy thy (!ruleset',
38.26 - [("univariate_equation_prls",
38.27 - prep_rls univariate_equation_prls)]);
38.28 -
38.29 -
38.30 -store_pbt
38.31 - (prep_pbt Equation.thy "pbl_equ" [] e_pblID
38.32 - (["equation"],
38.33 - [("#Given" ,["equality e_","solveFor v_"]),
38.34 - ("#Where" ,["matches (?a = ?b) e_"]),
38.35 - ("#Find" ,["solutions v_i_"])
38.36 - ],
38.37 - append_rls "equation_prls" e_rls
38.38 - [Calc ("Tools.matches",eval_matches "")],
38.39 - SOME "solve (e_::bool, v_)",
38.40 - []));
38.41 -
38.42 -store_pbt
38.43 - (prep_pbt Equation.thy "pbl_equ_univ" [] e_pblID
38.44 - (["univariate","equation"],
38.45 - [("#Given" ,["equality e_","solveFor v_"]),
38.46 - ("#Where" ,["matches (?a = ?b) e_"]),
38.47 - ("#Find" ,["solutions v_i_"])
38.48 - ],
38.49 - univariate_equation_prls,SOME "solve (e_::bool, v_)",[]));
38.50 -
38.51 -
38.52 -(*.function for handling the cas-input "solve (x+1=2, x)":
38.53 - make a model which is already in ptree-internal format.*)
38.54 -(* val (h,argl) = strip_comb (str2term "solve (x+1=2, x)");
38.55 - val (h,argl) = strip_comb ((term_of o the o (parse thy))
38.56 - "solveTest (x+1=2, x)");
38.57 - *)
38.58 -fun argl2dtss [Const ("Pair", _) $ eq $ bdv] =
38.59 - [((term_of o the o (parse thy)) "equality", [eq]),
38.60 - ((term_of o the o (parse thy)) "solveFor", [bdv]),
38.61 - ((term_of o the o (parse thy)) "solutions",
38.62 - [(term_of o the o (parse thy)) "L"])
38.63 - ]
38.64 - | argl2dtss _ = raise error "Equation.ML: wrong argument for argl2dtss";
38.65 -
38.66 -castab :=
38.67 -overwritel (!castab,
38.68 - [((term_of o the o (parse thy)) "solveTest",
38.69 - (("Test.thy", ["univariate","equation","test"], ["no_met"]),
38.70 - argl2dtss)),
38.71 - ((term_of o the o (parse thy)) "solve",
38.72 - (("Isac.thy", ["univariate","equation"], ["no_met"]),
38.73 - argl2dtss))
38.74 - ]);
38.75 -
38.76 -
38.77 -
38.78 -store_met
38.79 - (prep_met Equation.thy "met_equ" [] e_metID
38.80 - (["Equation"],
38.81 - [],
38.82 - {rew_ord'="tless_true", rls'=Erls, calc = [],
38.83 - srls = e_rls,
38.84 - prls=e_rls,
38.85 - crls = Atools_erls, nrls = e_rls},
38.86 -"empty_script"
38.87 -));
38.88 -
39.1 --- a/src/Tools/isac/IsacKnowledge/Equation.thy Wed Aug 25 15:15:01 2010 +0200
39.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
39.3 @@ -1,29 +0,0 @@
39.4 -(* equations and functions; functions NOT as lambda-terms
39.5 - author: Walther Neuper 2005, 2006
39.6 - (c) due to copyright terms
39.7 -
39.8 -remove_thy"Equation";
39.9 -use_thy"IsacKnowledge/Equation";
39.10 -use_thy_only"IsacKnowledge/Equation";
39.11 -
39.12 -remove_thy"Equation";
39.13 -use_thy"IsacKnowledge/Isac";
39.14 -*)
39.15 -
39.16 -Equation = Atools +
39.17 -
39.18 -consts
39.19 -
39.20 - (*descriptions in the related problems TODOshift here from Descriptions.thy*)
39.21 - substitution :: bool => una
39.22 -
39.23 - (*the CAS-commands*)
39.24 - solve :: "[bool * 'a] => bool list" (* solve (x+1=2, x) *)
39.25 - solveTest :: "[bool * 'a] => bool list" (* for test collection *)
39.26 -
39.27 - (*Script-names*)
39.28 - Function2Equality :: "[bool, bool, bool] \
39.29 - \=> bool"
39.30 - ("((Script Function2Equality (_ _ =))// (_))" 9)
39.31 -
39.32 -end
39.33 \ No newline at end of file
40.1 --- a/src/Tools/isac/IsacKnowledge/InsSort.ML Wed Aug 25 15:15:01 2010 +0200
40.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
40.3 @@ -1,77 +0,0 @@
40.4 -(* 6.8.02 change to Isabelle2002 caused error -- thy excluded !
40.5 -
40.6 -Proving equations for primrec function(s) "InsSort.foldr" ...
40.7 -GC #1.17.30.54.345.21479: (10 ms)
40.8 -*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list"
40.9 -*** imposes additional sort constraints on the declared type of the constant
40.10 -*** The error(s) above occurred in definition "InsSort.ins.ins_list_def"
40.11 -*)
40.12 -
40.13 -(* tools for insertion sort
40.14 - use"IsacKnowledge/InsSort.ML";
40.15 -*)
40.16 -
40.17 -(** interface isabelle -- isac **)
40.18 -
40.19 -theory' := (!theory') @ [("InsSort.thy",InsSort.thy)];
40.20 -
40.21 -(** rule set **)
40.22 -
40.23 -val ins_sort = prep_rls(
40.24 - Rls{preconds = [], rew_ord = ("tless_true",tless_true),
40.25 - rules = [Thm ("foldr_base",(*num_str*) foldr_base),
40.26 - Thm ("foldr_rec",foldr_rec),
40.27 - Thm ("ins_base",ins_base),
40.28 - Thm ("ins_rec",ins_rec),
40.29 - Thm ("sort_def",sort_def),
40.30 -
40.31 - Calc ("op <",eval_equ "#less_"),
40.32 - Thm ("if_True", if_True),
40.33 - Thm ("if_False", if_False)
40.34 - ],
40.35 - scr = Script ((term_of o the o (parse thy))
40.36 - "empty_script")
40.37 - }:rls);
40.38 -
40.39 -(** problem type **)
40.40 -
40.41 -store_pbt
40.42 - (prep_pbt InsSort.thy
40.43 - (["functional"]:pblID,
40.44 - [("#Given" ,["unsorted u_"]),
40.45 - ("#Find" ,["sorted s_"])
40.46 - ],
40.47 - []));
40.48 -
40.49 -store_pbt
40.50 - (prep_pbt InsSort.thy
40.51 - (["inssort","functional"]:pblID,
40.52 - [("#Given" ,["unsorted u_"]),
40.53 - ("#Find" ,["sorted s_"])
40.54 - ],
40.55 - []));
40.56 -
40.57 -(** method,
40.58 - todo: implementation needs extra object-level lists **)
40.59 -
40.60 -store_met
40.61 - (prep_met Diff.thy
40.62 - (["InsSort"],
40.63 - [],
40.64 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
40.65 - crls = Atools_rls, nrls=norm_Rational
40.66 - (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
40.67 -store_met
40.68 - (prep_met InsSort.thy (*test-version for [#1,#3,#2] only: see *.sml*)
40.69 - (["InsSort""sort"]:metID,
40.70 - [("#Given" ,["unsorted u_"]),
40.71 - ("#Find" ,["sorted s_"])
40.72 - ],
40.73 - {rew_ord'="tless_true",rls'=eval_rls,calc = [], srls = e_rls, prls=e_rls,
40.74 - crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)},
40.75 - "Script Sort (u_::'a list) = (Rewrite_Set ins_sort False) u_"
40.76 - ));
40.77 -
40.78 -ruleset' := overwritelthy thy (!ruleset',
40.79 - [(*("ins_sort",ins_sort) overwrites a Isa fun!!*)
40.80 - ]:(string * rls) list);
41.1 --- a/src/Tools/isac/IsacKnowledge/InsSort.sml Wed Aug 25 15:15:01 2010 +0200
41.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
41.3 @@ -1,395 +0,0 @@
41.4 -
41.5 -
41.6 -(*-------------------------from InsSort.thy 8.3.01----------------------*)
41.7 -(*List.thy:
41.8 - foldl :: [['b,'a] => 'b, 'b, 'a list] => 'b
41.9 -primrec
41.10 - foldl_Nil "foldl f a [] = a"
41.11 - foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs"
41.12 -
41.13 -above in sml:
41.14 -fun foldr f [] a = a
41.15 - | foldr f (x::xs) a = foldr f xs (f a x);
41.16 -(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*)
41.17 -fun ins [] a = [a]
41.18 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.19 -fun sort xs = foldr ins xs [];
41.20 -*)
41.21 -(*-------------------------from InsSort.thy 8.3.01----------------------*)
41.22 -
41.23 -
41.24 -(*-------------------------from InsSort.ML 8.3.01----------------------*)
41.25 -
41.26 -theory' := (!theory') @ [("InsSort.thy",InsSort.thy)];
41.27 -
41.28 -val ins_sort =
41.29 - Rls{preconds = [], rew_ord = ("tless_true",tless_true),
41.30 - rules = [Thm ("foldr_base",(*num_str*) foldr_base),
41.31 - Thm ("foldr_rec",foldr_rec),
41.32 - Thm ("ins_base",ins_base),
41.33 - Thm ("ins_rec",ins_rec),
41.34 - Thm ("sort_def",sort_def),
41.35 -
41.36 - Calc ("op <",eval_equ "#less_"),
41.37 - Thm ("if_True", if_True),
41.38 - Thm ("if_False", if_False)
41.39 - ],
41.40 - scr = Script ((term_of o the o (parse thy))
41.41 - "empty_script")
41.42 - }:rls;
41.43 -
41.44 -
41.45 -
41.46 -
41.47 -(*
41.48 -> get_pbt ["Script.thy","squareroot","univariate","equation"];
41.49 -> get_met ("Script.thy","max_on_interval_by_calculus");
41.50 -*)
41.51 -pbltypes:= (!pbltypes) @
41.52 -[
41.53 - prep_pbt InsSort.thy
41.54 - (["InsSort.thy","inssort"]:pblID,
41.55 - [("#Given" ,"unsorted u_"),
41.56 - ("#Find" ,"sorted s_")
41.57 - ])
41.58 -];
41.59 -
41.60 -methods:= (!methods) @
41.61 -[
41.62 -(*, -------17.6.00,
41.63 - (("InsSort.thy","inssort"):metID,
41.64 - {ppc = prep_met
41.65 - [("#Given" ,"unsorted u_"),
41.66 - ("#Find" ,"sorted s_")
41.67 - ],
41.68 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
41.69 - scr=Script (((inst_abs (assoc_thm "InsSort.thy"))
41.70 - o term_of o the o (parse thy)) (*for [#1,#3,#2] only*)
41.71 - "Script Ins_sort (u_::'a list) = \
41.72 - \ (let u_ = Rewrite sort_def False u_; \
41.73 - \ u_ = Rewrite foldr_rec False u_; \
41.74 - \ u_ = Rewrite ins_base False u_; \
41.75 - \ u_ = Rewrite foldr_rec False u_; \
41.76 - \ u_ = Rewrite ins_rec False u_; \
41.77 - \ u_ = Calculate le u_; \
41.78 - \ u_ = Rewrite if_True False u_; \
41.79 - \ u_ = Rewrite ins_base False u_; \
41.80 - \ u_ = Rewrite foldr_rec False u_; \
41.81 - \ u_ = Rewrite ins_rec False u_; \
41.82 - \ u_ = Calculate le u_; \
41.83 - \ u_ = Rewrite if_True False u_; \
41.84 - \ u_ = Rewrite ins_rec False u_; \
41.85 - \ u_ = Calculate le u_; \
41.86 - \ u_ = Rewrite if_False False u_; \
41.87 - \ u_ = Rewrite foldr_base False u_ \
41.88 - \ in u_)")
41.89 - } : met),
41.90 -
41.91 - (("InsSort.thy","sort"):metID,
41.92 - {ppc = prep_met
41.93 - [("#Given" ,"unsorted u_"),
41.94 - ("#Find" ,"sorted s_")
41.95 - ],
41.96 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
41.97 - scr=Script ((inst_abs o term_of o the o (parse thy))
41.98 - "Script Sort (u_::'a list) = \
41.99 - \ Rewrite_Set ins_sort False u_")
41.100 - } : met)
41.101 -------- *)
41.102 -(*,
41.103 -
41.104 - (("",""):metID,
41.105 - {ppc = prep_met
41.106 - [("#Given" ,""),
41.107 - ("#Find" ,""),
41.108 - ("#Relate","")
41.109 - ],
41.110 - rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
41.111 - scr=EmptyScr} : met),
41.112 -*)
41.113 -];
41.114 -(*-------------------------from InsSort.ML 8.3.01----------------------*)
41.115 -
41.116 -
41.117 -(*------------------------- nipkow ----------------------*)
41.118 -consts
41.119 - sort :: 'a list => 'a list
41.120 - ins :: ['a,'a list] => 'a list
41.121 -(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a
41.122 -*)
41.123 -rules
41.124 - ins_base "ins e [] = [e]"
41.125 - ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))"
41.126 -
41.127 -rules
41.128 - sort_def "sort ls = (foldl ins ls [])"
41.129 -end
41.130 -
41.131 -
41.132 -(** swp: ..L **)
41.133 -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
41.134 -fun foldL f [] e = e
41.135 - | foldL f (l::ls) e = f(l,foldL f ls e);
41.136 -
41.137 -(* fn : int * int list -> int list *)
41.138 -fun insL (e,[]) = [e]
41.139 - | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls);
41.140 -
41.141 -fun sortL ls = foldL insL ls [];
41.142 -
41.143 -sortL [2,3,1]; (* [1,2,3] *)
41.144 -
41.145 -
41.146 -(** swp, curried: ..LC **)
41.147 -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
41.148 -fun foldLC f [] e = e
41.149 - | foldLC f (x::xs) e = f x (foldLC f xs e);
41.150 -
41.151 -(* fn : int * int list -> int list *)
41.152 -fun insLC e [] = [e]
41.153 - | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls);
41.154 -
41.155 -fun sortLC ls = foldLC insLC ls [];
41.156 -
41.157 -sortLC [2,3,1]; (* [1,2,3] *)
41.158 -
41.159 -
41.160 -(** sml110: ..l **)
41.161 -(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *)
41.162 -foldl;
41.163 -(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!!
41.164 -fun foldl f e [] = e
41.165 - | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0
41.166 -
41.167 -foldl op+ (0,[100,11,1]);
41.168 -val it = 0 : int ... GEHT NICHT !!! *)
41.169 -
41.170 -fun insl (e,[]) = [e]
41.171 - | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls);
41.172 -
41.173 -fun sortl ls = foldl insl [] ls;
41.174 -
41.175 -sortl [2,3,1]; (* [1,2,3] *)
41.176 -
41.177 -
41.178 -(** sml110, curried: ..lC **)
41.179 -(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *)
41.180 -fun foldlC f e [] = e
41.181 - | foldlC f e (l::ls) = f e (foldlC f e ls);
41.182 -
41.183 -(* fn : int -> int list -> int list *)
41.184 -fun inslC e [] = [e]
41.185 - | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls);
41.186 -
41.187 -fun sortlC ls = foldlC inslC [] ls;
41.188 -
41.189 -sortlC [2,3,1];
41.190 -
41.191 -(*--- 15.6.00 ---*)
41.192 -
41.193 -
41.194 -fun Foldl f a [] = a
41.195 - | Foldl f a (x::xs) = Foldl f (f a x) xs;
41.196 -(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*)
41.197 -
41.198 -fun add a b = a+b:int;
41.199 -
41.200 -Foldl add 0 [1,2,3];
41.201 -
41.202 -fun ins0 a [] = [a]
41.203 - | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs);
41.204 -(*val ins = fn : int -> int list -> int list*)
41.205 -
41.206 -fun ins [] a = [a]
41.207 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.208 -(*val ins = fn : int -> int list -> int list*)
41.209 -
41.210 -ins 3 [1,2,4];
41.211 -
41.212 -fun sort xs = Foldl ins0 xs [];
41.213 -(*operator domain: int -> int list -> int
41.214 - operand: int -> int list -> int list
41.215 - in expression:
41.216 - Foldl ins
41.217 - *)
41.218 -fun sort xs = Foldl ins xs [];
41.219 -
41.220 -
41.221 -
41.222 -(*--- 17.6.00 ---*)
41.223 -
41.224 -
41.225 -fun foldr f [] a = a
41.226 - | foldr f (x::xs) a = foldr f xs (f a x);
41.227 -(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*)
41.228 -
41.229 -fun add a b = a+b:int;
41.230 -
41.231 -fold add [1,2,3] 0;
41.232 -
41.233 -fun ins [] a = [a]
41.234 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.235 -(*val ins = fn : int list -> int -> int list*)
41.236 -
41.237 -ins [1,2,4] 3;
41.238 -
41.239 -fun sort xs = foldr ins xs [];
41.240 -
41.241 -sort [3,1,4,2];
41.242 -
41.243 -
41.244 -
41.245 -(*--- 17.6.00 II ---*)
41.246 -
41.247 -fun foldl f a [] = a
41.248 - | foldl f a (x::xs) = foldl f (f a x) xs;
41.249 -
41.250 -fun ins [] a = [a]
41.251 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.252 -
41.253 -fun sort xs = foldl ins xs [];
41.254 -
41.255 -sort [3,1,4,2];
41.256 -(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*)
41.257 -
41.258 -(*------------------------- nipkow ----------------------*)
41.259 -consts
41.260 - sort :: 'a list => 'a list
41.261 - ins :: ['a,'a list] => 'a list
41.262 -(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a
41.263 -*)
41.264 -rules
41.265 - ins_base "ins e [] = [e]"
41.266 - ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))"
41.267 -
41.268 -rules
41.269 - sort_def "sort ls = (foldl ins ls [])"
41.270 -end
41.271 -
41.272 -
41.273 -(** swp: ..L **)
41.274 -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
41.275 -fun foldL f [] e = e
41.276 - | foldL f (l::ls) e = f(l,foldL f ls e);
41.277 -
41.278 -(* fn : int * int list -> int list *)
41.279 -fun insL (e,[]) = [e]
41.280 - | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls);
41.281 -
41.282 -fun sortL ls = foldL insL ls [];
41.283 -
41.284 -sortL [2,3,1]; (* [1,2,3] *)
41.285 -
41.286 -
41.287 -(** swp, curried: ..LC **)
41.288 -(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
41.289 -fun foldLC f [] e = e
41.290 - | foldLC f (x::xs) e = f x (foldLC f xs e);
41.291 -
41.292 -(* fn : int * int list -> int list *)
41.293 -fun insLC e [] = [e]
41.294 - | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls);
41.295 -
41.296 -fun sortLC ls = foldLC insLC ls [];
41.297 -
41.298 -sortLC [2,3,1]; (* [1,2,3] *)
41.299 -
41.300 -
41.301 -(** sml110: ..l **)
41.302 -(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *)
41.303 -foldl;
41.304 -(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!!
41.305 -fun foldl f e [] = e
41.306 - | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0
41.307 -
41.308 -foldl op+ (0,[100,11,1]);
41.309 -val it = 0 : int ... GEHT NICHT !!! *)
41.310 -
41.311 -fun insl (e,[]) = [e]
41.312 - | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls);
41.313 -
41.314 -fun sortl ls = foldl insl [] ls;
41.315 -
41.316 -sortl [2,3,1]; (* [1,2,3] *)
41.317 -
41.318 -
41.319 -(** sml110, curried: ..lC **)
41.320 -(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *)
41.321 -fun foldlC f e [] = e
41.322 - | foldlC f e (l::ls) = f e (foldlC f e ls);
41.323 -
41.324 -(* fn : int -> int list -> int list *)
41.325 -fun inslC e [] = [e]
41.326 - | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls);
41.327 -
41.328 -fun sortlC ls = foldlC inslC [] ls;
41.329 -
41.330 -sortlC [2,3,1];
41.331 -
41.332 -(*--- 15.6.00 ---*)
41.333 -
41.334 -
41.335 -fun Foldl f a [] = a
41.336 - | Foldl f a (x::xs) = Foldl f (f a x) xs;
41.337 -(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*)
41.338 -
41.339 -fun add a b = a+b:int;
41.340 -
41.341 -Foldl add 0 [1,2,3];
41.342 -
41.343 -fun ins0 a [] = [a]
41.344 - | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs);
41.345 -(*val ins = fn : int -> int list -> int list*)
41.346 -
41.347 -fun ins [] a = [a]
41.348 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.349 -(*val ins = fn : int -> int list -> int list*)
41.350 -
41.351 -ins 3 [1,2,4];
41.352 -
41.353 -fun sort xs = Foldl ins0 xs [];
41.354 -(*operator domain: int -> int list -> int
41.355 - operand: int -> int list -> int list
41.356 - in expression:
41.357 - Foldl ins
41.358 - *)
41.359 -fun sort xs = Foldl ins xs [];
41.360 -
41.361 -
41.362 -
41.363 -(*--- 17.6.00 ---*)
41.364 -
41.365 -
41.366 -fun foldr f [] a = a
41.367 - | foldr f (x::xs) a = foldr f xs (f a x);
41.368 -(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*)
41.369 -
41.370 -fun add a b = a+b:int;
41.371 -
41.372 -fold add [1,2,3] 0;
41.373 -
41.374 -fun ins [] a = [a]
41.375 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.376 -(*val ins = fn : int list -> int -> int list*)
41.377 -
41.378 -ins [1,2,4] 3;
41.379 -
41.380 -fun sort xs = foldr ins xs [];
41.381 -
41.382 -sort [3,1,4,2];
41.383 -
41.384 -
41.385 -
41.386 -(*--- 17.6.00 II ---*)
41.387 -
41.388 -fun foldl f a [] = a
41.389 - | foldl f a (x::xs) = foldl f (f a x) xs;
41.390 -
41.391 -fun ins [] a = [a]
41.392 - | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
41.393 -
41.394 -fun sort xs = foldl ins xs [];
41.395 -
41.396 -sort [3,1,4,2];
41.397 -(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*)
41.398 -(*------------------------- nipkow ----------------------*)
42.1 --- a/src/Tools/isac/IsacKnowledge/InsSort.thy Wed Aug 25 15:15:01 2010 +0200
42.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
42.3 @@ -1,63 +0,0 @@
42.4 -(* 6.8.02 change to Isabelle2002 caused error -- thy excluded !
42.5 -
42.6 -Proving equations for primrec function(s) "InsSort.foldr" ...
42.7 -GC #1.17.30.54.345.21479: (10 ms)
42.8 -*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list"
42.9 -*** imposes additional sort constraints on the declared type of the constant
42.10 -*** The error(s) above occurred in definition "InsSort.ins.ins_list_def (@@@)"
42.11 -*)
42.12 -
42.13 -(* insertion sort, would need lists different from script-lists WN.11.00
42.14 -WN.7.5.03: -"- started with someList :: 'a list => unl, fun dest_list
42.15 -WN.8.5.03: error (@@@) remained with outcommenting foldr ?!?
42.16 -
42.17 - use_thy_only"IsacKnowledge/InsSort";
42.18 -
42.19 -*)
42.20 -
42.21 -InsSort = Script +
42.22 -
42.23 -consts
42.24 -
42.25 -(*foldr :: [['a,'b] => 'a, 'b list, 'a] => 'a
42.26 -WN.8.5.03: already defined in Isabelle2002 (instantiated by Typefix):
42.27 - "[[real, real] => real, real list, real] => real") : term
42.28 -
42.29 - val t = str2term "foldr";
42.30 -val t =
42.31 - Const
42.32 - ("List.foldr",
42.33 - "[[RealDef.real, RealDef.real] => RealDef.real, RealDef.real List.list,
42.34 - RealDef.real] => RealDef.real") : term
42.35 - *)
42.36 - ins :: ['a list,'a] => 'a list
42.37 - sort :: 'a list => 'a list
42.38 -
42.39 -(*descriptions, script-id*)
42.40 - unsorted :: 'a list => unl
42.41 - sorted :: 'a list => unl
42.42 -
42.43 -(*subproblem and script-name*)
42.44 - Ins'_sort :: "['a list, \
42.45 - \ 'a list] => 'a list"
42.46 - ("((Script Ins'_sort (_ =))// \
42.47 - \ (_))" 9)
42.48 - Sort :: "['a list, \
42.49 - \ 'a list] => 'a list"
42.50 - ("((Script Sort (_ =))// \
42.51 - \ (_))" 9)
42.52 -
42.53 -(*primrec
42.54 - foldr_base "foldr f [] a = a"
42.55 - foldr_rec "foldr f (x#xs) a = foldr f xs (f a x)"
42.56 -*)
42.57 -
42.58 -rules
42.59 -
42.60 -(*primrec .. outcommented analoguous to ListG.thy*)
42.61 - ins_base "ins [] a = [a]"
42.62 - ins_rec "ins (x#xs) a = (if x < a then x#(ins xs a) else a#(x#xs))"
42.63 -
42.64 - sort_def "sort ls = foldr ins ls []"
42.65 -
42.66 -end
43.1 --- a/src/Tools/isac/IsacKnowledge/Integrate.ML Wed Aug 25 15:15:01 2010 +0200
43.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
43.3 @@ -1,357 +0,0 @@
43.4 -(* tools for integration over the reals
43.5 - author: Walther Neuper 050905, 08:51
43.6 - (c) due to copyright terms
43.7 -
43.8 -use"IsacKnowledge/Integrate.ML";
43.9 -use"Integrate.ML";
43.10 -
43.11 -remove_thy"Integrate";
43.12 -use_thy"IsacKnowledge/Isac";
43.13 -*)
43.14 -
43.15 -(** interface isabelle -- isac **)
43.16 -
43.17 -theory' := overwritel (!theory', [("Integrate.thy",Integrate.thy)]);
43.18 -
43.19 -(** eval functions **)
43.20 -
43.21 -val c = Free ("c", HOLogic.realT);
43.22 -(*.create a new unique variable 'c..' in a term; for use by Calc in a rls;
43.23 - an alternative to do this would be '(Try (Calculate new_c_) (new_c es__))'
43.24 - in the script; this will be possible if currying doesnt take the value
43.25 - from a variable, but the value '(new_c es__)' itself.*)
43.26 -fun new_c term =
43.27 - let fun selc var =
43.28 - case (explode o id_of) var of
43.29 - "c"::[] => true
43.30 - | "c"::"_"::is => (case (int_of_str o implode) is of
43.31 - SOME _ => true
43.32 - | NONE => false)
43.33 - | _ => false;
43.34 - fun get_coeff c = case (explode o id_of) c of
43.35 - "c"::"_"::is => (the o int_of_str o implode) is
43.36 - | _ => 0;
43.37 - val cs = filter selc (vars term);
43.38 - in
43.39 - case cs of
43.40 - [] => c
43.41 - | [c] => Free ("c_2", HOLogic.realT)
43.42 - | cs =>
43.43 - let val max_coeff = maxl (map get_coeff cs)
43.44 - in Free ("c_"^string_of_int (max_coeff + 1), HOLogic.realT) end
43.45 - end;
43.46 -
43.47 -(*WN080222
43.48 -(*("new_c", ("Integrate.new'_c", eval_new_c "#new_c_"))*)
43.49 -fun eval_new_c _ _ (p as (Const ("Integrate.new'_c",_) $ t)) _ =
43.50 - SOME ((term2str p) ^ " = " ^ term2str (new_c p),
43.51 - Trueprop $ (mk_equality (p, new_c p)))
43.52 - | eval_new_c _ _ _ _ = NONE;
43.53 -*)
43.54 -
43.55 -(*WN080222:*)
43.56 -(*("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "#add_new_c_"))
43.57 - add a new c to a term or a fun-equation;
43.58 - this is _not in_ the term, because only applied to _whole_ term*)
43.59 -fun eval_add_new_c (_:string) "Integrate.add'_new'_c" p (_:theory) =
43.60 - let val p' = case p of
43.61 - Const ("op =", T) $ lh $ rh =>
43.62 - Const ("op =", T) $ lh $ mk_add rh (new_c rh)
43.63 - | p => mk_add p (new_c p)
43.64 - in SOME ((term2str p) ^ " = " ^ term2str p',
43.65 - Trueprop $ (mk_equality (p, p')))
43.66 - end
43.67 - | eval_add_new_c _ _ _ _ = NONE;
43.68 -
43.69 -
43.70 -(*("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_x_"))*)
43.71 -fun eval_is_f_x _ _(p as (Const ("Integrate.is'_f'_x", _)
43.72 - $ arg)) _ =
43.73 - if is_f_x arg
43.74 - then SOME ((term2str p) ^ " = True",
43.75 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
43.76 - else SOME ((term2str p) ^ " = False",
43.77 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
43.78 - | eval_is_f_x _ _ _ _ = NONE;
43.79 -
43.80 -calclist':= overwritel (!calclist',
43.81 - [(*("new_c", ("Integrate.new'_c", eval_new_c "new_c_")),*)
43.82 - ("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_")),
43.83 - ("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_idextifier_"))
43.84 - ]);
43.85 -
43.86 -
43.87 -(** rulesets **)
43.88 -
43.89 -(*.rulesets for integration.*)
43.90 -val integration_rules =
43.91 - Rls {id="integration_rules", preconds = [],
43.92 - rew_ord = ("termlessI",termlessI),
43.93 - erls = Rls {id="conditions_in_integration_rules",
43.94 - preconds = [],
43.95 - rew_ord = ("termlessI",termlessI),
43.96 - erls = Erls,
43.97 - srls = Erls, calc = [],
43.98 - rules = [(*for rewriting conditions in Thm's*)
43.99 - Calc ("Atools.occurs'_in",
43.100 - eval_occurs_in "#occurs_in_"),
43.101 - Thm ("not_true",num_str not_true),
43.102 - Thm ("not_false",not_false)
43.103 - ],
43.104 - scr = EmptyScr},
43.105 - srls = Erls, calc = [],
43.106 - rules = [
43.107 - Thm ("integral_const",num_str integral_const),
43.108 - Thm ("integral_var",num_str integral_var),
43.109 - Thm ("integral_add",num_str integral_add),
43.110 - Thm ("integral_mult",num_str integral_mult),
43.111 - Thm ("integral_pow",num_str integral_pow),
43.112 - Calc ("op +", eval_binop "#add_")(*for n+1*)
43.113 - ],
43.114 - scr = EmptyScr};
43.115 -val add_new_c =
43.116 - Seq {id="add_new_c", preconds = [],
43.117 - rew_ord = ("termlessI",termlessI),
43.118 - erls = Rls {id="conditions_in_add_new_c",
43.119 - preconds = [],
43.120 - rew_ord = ("termlessI",termlessI),
43.121 - erls = Erls,
43.122 - srls = Erls, calc = [],
43.123 - rules = [Calc ("Tools.matches", eval_matches""),
43.124 - Calc ("Integrate.is'_f'_x",
43.125 - eval_is_f_x "is_f_x_"),
43.126 - Thm ("not_true",num_str not_true),
43.127 - Thm ("not_false",num_str not_false)
43.128 - ],
43.129 - scr = EmptyScr},
43.130 - srls = Erls, calc = [],
43.131 - rules = [ (*Thm ("call_for_new_c", num_str call_for_new_c),*)
43.132 - Cal1 ("Integrate.add'_new'_c", eval_add_new_c "new_c_")
43.133 - ],
43.134 - scr = EmptyScr};
43.135 -
43.136 -(*.rulesets for simplifying Integrals.*)
43.137 -
43.138 -(*.for simplify_Integral adapted from 'norm_Rational_rls'.*)
43.139 -val norm_Rational_rls_noadd_fractions =
43.140 -Rls {id = "norm_Rational_rls_noadd_fractions", preconds = [],
43.141 - rew_ord = ("dummy_ord",dummy_ord),
43.142 - erls = norm_rat_erls, srls = Erls, calc = [],
43.143 - rules = [(*Rls_ common_nominator_p_rls,!!!*)
43.144 - Rls_ (*rat_mult_div_pow original corrected WN051028*)
43.145 - (Rls {id = "rat_mult_div_pow", preconds = [],
43.146 - rew_ord = ("dummy_ord",dummy_ord),
43.147 - erls = (*FIXME.WN051028 e_rls,*)
43.148 - append_rls "e_rls-is_polyexp" e_rls
43.149 - [Calc ("Poly.is'_polyexp",
43.150 - eval_is_polyexp "")],
43.151 - srls = Erls, calc = [],
43.152 - rules = [Thm ("rat_mult",num_str rat_mult),
43.153 - (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
43.154 - Thm ("rat_mult_poly_l",num_str rat_mult_poly_l),
43.155 - (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*)
43.156 - Thm ("rat_mult_poly_r",num_str rat_mult_poly_r),
43.157 - (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*)
43.158 -
43.159 - Thm ("real_divide_divide1_mg", real_divide_divide1_mg),
43.160 - (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*)
43.161 - Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
43.162 - (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
43.163 - Thm ("real_divide_divide2_eq", real_divide_divide2_eq),
43.164 - (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
43.165 - Calc ("HOL.divide" ,eval_cancel "#divide_"),
43.166 -
43.167 - Thm ("rat_power", num_str rat_power)
43.168 - (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
43.169 - ],
43.170 - scr = Script ((term_of o the o (parse thy)) "empty_script")
43.171 - }),
43.172 - Rls_ make_rat_poly_with_parentheses,
43.173 - Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*)
43.174 - Rls_ rat_reduce_1
43.175 - ],
43.176 - scr = Script ((term_of o the o (parse thy)) "empty_script")
43.177 - }:rls;
43.178 -
43.179 -(*.for simplify_Integral adapted from 'norm_Rational'.*)
43.180 -val norm_Rational_noadd_fractions =
43.181 - Seq {id = "norm_Rational_noadd_fractions", preconds = [],
43.182 - rew_ord = ("dummy_ord",dummy_ord),
43.183 - erls = norm_rat_erls, srls = Erls, calc = [],
43.184 - rules = [Rls_ discard_minus_,
43.185 - Rls_ rat_mult_poly,(* removes double fractions like a/b/c *)
43.186 - Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*)
43.187 - Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*)
43.188 - Rls_ norm_Rational_rls_noadd_fractions,(* the main rls (#) *)
43.189 - Rls_ discard_parentheses_ (* mult only *)
43.190 - ],
43.191 - scr = Script ((term_of o the o (parse thy)) "empty_script")
43.192 - }:rls;
43.193 -
43.194 -(*.simplify terms before and after Integration such that
43.195 - ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO
43.196 - common denominator as done by norm_Rational or make_ratpoly_in.
43.197 - This is a copy from 'make_ratpoly_in' with respective reduction of rules and
43.198 - *1* expand the term, ie. distribute * and / over +
43.199 -.*)
43.200 -val separate_bdv2 =
43.201 - append_rls "separate_bdv2"
43.202 - collect_bdv
43.203 - [Thm ("separate_bdv", num_str separate_bdv),
43.204 - (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*)
43.205 - Thm ("separate_bdv_n", num_str separate_bdv_n),
43.206 - Thm ("separate_1_bdv", num_str separate_1_bdv),
43.207 - (*"?bdv / ?b = (1 / ?b) * ?bdv"*)
43.208 - Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*,
43.209 - (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*)
43.210 - *****Thm ("real_add_divide_distrib",
43.211 - *****num_str real_add_divide_distrib)
43.212 - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)----------*)
43.213 - ];
43.214 -val simplify_Integral =
43.215 - Seq {id = "simplify_Integral", preconds = []:term list,
43.216 - rew_ord = ("dummy_ord", dummy_ord),
43.217 - erls = Atools_erls, srls = Erls,
43.218 - calc = [], (*asm_thm = [],*)
43.219 - rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib),
43.220 - (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*)
43.221 - Thm ("real_add_divide_distrib",num_str real_add_divide_distrib),
43.222 - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)
43.223 - (*^^^^^ *1* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*)
43.224 - Rls_ norm_Rational_noadd_fractions,
43.225 - Rls_ order_add_mult_in,
43.226 - Rls_ discard_parentheses,
43.227 - (*Rls_ collect_bdv, from make_polynomial_in*)
43.228 - Rls_ separate_bdv2,
43.229 - Calc ("HOL.divide" ,eval_cancel "#divide_")
43.230 - ],
43.231 - scr = EmptyScr}:rls;
43.232 -
43.233 -
43.234 -(*simplify terms before and after Integration such that
43.235 - ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO
43.236 - common denominator as done by norm_Rational or make_ratpoly_in.
43.237 - This is a copy from 'make_polynomial_in' with insertions from
43.238 - 'make_ratpoly_in'
43.239 -THIS IS KEPT FOR COMPARISON ............................................
43.240 -* val simplify_Integral = prep_rls(
43.241 -* Seq {id = "", preconds = []:term list,
43.242 -* rew_ord = ("dummy_ord", dummy_ord),
43.243 -* erls = Atools_erls, srls = Erls,
43.244 -* calc = [], (*asm_thm = [],*)
43.245 -* rules = [Rls_ expand_poly,
43.246 -* Rls_ order_add_mult_in,
43.247 -* Rls_ simplify_power,
43.248 -* Rls_ collect_numerals,
43.249 -* Rls_ reduce_012,
43.250 -* Thm ("realpow_oneI",num_str realpow_oneI),
43.251 -* Rls_ discard_parentheses,
43.252 -* Rls_ collect_bdv,
43.253 -* (*below inserted from 'make_ratpoly_in'*)
43.254 -* Rls_ (append_rls "separate_bdv"
43.255 -* collect_bdv
43.256 -* [Thm ("separate_bdv", num_str separate_bdv),
43.257 -* (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*)
43.258 -* Thm ("separate_bdv_n", num_str separate_bdv_n),
43.259 -* Thm ("separate_1_bdv", num_str separate_1_bdv),
43.260 -* (*"?bdv / ?b = (1 / ?b) * ?bdv"*)
43.261 -* Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*,
43.262 -* (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*)
43.263 -* Thm ("real_add_divide_distrib",
43.264 -* num_str real_add_divide_distrib)
43.265 -* (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)*)
43.266 -* ]),
43.267 -* Calc ("HOL.divide" ,eval_cancel "#divide_")
43.268 -* ],
43.269 -* scr = EmptyScr
43.270 -* }:rls);
43.271 -.......................................................................*)
43.272 -
43.273 -val integration =
43.274 - Seq {id="integration", preconds = [],
43.275 - rew_ord = ("termlessI",termlessI),
43.276 - erls = Rls {id="conditions_in_integration",
43.277 - preconds = [],
43.278 - rew_ord = ("termlessI",termlessI),
43.279 - erls = Erls,
43.280 - srls = Erls, calc = [],
43.281 - rules = [],
43.282 - scr = EmptyScr},
43.283 - srls = Erls, calc = [],
43.284 - rules = [ Rls_ integration_rules,
43.285 - Rls_ add_new_c,
43.286 - Rls_ simplify_Integral
43.287 - ],
43.288 - scr = EmptyScr};
43.289 -ruleset' :=
43.290 -overwritelthy thy (!ruleset',
43.291 - [("integration_rules", prep_rls integration_rules),
43.292 - ("add_new_c", prep_rls add_new_c),
43.293 - ("simplify_Integral", prep_rls simplify_Integral),
43.294 - ("integration", prep_rls integration),
43.295 - ("separate_bdv2", separate_bdv2),
43.296 - ("norm_Rational_noadd_fractions", norm_Rational_noadd_fractions),
43.297 - ("norm_Rational_rls_noadd_fractions",
43.298 - norm_Rational_rls_noadd_fractions)
43.299 - ]);
43.300 -
43.301 -(** problems **)
43.302 -
43.303 -store_pbt
43.304 - (prep_pbt Integrate.thy "pbl_fun_integ" [] e_pblID
43.305 - (["integrate","function"],
43.306 - [("#Given" ,["functionTerm f_", "integrateBy v_"]),
43.307 - ("#Find" ,["antiDerivative F_"])
43.308 - ],
43.309 - append_rls "e_rls" e_rls [(*for preds in where_*)],
43.310 - SOME "Integrate (f_, v_)",
43.311 - [["diff","integration"]]));
43.312 -
43.313 -(*here "named" is used differently from Differentiation"*)
43.314 -store_pbt
43.315 - (prep_pbt Integrate.thy "pbl_fun_integ_nam" [] e_pblID
43.316 - (["named","integrate","function"],
43.317 - [("#Given" ,["functionTerm f_", "integrateBy v_"]),
43.318 - ("#Find" ,["antiDerivativeName F_"])
43.319 - ],
43.320 - append_rls "e_rls" e_rls [(*for preds in where_*)],
43.321 - SOME "Integrate (f_, v_)",
43.322 - [["diff","integration","named"]]));
43.323 -
43.324 -(** methods **)
43.325 -
43.326 -store_met
43.327 - (prep_met Integrate.thy "met_diffint" [] e_metID
43.328 - (["diff","integration"],
43.329 - [("#Given" ,["functionTerm f_", "integrateBy v_"]),
43.330 - ("#Find" ,["antiDerivative F_"])
43.331 - ],
43.332 - {rew_ord'="tless_true", rls'=Atools_erls, calc = [],
43.333 - srls = e_rls,
43.334 - prls=e_rls,
43.335 - crls = Atools_erls, nrls = e_rls},
43.336 -"Script IntegrationScript (f_::real) (v_::real) = \
43.337 -\ (let t_ = Take (Integral f_ D v_) \
43.338 -\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) (t_::real))"
43.339 -));
43.340 -
43.341 -store_met
43.342 - (prep_met Integrate.thy "met_diffint_named" [] e_metID
43.343 - (["diff","integration","named"],
43.344 - [("#Given" ,["functionTerm f_", "integrateBy v_"]),
43.345 - ("#Find" ,["antiDerivativeName F_"])
43.346 - ],
43.347 - {rew_ord'="tless_true", rls'=Atools_erls, calc = [],
43.348 - srls = e_rls,
43.349 - prls=e_rls,
43.350 - crls = Atools_erls, nrls = e_rls},
43.351 -"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \
43.352 -\ (let t_ = Take (F_ v_ = Integral f_ D v_) \
43.353 -\ in ((Try (Rewrite_Set_Inst [(bdv,v_)] simplify_Integral False)) @@\
43.354 -\ (Rewrite_Set_Inst [(bdv,v_)] integration False)) t_)"
43.355 -(*
43.356 -"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \
43.357 -\ (let t_ = Take (F_ v_ = Integral f_ D v_) \
43.358 -\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) t_)"
43.359 -*)
43.360 - ));
44.1 --- a/src/Tools/isac/IsacKnowledge/Integrate.thy Wed Aug 25 15:15:01 2010 +0200
44.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
44.3 @@ -1,54 +0,0 @@
44.4 -(* integration over the reals
44.5 - author: Walther Neuper
44.6 - 050814, 08:51
44.7 - (c) due to copyright terms
44.8 -
44.9 -remove_thy"Integrate";
44.10 -use_thy"IsacKnowledge/Integrate";
44.11 -use_thy_only"IsacKnowledge/Integrate";
44.12 -
44.13 -remove_thy"Typefix";
44.14 -use_thy"IsacKnowledge/Isac";
44.15 -*)
44.16 -
44.17 -Integrate = Diff +
44.18 -
44.19 -consts
44.20 -
44.21 - Integral :: "[real, real]=> real" ("Integral _ D _" 91)
44.22 -(*new'_c :: "real => real" ("new'_c _" 66)*)
44.23 - is'_f'_x :: "real => bool" ("_ is'_f'_x" 10)
44.24 -
44.25 - (*descriptions in the related problems*)
44.26 - integrateBy :: real => una
44.27 - antiDerivative :: real => una
44.28 - antiDerivativeName :: (real => real) => una
44.29 -
44.30 - (*the CAS-command, eg. "Integrate (2*x^^^3, x)"*)
44.31 - Integrate :: "[real * real] => real"
44.32 -
44.33 - (*Script-names*)
44.34 - IntegrationScript :: "[real,real, real] => real"
44.35 - ("((Script IntegrationScript (_ _ =))// (_))" 9)
44.36 - NamedIntegrationScript :: "[real,real, real=>real, bool] => bool"
44.37 - ("((Script NamedIntegrationScript (_ _ _=))// (_))" 9)
44.38 -
44.39 -rules
44.40 -(*stated as axioms, todo: prove as theorems
44.41 - 'bdv' is a constant handled on the meta-level
44.42 - specifically as a 'bound variable' *)
44.43 -
44.44 - integral_const "Not (bdv occurs_in u) ==> Integral u D bdv = u * bdv"
44.45 - integral_var "Integral bdv D bdv = bdv ^^^ 2 / 2"
44.46 -
44.47 - integral_add "Integral (u + v) D bdv = \
44.48 - \(Integral u D bdv) + (Integral v D bdv)"
44.49 - integral_mult "[| Not (bdv occurs_in u); bdv occurs_in v |] ==> \
44.50 - \Integral (u * v) D bdv = u * (Integral v D bdv)"
44.51 -(*WN080222: this goes into sub-terms, too ...
44.52 - call_for_new_c "[| Not (matches (u + new_c v) a); Not (a is_f_x) |] ==> \
44.53 - \a = a + new_c a"
44.54 -*)
44.55 - integral_pow "Integral bdv ^^^ n D bdv = bdv ^^^ (n+1) / (n + 1)"
44.56 -
44.57 -end
44.58 \ No newline at end of file
45.1 --- a/src/Tools/isac/IsacKnowledge/Isac.ML Wed Aug 25 15:15:01 2010 +0200
45.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
45.3 @@ -1,37 +0,0 @@
45.4 -(* collect all knowledge defined in theories so far
45.5 - author: Walther Neuper 0003
45.6 - (c) isac-team
45.7 -
45.8 -use"IsacKnowledge/Isac.ML";
45.9 -use"Isac.ML";
45.10 - *)
45.11 -
45.12 -
45.13 -theory' := overwritel (!theory', [("Isac.thy",Isac.thy)]);
45.14 -
45.15 -
45.16 -(**.set up a list for getting guh + theID for a thm (defined in isabelle).**)
45.17 -
45.18 -(*.get all theorems used by isac and defined in isabelle.*)
45.19 -local
45.20 - val isacrlsthms = ((gen_distinct eq_thmI) o (map rep_thm_G') o flat o
45.21 - (map (thms_of_rls o #2 o #2))) (!ruleset');
45.22 - val isacthms = (flat o (map (PureThy.all_thms_of o #2))) (!theory');
45.23 -in
45.24 - val rlsthmsNOTisac = gen_diff eq_thmI (isacrlsthms, isacthms);
45.25 -end;
45.26 -
45.27 -(*.set up the list using 'val first_isac_thy' (see ListG.ML).*)
45.28 -isab_thm_thy := make_isab rlsthmsNOTisac
45.29 - ((#ancestors o rep_theory) first_isac_thy);
45.30 -
45.31 -
45.32 -(*.create the hierarchy of theory elements from IsacKnowledge
45.33 - including thms from Isabelle used in rls;
45.34 - elements store_*d in any *.ML are not overwritten.*)
45.35 -
45.36 -thehier := the_hier (!thehier) (collect_thydata ());
45.37 -writeln("----------------------------------\n\
45.38 - \*** insert: not found ... IS OK : \n\
45.39 - \comes from fill_parents \n\
45.40 - \----------------------------------\n");
46.1 --- a/src/Tools/isac/IsacKnowledge/Isac.thy Wed Aug 25 15:15:01 2010 +0200
46.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
46.3 @@ -1,21 +0,0 @@
46.4 -(* theory collecting all knowledge defined so far
46.5 - WN.11.00
46.6 - *)
46.7 -
46.8 -Isac = PolyMinus + PolyEq + Vect + DiffApp + Biegelinie + AlgEin
46.9 - + (*InsSort +*) Test +
46.10 -
46.11 -end
46.12 -
46.13 -(* dependencies alternative to those defined by R.Lang during his thesis:
46.14 -
46.15 - Poly Root
46.16 - |\__________ |
46.17 - | \ |
46.18 - | Rational |
46.19 - | | |
46.20 - PolyEq RatEq RootEq
46.21 - \ / \ /
46.22 - \ / \ /
46.23 - RatPolyEq RatRootEq etc.
46.24 -*)
47.1 --- a/src/Tools/isac/IsacKnowledge/LinEq.ML Wed Aug 25 15:15:01 2010 +0200
47.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
47.3 @@ -1,171 +0,0 @@
47.4 -(*. (c) by Richard Lang, 2003 .*)
47.5 -(* collecting all knowledge for LinearEquations
47.6 - created by: rlang
47.7 - date: 02.10
47.8 - changed by: rlang
47.9 - last change by: rlang
47.10 - date: 02.11.04
47.11 -*)
47.12 -
47.13 -(* remove_thy"LinEq";
47.14 - use_thy"IsacKnowledge/Isac";
47.15 -
47.16 - use_thy"IsacKnowledge/LinEq";
47.17 -
47.18 - use"ROOT.ML";
47.19 - cd"knowledge";
47.20 -*)
47.21 -
47.22 -"******* LinEq.ML begin *******";
47.23 -
47.24 -(*-------------------- theory -------------------------------------------------*)
47.25 -theory' := overwritel (!theory', [("LinEq.thy",LinEq.thy)]);
47.26 -
47.27 -(*-------------- rules -------------------------------------------------------*)
47.28 -val LinEq_prls = (*3.10.02:just the following order due to subterm evaluation*)
47.29 - append_rls "LinEq_prls" e_rls
47.30 - [Calc ("op =",eval_equal "#equal_"),
47.31 - Calc ("Tools.matches",eval_matches ""),
47.32 - Calc ("Tools.lhs" ,eval_lhs ""),
47.33 - Calc ("Tools.rhs" ,eval_rhs ""),
47.34 - Calc ("Poly.has'_degree'_in",eval_has_degree_in ""),
47.35 - Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""),
47.36 - Calc ("Atools.occurs'_in",eval_occurs_in ""),
47.37 - Calc ("Atools.ident",eval_ident "#ident_"),
47.38 - Thm ("not_true",num_str not_true),
47.39 - Thm ("not_false",num_str not_false),
47.40 - Thm ("and_true",num_str and_true),
47.41 - Thm ("and_false",num_str and_false),
47.42 - Thm ("or_true",num_str or_true),
47.43 - Thm ("or_false",num_str or_false)
47.44 - ];
47.45 -(* ----- erls ----- *)
47.46 -val LinEq_crls =
47.47 - append_rls "LinEq_crls" poly_crls
47.48 - [Thm ("real_assoc_1",num_str real_assoc_1)
47.49 - (*
47.50 - Don't use
47.51 - Calc ("HOL.divide", eval_cancel "#divide_"),
47.52 - Calc ("Atools.pow" ,eval_binop "#power_"),
47.53 - *)
47.54 - ];
47.55 -
47.56 -(* ----- crls ----- *)
47.57 -val LinEq_erls =
47.58 - append_rls "LinEq_erls" Poly_erls
47.59 - [Thm ("real_assoc_1",num_str real_assoc_1)
47.60 - (*
47.61 - Don't use
47.62 - Calc ("HOL.divide", eval_cancel "#divide_"),
47.63 - Calc ("Atools.pow" ,eval_binop "#power_"),
47.64 - *)
47.65 - ];
47.66 -
47.67 -ruleset' := overwritelthy thy (!ruleset',
47.68 - [("LinEq_erls",LinEq_erls)(*FIXXXME:del with rls.rls'*)
47.69 - ]);
47.70 -
47.71 -val LinPoly_simplify = prep_rls(
47.72 - Rls {id = "LinPoly_simplify", preconds = [],
47.73 - rew_ord = ("termlessI",termlessI),
47.74 - erls = LinEq_erls,
47.75 - srls = Erls,
47.76 - calc = [],
47.77 - (*asm_thm = [],*)
47.78 - rules = [
47.79 - Thm ("real_assoc_1",num_str real_assoc_1),
47.80 - Calc ("op +",eval_binop "#add_"),
47.81 - Calc ("op -",eval_binop "#sub_"),
47.82 - Calc ("op *",eval_binop "#mult_"),
47.83 - (* Dont use
47.84 - Calc ("HOL.divide", eval_cancel "#divide_"),
47.85 - Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
47.86 - *)
47.87 - Calc ("Atools.pow" ,eval_binop "#power_")
47.88 - ],
47.89 - scr = Script ((term_of o the o (parse thy)) "empty_script")
47.90 - }:rls);
47.91 -ruleset' := overwritelthy thy (!ruleset',
47.92 - [("LinPoly_simplify",LinPoly_simplify)]);
47.93 -
47.94 -(*isolate the bound variable in an linear equation; 'bdv' is a meta-constant*)
47.95 -val LinEq_simplify = prep_rls(
47.96 -Rls {id = "LinEq_simplify", preconds = [],
47.97 - rew_ord = ("e_rew_ord",e_rew_ord),
47.98 - erls = LinEq_erls,
47.99 - srls = Erls,
47.100 - calc = [],
47.101 - (*asm_thm = [("lin_isolate_div","")],*)
47.102 - rules = [
47.103 - Thm("lin_isolate_add1",num_str lin_isolate_add1),
47.104 - (* a+bx=0 -> bx=-a *)
47.105 - Thm("lin_isolate_add2",num_str lin_isolate_add2),
47.106 - (* a+ x=0 -> x=-a *)
47.107 - Thm("lin_isolate_div",num_str lin_isolate_div)
47.108 - (* bx=c -> x=c/b *)
47.109 - ],
47.110 - scr = Script ((term_of o the o (parse thy)) "empty_script")
47.111 - }:rls);
47.112 -ruleset' := overwritelthy thy (!ruleset',
47.113 - [("LinEq_simplify",LinEq_simplify)]);
47.114 -
47.115 -(*----------------------------- problem types --------------------------------*)
47.116 -(*
47.117 -show_ptyps();
47.118 -(get_pbt ["linear","univariate","equation"]);
47.119 -*)
47.120 -(* ---------linear----------- *)
47.121 -store_pbt
47.122 - (prep_pbt LinEq.thy "pbl_equ_univ_lin" [] e_pblID
47.123 - (["linear","univariate","equation"],
47.124 - [("#Given" ,["equality e_","solveFor v_"]),
47.125 - ("#Where" ,["False", (*WN0509 just detected: this pbl can never be used?!?*)
47.126 - "Not( (lhs e_) is_polyrat_in v_)",
47.127 - "Not( (rhs e_) is_polyrat_in v_)",
47.128 - "((lhs e_) has_degree_in v_)=1",
47.129 - "((rhs e_) has_degree_in v_)=1"]),
47.130 - ("#Find" ,["solutions v_i_"])
47.131 - ],
47.132 - LinEq_prls, SOME "solve (e_::bool, v_)",
47.133 - [["LinEq","solve_lineq_equation"]]));
47.134 -
47.135 -(*-------------- methods-------------------------------------------------------*)
47.136 -store_met
47.137 - (prep_met LinEq.thy "met_eqlin" [] e_metID
47.138 - (["LinEq"],
47.139 - [],
47.140 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
47.141 - crls=LinEq_crls, nrls=norm_Poly
47.142 - (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
47.143 -
47.144 -(* ansprechen mit ["LinEq","solve_univar_equation"] *)
47.145 -store_met
47.146 -(prep_met LinEq.thy "met_eq_lin" [] e_metID
47.147 - (["LinEq","solve_lineq_equation"],
47.148 - [("#Given" ,["equality e_","solveFor v_"]),
47.149 - ("#Where" ,["Not( (lhs e_) is_polyrat_in v_)",
47.150 - "( (lhs e_) has_degree_in v_)=1"]),
47.151 - ("#Find" ,["solutions v_i_"])
47.152 - ],
47.153 - {rew_ord'="termlessI",
47.154 - rls'=LinEq_erls,
47.155 - srls=e_rls,
47.156 - prls=LinEq_prls,
47.157 - calc=[],
47.158 - crls=LinEq_crls, nrls=norm_Poly(*,
47.159 - asm_rls=[],
47.160 - asm_thm=[("lin_isolate_div","")]*)},
47.161 - "Script Solve_lineq_equation (e_::bool) (v_::real) = \
47.162 - \(let e_ =((Try (Rewrite all_left False)) @@ \
47.163 - \ (Try (Repeat (Rewrite makex1_x False))) @@ \
47.164 - \ (Try (Rewrite_Set expand_binoms False)) @@ \
47.165 - \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \
47.166 - \ make_ratpoly_in False))) @@ \
47.167 - \ (Try (Repeat (Rewrite_Set LinPoly_simplify False)))) e_;\
47.168 - \ e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
47.169 - \ LinEq_simplify True)) @@ \
47.170 - \ (Repeat(Try (Rewrite_Set LinPoly_simplify False)))) e_ \
47.171 - \ in ((Or_to_List e_)::bool list))"
47.172 - ));
47.173 -"******* LinEq.ML end *******";
47.174 -get_met ["LinEq","solve_lineq_equation"];
48.1 --- a/src/Tools/isac/IsacKnowledge/LinEq.thy Wed Aug 25 15:15:01 2010 +0200
48.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
48.3 @@ -1,50 +0,0 @@
48.4 -(*. (c) by Richard Lang, 2003 .*)
48.5 -(* theory collecting all knowledge for LinearEquations
48.6 - created by: rlang
48.7 - date: 02.10
48.8 - changed by: rlang
48.9 - last change by: rlang
48.10 - date: 02.10.20
48.11 -*)
48.12 -
48.13 -(*
48.14 - use"knowledge/LinEq.ML";
48.15 - use"LinEq.ML";
48.16 -
48.17 - use"ROOT.ML";
48.18 - cd"knowledge";
48.19 -
48.20 -*)
48.21 -
48.22 -LinEq = Poly + Equation +
48.23 -
48.24 -(*-------------------- consts------------------------------------------------*)
48.25 -consts
48.26 - Solve'_lineq'_equation
48.27 - :: "[bool,real, \
48.28 - \ bool list] => bool list"
48.29 - ("((Script Solve'_lineq'_equation (_ _ =))// \
48.30 - \ (_))" 9)
48.31 -
48.32 -(*-------------------- rules -------------------------------------------------*)
48.33 -rules
48.34 -(*-- normalize --*)
48.35 - (*WN0509 compare PolyEq.all_left "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)"*)
48.36 - all_left
48.37 - "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)"
48.38 - makex1_x
48.39 - "a^^^1 = a"
48.40 - real_assoc_1
48.41 - "a+(b+c) = a+b+c"
48.42 - real_assoc_2
48.43 - "a*(b*c) = a*b*c"
48.44 -
48.45 -(*-- solve --*)
48.46 - lin_isolate_add1
48.47 - "(a + b*bdv = 0) = (b*bdv = (-1)*a)"
48.48 - lin_isolate_add2
48.49 - "(a + bdv = 0) = ( bdv = (-1)*a)"
48.50 - lin_isolate_div
48.51 - "[|Not(b=0)|] ==> (b*bdv = c) = (bdv = c / b)"
48.52 -end
48.53 -
49.1 --- a/src/Tools/isac/IsacKnowledge/LogExp.ML Wed Aug 25 15:15:01 2010 +0200
49.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
49.3 @@ -1,39 +0,0 @@
49.4 -(* all outcommented in order to demonstrate authoring:
49.5 - WN071203
49.6 -*)
49.7 -
49.8 -(** interface isabelle -- isac **)
49.9 -theory' := overwritel (!theory', [("LogExp.thy",LogExp.thy)]);
49.10 -
49.11 -(*--------------------------------------------------*)
49.12 -
49.13 -(** problems **)
49.14 -store_pbt
49.15 - (prep_pbt LogExp.thy "pbl_test_equ_univ_log" [] e_pblID
49.16 - (["logarithmic","univariate","equation"],
49.17 - [("#Given",["equality e_","solveFor v_"]),
49.18 - ("#Where",["matches ((?a log ?v_) = ?b) e_"]),
49.19 - ("#Find" ,["solutions v_i_"]),
49.20 - ("#With" ,["||(lhs (Subst (v_i_,v_) e_) - \
49.21 - \ (rhs (Subst (v_i_,v_) e_) || < eps)"])
49.22 - ],
49.23 - PolyEq_prls, SOME "solve (e_::bool, v_)",
49.24 - [["Equation","solve_log"]]));
49.25 -
49.26 -(** methods **)
49.27 -store_met
49.28 - (prep_met LogExp.thy "met_equ_log" [] e_metID
49.29 - (["Equation","solve_log"],
49.30 - [("#Given" ,["equality e_","solveFor v_"]),
49.31 - ("#Where" ,["matches ((?a log ?v_) = ?b) e_"]),
49.32 - ("#Find" ,["solutions v_i_"])
49.33 - ],
49.34 - {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls,
49.35 - calc=[],crls=PolyEq_crls, nrls=norm_Rational},
49.36 - "Script Solve_log (e_::bool) (v_::real) = \
49.37 - \(let e_ = ((Rewrite equality_power False) @@ \
49.38 - \ (Rewrite exp_invers_log False) @@ \
49.39 - \ (Rewrite_Set norm_Poly False)) e_ \
49.40 - \ in [e_])"
49.41 - ));
49.42 -(*--------------------------------------------------*)
50.1 --- a/src/Tools/isac/IsacKnowledge/LogExp.thy Wed Aug 25 15:15:01 2010 +0200
50.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
50.3 @@ -1,30 +0,0 @@
50.4 -(* all outcommented in order to demonstrate authoring:
50.5 - WN071203
50.6 -remove_thy"LogExp";
50.7 -use_thy_only"IsacKnowledge/LogExp";
50.8 -use_thy_only"IsacKnowledge/Isac";
50.9 -*)
50.10 -LogExp = PolyEq +
50.11 -
50.12 -consts
50.13 -
50.14 - ln :: "real => real"
50.15 - exp :: "real => real" ("E'_ ^^^ _" 80)
50.16 -
50.17 -(*--------------------------------------------------*)
50.18 - alog :: "[real, real] => real" ("_ log _" 90)
50.19 -
50.20 - (*Script-names*)
50.21 - Solve'_log :: "[bool,real, bool list] \
50.22 - \=> bool list"
50.23 - ("((Script Solve'_log (_ _=))//(_))" 9)
50.24 -
50.25 -rules
50.26 -
50.27 - equality_pow "0 < a ==> (l = r) = (a^^^l = a^^^r)"
50.28 - (* this is what students ^^^^^^^... are told to do *)
50.29 - equality_power "((a log b) = c) = (a^^^(a log b) = a^^^c)"
50.30 - exp_invers_log "a^^^(a log b) = b"
50.31 -(*---------------------------------------------------*)
50.32 -
50.33 -end
50.34 \ No newline at end of file
51.1 --- a/src/Tools/isac/IsacKnowledge/Poly.ML Wed Aug 25 15:15:01 2010 +0200
51.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
51.3 @@ -1,1495 +0,0 @@
51.4 -(*.eval_funs, rulesets, problems and methods concerning polynamials
51.5 - authors: Matthias Goldgruber 2003
51.6 - (c) due to copyright terms
51.7 -
51.8 - use"../IsacKnowledge/Poly.ML";
51.9 - use"IsacKnowledge/Poly.ML";
51.10 - use"Poly.ML";
51.11 -
51.12 - remove_thy"Poly";
51.13 - use_thy"IsacKnowledge/Isac";
51.14 -****************************************************************.*)
51.15 -
51.16 -(*.****************************************************************
51.17 - remark on 'polynomials'
51.18 - WN020919
51.19 - there are 5 kinds of expanded normalforms:
51.20 -[1] 'complete polynomial' (Komplettes Polynom), univariate
51.21 - a_0 + a_1.x^1 +...+ a_n.x^n not (a_n = 0)
51.22 - not (a_n = 0), some a_i may be zero (DON'T disappear),
51.23 - variables in monomials lexicographically ordered and complete,
51.24 - x written as 1*x^1, ...
51.25 -[2] 'polynomial' (Polynom), univariate and multivariate
51.26 - a_0 + a_1.x +...+ a_n.x^n not (a_n = 0)
51.27 - a_0 + a_1.x_1.x_2^n_12...x_m^n_1m +...+ a_n.x_1^n.x_2^n_n2...x_m^n_nm
51.28 - not (a_n = 0), some a_i may be zero (ie. monomials disappear),
51.29 - exponents and coefficients equal 1 are not (WN060904.TODO in cancel_p_)shown,
51.30 - and variables in monomials are lexicographically ordered
51.31 - examples: [1]: "1 + (-10) * x ^^^ 1 + 25 * x ^^^ 2"
51.32 - [1]: "11 + 0 * x ^^^ 1 + 1 * x ^^^ 2"
51.33 - [2]: "x + (-50) * x ^^^ 3"
51.34 - [2]: "(-1) * x * y ^^^ 2 + 7 * x ^^^ 3"
51.35 -
51.36 -[3] 'expanded_term' (Ausmultiplizierter Term):
51.37 - pull out unary minus to binary minus,
51.38 - as frequently exercised in schools; other conditions for [2] hold however
51.39 - examples: "a ^^^ 2 - 2 * a * b + b ^^^ 2"
51.40 - "4 * x ^^^ 2 - 9 * y ^^^ 2"
51.41 -[4] 'polynomial_in' (Polynom in):
51.42 - polynomial in 1 variable with arbitrary coefficients
51.43 - examples: "2 * x + (-50) * x ^^^ 3" (poly in x)
51.44 - "(u + v) + (2 * u ^^^ 2) * a + (-u) * a ^^^ 2 (poly in a)
51.45 -[5] 'expanded_in' (Ausmultiplizierter Termin in):
51.46 - analoguous to [3] with binary minus like [3]
51.47 - examples: "2 * x - 50 * x ^^^ 3" (expanded in x)
51.48 - "(u + v) + (2 * u ^^^ 2) * a - u * a ^^^ 2 (expanded in a)
51.49 -*****************************************************************.*)
51.50 -
51.51 -"******** Poly.ML begin ******************************************";
51.52 -theory' := overwritel (!theory', [("Poly.thy",Poly.thy)]);
51.53 -
51.54 -
51.55 -(* is_polyrat_in becomes true, if no bdv is in the denominator of a fraction*)
51.56 -fun is_polyrat_in t v =
51.57 - let
51.58 - fun coeff_in c v = member op = (vars c) v;
51.59 - fun finddivide (_ $ _ $ _ $ _) v = raise error("is_polyrat_in:")
51.60 - (* at the moment there is no term like this, but ....*)
51.61 - | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = not(coeff_in b v)
51.62 - | finddivide (_ $ t1 $ t2) v = (finddivide t1 v) orelse (finddivide t2 v)
51.63 - | finddivide (_ $ t1) v = (finddivide t1 v)
51.64 - | finddivide _ _ = false;
51.65 - in
51.66 - finddivide t v
51.67 - end;
51.68 -
51.69 -fun eval_is_polyrat_in _ _ (p as (Const ("Poly.is'_polyrat'_in",_) $ t $ v)) _ =
51.70 - if is_polyrat_in t v then
51.71 - SOME ((term2str p) ^ " = True",
51.72 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
51.73 - else SOME ((term2str p) ^ " = True",
51.74 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
51.75 - | eval_is_polyrat_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
51.76 -
51.77 -
51.78 -local
51.79 - (*.a 'c is coefficient of v' if v does NOT occur in c.*)
51.80 - fun coeff_in c v = not (member op = (vars c) v);
51.81 - (*
51.82 - val v = (term_of o the o (parse thy)) "x";
51.83 - val t = (term_of o the o (parse thy)) "1";
51.84 - coeff_in t v;
51.85 - (*val it = true : bool*)
51.86 - val t = (term_of o the o (parse thy)) "a*b+c";
51.87 - coeff_in t v;
51.88 - (*val it = true : bool*)
51.89 - val t = (term_of o the o (parse thy)) "a*x+c";
51.90 - coeff_in t v;
51.91 - (*val it = false : bool*)
51.92 - *)
51.93 - (*. a 'monomial t in variable v' is a term t with
51.94 - either (1) v NOT existent in t, or (2) v contained in t,
51.95 - if (1) then degree 0
51.96 - if (2) then v is a factor on the very right, ev. with exponent.*)
51.97 - fun factor_right_deg (*case 2*)
51.98 - (t as Const ("op *",_) $ t1 $
51.99 - (Const ("Atools.pow",_) $ vv $ Free (d,_))) v =
51.100 - if ((vv = v) andalso (coeff_in t1 v)) then SOME (int_of_str' d) else NONE
51.101 - | factor_right_deg
51.102 - (t as Const ("Atools.pow",_) $ vv $ Free (d,_)) v =
51.103 - if (vv = v) then SOME (int_of_str' d) else NONE
51.104 - | factor_right_deg (t as Const ("op *",_) $ t1 $ vv) v =
51.105 - if ((vv = v) andalso (coeff_in t1 v))then SOME 1 else NONE
51.106 - | factor_right_deg vv v =
51.107 - if (vv = v) then SOME 1 else NONE;
51.108 - fun mono_deg_in m v =
51.109 - if coeff_in m v then (*case 1*) SOME 0
51.110 - else factor_right_deg m v;
51.111 - (*
51.112 - val v = (term_of o the o (parse thy)) "x";
51.113 - val t = (term_of o the o (parse thy)) "(a*b+c)*x^^^7";
51.114 - mono_deg_in t v;
51.115 - (*val it = SOME 7*)
51.116 - val t = (term_of o the o (parse thy)) "x^^^7";
51.117 - mono_deg_in t v;
51.118 - (*val it = SOME 7*)
51.119 - val t = (term_of o the o (parse thy)) "(a*b+c)*x";
51.120 - mono_deg_in t v;
51.121 - (*val it = SOME 1*)
51.122 - val t = (term_of o the o (parse thy)) "(a*b+x)*x";
51.123 - mono_deg_in t v;
51.124 - (*val it = NONE*)
51.125 - val t = (term_of o the o (parse thy)) "x";
51.126 - mono_deg_in t v;
51.127 - (*val it = SOME 1*)
51.128 - val t = (term_of o the o (parse thy)) "(a*b+c)";
51.129 - mono_deg_in t v;
51.130 - (*val it = SOME 0*)
51.131 - val t = (term_of o the o (parse thy)) "ab - (a*b)*x";
51.132 - mono_deg_in t v;
51.133 - (*val it = NONE*)
51.134 - *)
51.135 - fun expand_deg_in t v =
51.136 - let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) =
51.137 - (case mono_deg_in t2 v of (* $ is left associative*)
51.138 - SOME d' => edi d' d' t1
51.139 - | NONE => NONE)
51.140 - | edi ~1 ~1 (Const ("op -",_) $ t1 $ t2) =
51.141 - (case mono_deg_in t2 v of
51.142 - SOME d' => edi d' d' t1
51.143 - | NONE => NONE)
51.144 - | edi d dmax (Const ("op -",_) $ t1 $ t2) =
51.145 - (case mono_deg_in t2 v of
51.146 - (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*)
51.147 - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE
51.148 - | NONE => NONE)
51.149 - | edi d dmax (Const ("op +",_) $ t1 $ t2) =
51.150 - (case mono_deg_in t2 v of
51.151 - (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*)
51.152 - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE
51.153 - | NONE => NONE)
51.154 - | edi ~1 ~1 t =
51.155 - (case mono_deg_in t v of
51.156 - d as SOME _ => d
51.157 - | NONE => NONE)
51.158 - | edi d dmax t = (*basecase last*)
51.159 - (case mono_deg_in t v of
51.160 - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE
51.161 - | NONE => NONE)
51.162 - in edi ~1 ~1 t end;
51.163 - (*
51.164 - val v = (term_of o the o (parse thy)) "x";
51.165 - val t = (term_of o the o (parse thy)) "a+b";
51.166 - expand_deg_in t v;
51.167 - (*val it = SOME 0*)
51.168 - val t = (term_of o the o (parse thy)) "(a+b)*x";
51.169 - expand_deg_in t v;
51.170 - (*SOME 1*)
51.171 - val t = (term_of o the o (parse thy)) "a*b - (a+b)*x";
51.172 - expand_deg_in t v;
51.173 - (*SOME 1*)
51.174 - val t = (term_of o the o (parse thy)) "a*b + (a-b)*x";
51.175 - expand_deg_in t v;
51.176 - (*SOME 1*)
51.177 - val t = (term_of o the o (parse thy)) "a*b + (a+b)*x + x^^^2";
51.178 - expand_deg_in t v;
51.179 - *)
51.180 - fun poly_deg_in t v =
51.181 - let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) =
51.182 - (case mono_deg_in t2 v of (* $ is left associative*)
51.183 - SOME d' => edi d' d' t1
51.184 - | NONE => NONE)
51.185 - | edi d dmax (Const ("op +",_) $ t1 $ t2) =
51.186 - (case mono_deg_in t2 v of
51.187 - (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*)
51.188 - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE
51.189 - | NONE => NONE)
51.190 - | edi ~1 ~1 t =
51.191 - (case mono_deg_in t v of
51.192 - d as SOME _ => d
51.193 - | NONE => NONE)
51.194 - | edi d dmax t = (*basecase last*)
51.195 - (case mono_deg_in t v of
51.196 - SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE
51.197 - | NONE => NONE)
51.198 - in edi ~1 ~1 t end;
51.199 -in
51.200 -
51.201 -fun is_expanded_in t v =
51.202 - case expand_deg_in t v of SOME _ => true | NONE => false;
51.203 -fun is_poly_in t v =
51.204 - case poly_deg_in t v of SOME _ => true | NONE => false;
51.205 -fun has_degree_in t v =
51.206 - case expand_deg_in t v of SOME d => d | NONE => ~1;
51.207 -end;
51.208 -(*
51.209 - val v = (term_of o the o (parse thy)) "x";
51.210 - val t = (term_of o the o (parse thy)) "a*b - (a+b)*x + x^^^2";
51.211 - has_degree_in t v;
51.212 - (*val it = 2*)
51.213 - val t = (term_of o the o (parse thy)) "-8 - 2*x + x^^^2";
51.214 - has_degree_in t v;
51.215 - (*val it = 2*)
51.216 - val t = (term_of o the o (parse thy)) "6 + 13*x + 6*x^^^2";
51.217 - has_degree_in t v;
51.218 - (*val it = 2*)
51.219 -*)
51.220 -
51.221 -(*("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in ""))*)
51.222 -fun eval_is_expanded_in _ _
51.223 - (p as (Const ("Poly.is'_expanded'_in",_) $ t $ v)) _ =
51.224 - if is_expanded_in t v
51.225 - then SOME ((term2str p) ^ " = True",
51.226 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
51.227 - else SOME ((term2str p) ^ " = True",
51.228 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
51.229 - | eval_is_expanded_in _ _ _ _ = NONE;
51.230 -(*
51.231 - val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) is_expanded_in x";
51.232 - val SOME (id, t') = eval_is_expanded_in 0 0 t 0;
51.233 - (*val id = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*)
51.234 - term2str t';
51.235 - (*val it = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*)
51.236 -*)
51.237 -(*("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in ""))*)
51.238 -fun eval_is_poly_in _ _
51.239 - (p as (Const ("Poly.is'_poly'_in",_) $ t $ v)) _ =
51.240 - if is_poly_in t v
51.241 - then SOME ((term2str p) ^ " = True",
51.242 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
51.243 - else SOME ((term2str p) ^ " = True",
51.244 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
51.245 - | eval_is_poly_in _ _ _ _ = NONE;
51.246 -(*
51.247 - val t = (term_of o the o (parse thy)) "(8 + 2*x + x^^^2) is_poly_in x";
51.248 - val SOME (id, t') = eval_is_poly_in 0 0 t 0;
51.249 - (*val id = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*)
51.250 - term2str t';
51.251 - (*val it = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*)
51.252 -*)
51.253 -
51.254 -(*("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in ""))*)
51.255 -fun eval_has_degree_in _ _
51.256 - (p as (Const ("Poly.has'_degree'_in",_) $ t $ v)) _ =
51.257 - let val d = has_degree_in t v
51.258 - val d' = term_of_num HOLogic.realT d
51.259 - in SOME ((term2str p) ^ " = " ^ (string_of_int d),
51.260 - Trueprop $ (mk_equality (p, d')))
51.261 - end
51.262 - | eval_has_degree_in _ _ _ _ = NONE;
51.263 -(*
51.264 -> val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) has_degree_in x";
51.265 -> val SOME (id, t') = eval_has_degree_in 0 0 t 0;
51.266 -val id = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string
51.267 -> term2str t';
51.268 -val it = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string
51.269 -*)
51.270 -
51.271 -(*..*)
51.272 -val calculate_Poly =
51.273 - append_rls "calculate_PolyFIXXXME.not.impl." e_rls
51.274 - [];
51.275 -
51.276 -(*.for evaluation of conditions in rewrite rules.*)
51.277 -val Poly_erls =
51.278 - append_rls "Poly_erls" Atools_erls
51.279 - [ Calc ("op =",eval_equal "#equal_"),
51.280 - Thm ("real_unari_minus",num_str real_unari_minus),
51.281 - Calc ("op +",eval_binop "#add_"),
51.282 - Calc ("op -",eval_binop "#sub_"),
51.283 - Calc ("op *",eval_binop "#mult_"),
51.284 - Calc ("Atools.pow" ,eval_binop "#power_")
51.285 - ];
51.286 -
51.287 -val poly_crls =
51.288 - append_rls "poly_crls" Atools_crls
51.289 - [ Calc ("op =",eval_equal "#equal_"),
51.290 - Thm ("real_unari_minus",num_str real_unari_minus),
51.291 - Calc ("op +",eval_binop "#add_"),
51.292 - Calc ("op -",eval_binop "#sub_"),
51.293 - Calc ("op *",eval_binop "#mult_"),
51.294 - Calc ("Atools.pow" ,eval_binop "#power_")
51.295 - ];
51.296 -
51.297 -
51.298 -local (*. for make_polynomial .*)
51.299 -
51.300 -open Term; (* for type order = EQUAL | LESS | GREATER *)
51.301 -
51.302 -fun pr_ord EQUAL = "EQUAL"
51.303 - | pr_ord LESS = "LESS"
51.304 - | pr_ord GREATER = "GREATER";
51.305 -
51.306 -fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
51.307 - (case a of
51.308 - "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest string*)
51.309 - | _ => (((a, 0), T), 0))
51.310 - | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
51.311 - | dest_hd' (Var v) = (v, 2)
51.312 - | dest_hd' (Bound i) = ((("", i), dummyT), 3)
51.313 - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
51.314 -
51.315 -fun get_order_pow (t $ (Free(order,_))) = (* RL FIXXXME:geht zufaellig?WN*)
51.316 - (case int_of_str (order) of
51.317 - SOME d => d
51.318 - | NONE => 0)
51.319 - | get_order_pow _ = 0;
51.320 -
51.321 -fun size_of_term' (Const(str,_) $ t) =
51.322 - if "Atools.pow"= str then 1000 + size_of_term' t else 1+size_of_term' t(*WN*)
51.323 - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
51.324 - | size_of_term' (f$t) = size_of_term' f + size_of_term' t
51.325 - | size_of_term' _ = 1;
51.326 -
51.327 -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
51.328 - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
51.329 - | term_ord' pr thy (t, u) =
51.330 - (if pr then
51.331 - let
51.332 - val (f, ts) = strip_comb t and (g, us) = strip_comb u;
51.333 - val _=writeln("t= f@ts= \""^
51.334 - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
51.335 - (commas(map(Syntax.string_of_term (thy2ctxt thy))ts))^"]\"");
51.336 - val _=writeln("u= g@us= \""^
51.337 - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
51.338 - (commas(map(Syntax.string_of_term (thy2ctxt thy))us))^"]\"");
51.339 - val _=writeln("size_of_term(t,u)= ("^
51.340 - (string_of_int(size_of_term' t))^", "^
51.341 - (string_of_int(size_of_term' u))^")");
51.342 - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
51.343 - val _=writeln("terms_ord(ts,us) = "^
51.344 - ((pr_ord o terms_ord str false)(ts,us)));
51.345 - val _=writeln("-------");
51.346 - in () end
51.347 - else ();
51.348 - case int_ord (size_of_term' t, size_of_term' u) of
51.349 - EQUAL =>
51.350 - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
51.351 - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
51.352 - | ord => ord)
51.353 - end
51.354 - | ord => ord)
51.355 -and hd_ord (f, g) = (* ~ term.ML *)
51.356 - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
51.357 -and terms_ord str pr (ts, us) =
51.358 - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
51.359 -in
51.360 -
51.361 -fun ord_make_polynomial (pr:bool) thy (_:subst) tu =
51.362 - (term_ord' pr thy(***) tu = LESS );
51.363 -
51.364 -end;(*local*)
51.365 -
51.366 -
51.367 -rew_ord' := overwritel (!rew_ord',
51.368 -[("termlessI", termlessI),
51.369 - ("ord_make_polynomial", ord_make_polynomial false thy)
51.370 - ]);
51.371 -
51.372 -
51.373 -val expand =
51.374 - Rls{id = "expand", preconds = [],
51.375 - rew_ord = ("dummy_ord", dummy_ord),
51.376 - erls = e_rls,srls = Erls,
51.377 - calc = [],
51.378 - (*asm_thm = [],*)
51.379 - rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
51.380 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
51.381 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2)
51.382 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
51.383 - ], scr = EmptyScr}:rls;
51.384 -
51.385 -(*----------------- Begin: rulesets for make_polynomial_ -----------------
51.386 - 'rlsIDs' redefined by MG as 'rlsIDs_'
51.387 - ^^^*)
51.388 -
51.389 -val discard_minus_ =
51.390 - Rls{id = "discard_minus_", preconds = [],
51.391 - rew_ord = ("dummy_ord", dummy_ord),
51.392 - erls = e_rls,srls = Erls,
51.393 - calc = [],
51.394 - (*asm_thm = [],*)
51.395 - rules = [Thm ("real_diff_minus",num_str real_diff_minus),
51.396 - (*"a - b = a + -1 * b"*)
51.397 - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
51.398 - (*- ?z = "-1 * ?z"*)
51.399 - ], scr = EmptyScr}:rls;
51.400 -val expand_poly_ =
51.401 - Rls{id = "expand_poly_", preconds = [],
51.402 - rew_ord = ("dummy_ord", dummy_ord),
51.403 - erls = e_rls,srls = Erls,
51.404 - calc = [],
51.405 - (*asm_thm = [],*)
51.406 - rules = [Thm ("real_plus_binom_pow4",num_str real_plus_binom_pow4),
51.407 - (*"(a + b)^^^4 = ... "*)
51.408 - Thm ("real_plus_binom_pow5",num_str real_plus_binom_pow5),
51.409 - (*"(a + b)^^^5 = ... "*)
51.410 - Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
51.411 - (*"(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *)
51.412 -
51.413 - (*WN071229 changed/removed for Schaerding -----vvv*)
51.414 - (*Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),*)
51.415 - (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
51.416 - Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),
51.417 - (*"(a + b)^^^2 = (a + b) * (a + b)"*)
51.418 - (*Thm ("real_plus_minus_binom1_p_p",
51.419 - num_str real_plus_minus_binom1_p_p),*)
51.420 - (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*)
51.421 - (*Thm ("real_plus_minus_binom2_p_p",
51.422 - num_str real_plus_minus_binom2_p_p),*)
51.423 - (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*)
51.424 - (*WN071229 changed/removed for Schaerding -----^^^*)
51.425 -
51.426 - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
51.427 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
51.428 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
51.429 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
51.430 -
51.431 - Thm ("realpow_multI", num_str realpow_multI),
51.432 - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
51.433 - Thm ("realpow_pow",num_str realpow_pow)
51.434 - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
51.435 - ], scr = EmptyScr}:rls;
51.436 -
51.437 -(*.the expression contains + - * ^ only ?
51.438 - this is weaker than 'is_polynomial' !.*)
51.439 -fun is_polyexp (Free _) = true
51.440 - | is_polyexp (Const ("op +",_) $ Free _ $ Free _) = true
51.441 - | is_polyexp (Const ("op -",_) $ Free _ $ Free _) = true
51.442 - | is_polyexp (Const ("op *",_) $ Free _ $ Free _) = true
51.443 - | is_polyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true
51.444 - | is_polyexp (Const ("op +",_) $ t1 $ t2) =
51.445 - ((is_polyexp t1) andalso (is_polyexp t2))
51.446 - | is_polyexp (Const ("op -",_) $ t1 $ t2) =
51.447 - ((is_polyexp t1) andalso (is_polyexp t2))
51.448 - | is_polyexp (Const ("op *",_) $ t1 $ t2) =
51.449 - ((is_polyexp t1) andalso (is_polyexp t2))
51.450 - | is_polyexp (Const ("Atools.pow",_) $ t1 $ t2) =
51.451 - ((is_polyexp t1) andalso (is_polyexp t2))
51.452 - | is_polyexp _ = false;
51.453 -
51.454 -(*("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp ""))*)
51.455 -fun eval_is_polyexp (thmid:string) _
51.456 - (t as (Const("Poly.is'_polyexp", _) $ arg)) thy =
51.457 - if is_polyexp arg
51.458 - then SOME (mk_thmid thmid ""
51.459 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
51.460 - Trueprop $ (mk_equality (t, HOLogic.true_const)))
51.461 - else SOME (mk_thmid thmid ""
51.462 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
51.463 - Trueprop $ (mk_equality (t, HOLogic.false_const)))
51.464 - | eval_is_polyexp _ _ _ _ = NONE;
51.465 -
51.466 -val expand_poly_rat_ =
51.467 - Rls{id = "expand_poly_rat_", preconds = [],
51.468 - rew_ord = ("dummy_ord", dummy_ord),
51.469 - erls = append_rls "e_rls-is_polyexp" e_rls
51.470 - [Calc ("Poly.is'_polyexp", eval_is_polyexp "")
51.471 - ],
51.472 - srls = Erls,
51.473 - calc = [],
51.474 - (*asm_thm = [],*)
51.475 - rules = [Thm ("real_plus_binom_pow4_poly",num_str real_plus_binom_pow4_poly),
51.476 - (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^4 = ... "*)
51.477 - Thm ("real_plus_binom_pow5_poly",num_str real_plus_binom_pow5_poly),
51.478 - (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^5 = ... "*)
51.479 - Thm ("real_plus_binom_pow2_poly",num_str real_plus_binom_pow2_poly),
51.480 - (*"[| a is_polyexp; b is_polyexp |] ==>
51.481 - (a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
51.482 - Thm ("real_plus_binom_pow3_poly",num_str real_plus_binom_pow3_poly),
51.483 - (*"[| a is_polyexp; b is_polyexp |] ==>
51.484 - (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *)
51.485 - Thm ("real_plus_minus_binom1_p_p",num_str real_plus_minus_binom1_p_p),
51.486 - (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*)
51.487 - Thm ("real_plus_minus_binom2_p_p",num_str real_plus_minus_binom2_p_p),
51.488 - (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*)
51.489 -
51.490 - Thm ("real_add_mult_distrib_poly" ,num_str real_add_mult_distrib_poly),
51.491 - (*"w is_polyexp ==> (z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
51.492 - Thm ("real_add_mult_distrib2_poly",num_str real_add_mult_distrib2_poly),
51.493 - (*"w is_polyexp ==> w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
51.494 -
51.495 - Thm ("realpow_multI_poly", num_str realpow_multI_poly),
51.496 - (*"[| r is_polyexp; s is_polyexp |] ==>
51.497 - (r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
51.498 - Thm ("realpow_pow",num_str realpow_pow)
51.499 - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
51.500 - ], scr = EmptyScr}:rls;
51.501 -
51.502 -val simplify_power_ =
51.503 - Rls{id = "simplify_power_", preconds = [],
51.504 - rew_ord = ("dummy_ord", dummy_ord),
51.505 - erls = e_rls, srls = Erls,
51.506 - calc = [],
51.507 - (*asm_thm = [],*)
51.508 - rules = [(*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen
51.509 - a*(a*a) --> a*a^^^2 und nicht a*(a*a) --> a^^^2*a *)
51.510 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
51.511 - (*"r * r = r ^^^ 2"*)
51.512 - Thm ("realpow_twoI_assoc_l",num_str realpow_twoI_assoc_l),
51.513 - (*"r * (r * s) = r ^^^ 2 * s"*)
51.514 -
51.515 - Thm ("realpow_plus_1",num_str realpow_plus_1),
51.516 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
51.517 - Thm ("realpow_plus_1_assoc_l", num_str realpow_plus_1_assoc_l),
51.518 - (*"r * (r ^^^ m * s) = r ^^^ (1 + m) * s"*)
51.519 - (*MG 9.7.03: neues Thm wegen a*(a*(a*b)) --> a^^^2*(a*b) *)
51.520 - Thm ("realpow_plus_1_assoc_l2", num_str realpow_plus_1_assoc_l2),
51.521 - (*"r ^^^ m * (r * s) = r ^^^ (1 + m) * s"*)
51.522 -
51.523 - Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)),
51.524 - (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
51.525 - Thm ("realpow_addI_assoc_l", num_str realpow_addI_assoc_l),
51.526 - (*"r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s"*)
51.527 -
51.528 - (* ist in expand_poly - wird hier aber auch gebraucht, wegen:
51.529 - "r * r = r ^^^ 2" wenn r=a^^^b*)
51.530 - Thm ("realpow_pow",num_str realpow_pow)
51.531 - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
51.532 - ], scr = EmptyScr}:rls;
51.533 -
51.534 -val calc_add_mult_pow_ =
51.535 - Rls{id = "calc_add_mult_pow_", preconds = [],
51.536 - rew_ord = ("dummy_ord", dummy_ord),
51.537 - erls = Atools_erls(*erls3.4.03*),srls = Erls,
51.538 - calc = [("PLUS" , ("op +", eval_binop "#add_")),
51.539 - ("TIMES" , ("op *", eval_binop "#mult_")),
51.540 - ("POWER", ("Atools.pow", eval_binop "#power_"))
51.541 - ],
51.542 - (*asm_thm = [],*)
51.543 - rules = [Calc ("op +", eval_binop "#add_"),
51.544 - Calc ("op *", eval_binop "#mult_"),
51.545 - Calc ("Atools.pow", eval_binop "#power_")
51.546 - ], scr = EmptyScr}:rls;
51.547 -
51.548 -val reduce_012_mult_ =
51.549 - Rls{id = "reduce_012_mult_", preconds = [],
51.550 - rew_ord = ("dummy_ord", dummy_ord),
51.551 - erls = e_rls,srls = Erls,
51.552 - calc = [],
51.553 - (*asm_thm = [],*)
51.554 - rules = [(* MG: folgende Thm müssen hier stehen bleiben: *)
51.555 - Thm ("real_mult_1_right",num_str real_mult_1_right),
51.556 - (*"z * 1 = z"*) (*wegen "a * b * b^^^(-1) + a"*)
51.557 - Thm ("realpow_zeroI",num_str realpow_zeroI),
51.558 - (*"r ^^^ 0 = 1"*) (*wegen "a*a^^^(-1)*c + b + c"*)
51.559 - Thm ("realpow_oneI",num_str realpow_oneI),
51.560 - (*"r ^^^ 1 = r"*)
51.561 - Thm ("realpow_eq_oneI",num_str realpow_eq_oneI)
51.562 - (*"1 ^^^ n = 1"*)
51.563 - ], scr = EmptyScr}:rls;
51.564 -
51.565 -val collect_numerals_ =
51.566 - Rls{id = "collect_numerals_", preconds = [],
51.567 - rew_ord = ("dummy_ord", dummy_ord),
51.568 - erls = Atools_erls, srls = Erls,
51.569 - calc = [("PLUS" , ("op +", eval_binop "#add_"))
51.570 - ],
51.571 - rules = [Thm ("real_num_collect",num_str real_num_collect),
51.572 - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
51.573 - Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r),
51.574 - (*"[| l is_const; m is_const |] ==> \
51.575 - \(k + m * n) + l * n = k + (l + m)*n"*)
51.576 - Thm ("real_one_collect",num_str real_one_collect),
51.577 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
51.578 - Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r),
51.579 - (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*)
51.580 -
51.581 - Calc ("op +", eval_binop "#add_"),
51.582 -
51.583 - (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen
51.584 - (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *)
51.585 - Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r),
51.586 - (*"(k + z1) + z1 = k + 2 * z1"*)
51.587 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym))
51.588 - (*"z1 + z1 = 2 * z1"*)
51.589 -
51.590 - ], scr = EmptyScr}:rls;
51.591 -
51.592 -val reduce_012_ =
51.593 - Rls{id = "reduce_012_", preconds = [],
51.594 - rew_ord = ("dummy_ord", dummy_ord),
51.595 - erls = e_rls,srls = Erls,
51.596 - calc = [],
51.597 - (*asm_thm = [],*)
51.598 - rules = [Thm ("real_mult_1",num_str real_mult_1),
51.599 - (*"1 * z = z"*)
51.600 - Thm ("real_mult_0",num_str real_mult_0),
51.601 - (*"0 * z = 0"*)
51.602 - Thm ("real_mult_0_right",num_str real_mult_0_right),
51.603 - (*"z * 0 = 0"*)
51.604 - Thm ("real_add_zero_left",num_str real_add_zero_left),
51.605 - (*"0 + z = z"*)
51.606 - Thm ("real_add_zero_right",num_str real_add_zero_right),
51.607 - (*"z + 0 = z"*) (*wegen a+b-b --> a+(1-1)*b --> a+0 --> a*)
51.608 -
51.609 - (*Thm ("realpow_oneI",num_str realpow_oneI)*)
51.610 - (*"?r ^^^ 1 = ?r"*)
51.611 - Thm ("real_0_divide",num_str real_0_divide)(*WN060914*)
51.612 - (*"0 / ?x = 0"*)
51.613 - ], scr = EmptyScr}:rls;
51.614 -
51.615 -(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*)
51.616 -val discard_parentheses_ =
51.617 - append_rls "discard_parentheses_" e_rls
51.618 - [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym))
51.619 - (*"?z1.1 * (?z2.1 * ?z3.1) = ?z1.1 * ?z2.1 * ?z3.1"*)
51.620 - (*Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))*)
51.621 - (*"?z1.1 + (?z2.1 + ?z3.1) = ?z1.1 + ?z2.1 + ?z3.1"*)
51.622 - ];
51.623 -
51.624 -(*----------------- End: rulesets for make_polynomial_ -----------------*)
51.625 -
51.626 -(*MG.0401 ev. for use in rls with ordered rewriting ?
51.627 -val collect_numerals_left =
51.628 - Rls{id = "collect_numerals", preconds = [],
51.629 - rew_ord = ("dummy_ord", dummy_ord),
51.630 - erls = Atools_erls(*erls3.4.03*),srls = Erls,
51.631 - calc = [("PLUS" , ("op +", eval_binop "#add_")),
51.632 - ("TIMES" , ("op *", eval_binop "#mult_")),
51.633 - ("POWER", ("Atools.pow", eval_binop "#power_"))
51.634 - ],
51.635 - (*asm_thm = [],*)
51.636 - rules = [Thm ("real_num_collect",num_str real_num_collect),
51.637 - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
51.638 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
51.639 - (*"[| l is_const; m is_const |] ==>
51.640 - l * n + (m * n + k) = (l + m) * n + k"*)
51.641 - Thm ("real_one_collect",num_str real_one_collect),
51.642 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
51.643 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
51.644 - (*"m is_const ==> n + (m * n + k) = (1 + m) * n + k"*)
51.645 -
51.646 - Calc ("op +", eval_binop "#add_"),
51.647 -
51.648 - (*MG am 2.5.03: 2 Theoreme aus reduce_012 hierher verschoben*)
51.649 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
51.650 - (*"z1 + z1 = 2 * z1"*)
51.651 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc)
51.652 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
51.653 - ], scr = EmptyScr}:rls;*)
51.654 -
51.655 -val expand_poly =
51.656 - Rls{id = "expand_poly", preconds = [],
51.657 - rew_ord = ("dummy_ord", dummy_ord),
51.658 - erls = e_rls,srls = Erls,
51.659 - calc = [],
51.660 - (*asm_thm = [],*)
51.661 - rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
51.662 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
51.663 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
51.664 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
51.665 - (*Thm ("real_add_mult_distrib1",num_str real_add_mult_distrib1),
51.666 - ....... 18.3.03 undefined???*)
51.667 -
51.668 - Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),
51.669 - (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
51.670 - Thm ("real_minus_binom_pow2_p",num_str real_minus_binom_pow2_p),
51.671 - (*"(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2"*)
51.672 - Thm ("real_plus_minus_binom1_p",
51.673 - num_str real_plus_minus_binom1_p),
51.674 - (*"(a + b)*(a - b) = a^^^2 + -1*b^^^2"*)
51.675 - Thm ("real_plus_minus_binom2_p",
51.676 - num_str real_plus_minus_binom2_p),
51.677 - (*"(a - b)*(a + b) = a^^^2 + -1*b^^^2"*)
51.678 -
51.679 - Thm ("real_minus_minus",num_str real_minus_minus),
51.680 - (*"- (- ?z) = ?z"*)
51.681 - Thm ("real_diff_minus",num_str real_diff_minus),
51.682 - (*"a - b = a + -1 * b"*)
51.683 - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
51.684 - (*- ?z = "-1 * ?z"*)
51.685 -
51.686 - (*Thm ("",num_str ),
51.687 - Thm ("",num_str ),
51.688 - Thm ("",num_str ),*)
51.689 - (*Thm ("real_minus_add_distrib",
51.690 - num_str real_minus_add_distrib),*)
51.691 - (*"- (?x + ?y) = - ?x + - ?y"*)
51.692 - (*Thm ("real_diff_plus",num_str real_diff_plus)*)
51.693 - (*"a - b = a + -b"*)
51.694 - ], scr = EmptyScr}:rls;
51.695 -val simplify_power =
51.696 - Rls{id = "simplify_power", preconds = [],
51.697 - rew_ord = ("dummy_ord", dummy_ord),
51.698 - erls = e_rls, srls = Erls,
51.699 - calc = [],
51.700 - (*asm_thm = [],*)
51.701 - rules = [Thm ("realpow_multI", num_str realpow_multI),
51.702 - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
51.703 -
51.704 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
51.705 - (*"r1 * r1 = r1 ^^^ 2"*)
51.706 - Thm ("realpow_plus_1",num_str realpow_plus_1),
51.707 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
51.708 - Thm ("realpow_pow",num_str realpow_pow),
51.709 - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
51.710 - Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)),
51.711 - (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
51.712 - Thm ("realpow_oneI",num_str realpow_oneI),
51.713 - (*"r ^^^ 1 = r"*)
51.714 - Thm ("realpow_eq_oneI",num_str realpow_eq_oneI)
51.715 - (*"1 ^^^ n = 1"*)
51.716 - ], scr = EmptyScr}:rls;
51.717 -(*MG.0401: termorders for multivariate polys dropped due to principal problems:
51.718 - (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*)
51.719 -val order_add_mult =
51.720 - Rls{id = "order_add_mult", preconds = [],
51.721 - rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy),
51.722 - erls = e_rls,srls = Erls,
51.723 - calc = [],
51.724 - (*asm_thm = [],*)
51.725 - rules = [Thm ("real_mult_commute",num_str real_mult_commute),
51.726 - (* z * w = w * z *)
51.727 - Thm ("real_mult_left_commute",num_str real_mult_left_commute),
51.728 - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
51.729 - Thm ("real_mult_assoc",num_str real_mult_assoc),
51.730 - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
51.731 - Thm ("real_add_commute",num_str real_add_commute),
51.732 - (*z + w = w + z*)
51.733 - Thm ("real_add_left_commute",num_str real_add_left_commute),
51.734 - (*x + (y + z) = y + (x + z)*)
51.735 - Thm ("real_add_assoc",num_str real_add_assoc)
51.736 - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
51.737 - ], scr = EmptyScr}:rls;
51.738 -(*MG.0401: termorders for multivariate polys dropped due to principal problems:
51.739 - (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*)
51.740 -val order_mult =
51.741 - Rls{id = "order_mult", preconds = [],
51.742 - rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy),
51.743 - erls = e_rls,srls = Erls,
51.744 - calc = [],
51.745 - (*asm_thm = [],*)
51.746 - rules = [Thm ("real_mult_commute",num_str real_mult_commute),
51.747 - (* z * w = w * z *)
51.748 - Thm ("real_mult_left_commute",num_str real_mult_left_commute),
51.749 - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
51.750 - Thm ("real_mult_assoc",num_str real_mult_assoc)
51.751 - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
51.752 - ], scr = EmptyScr}:rls;
51.753 -val collect_numerals =
51.754 - Rls{id = "collect_numerals", preconds = [],
51.755 - rew_ord = ("dummy_ord", dummy_ord),
51.756 - erls = Atools_erls(*erls3.4.03*),srls = Erls,
51.757 - calc = [("PLUS" , ("op +", eval_binop "#add_")),
51.758 - ("TIMES" , ("op *", eval_binop "#mult_")),
51.759 - ("POWER", ("Atools.pow", eval_binop "#power_"))
51.760 - ],
51.761 - (*asm_thm = [],*)
51.762 - rules = [Thm ("real_num_collect",num_str real_num_collect),
51.763 - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
51.764 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
51.765 - (*"[| l is_const; m is_const |] ==>
51.766 - l * n + (m * n + k) = (l + m) * n + k"*)
51.767 - Thm ("real_one_collect",num_str real_one_collect),
51.768 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
51.769 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
51.770 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
51.771 - Calc ("op +", eval_binop "#add_"),
51.772 - Calc ("op *", eval_binop "#mult_"),
51.773 - Calc ("Atools.pow", eval_binop "#power_")
51.774 - ], scr = EmptyScr}:rls;
51.775 -val reduce_012 =
51.776 - Rls{id = "reduce_012", preconds = [],
51.777 - rew_ord = ("dummy_ord", dummy_ord),
51.778 - erls = e_rls,srls = Erls,
51.779 - calc = [],
51.780 - (*asm_thm = [],*)
51.781 - rules = [Thm ("real_mult_1",num_str real_mult_1),
51.782 - (*"1 * z = z"*)
51.783 - (*Thm ("real_mult_minus1",num_str real_mult_minus1),14.3.03*)
51.784 - (*"-1 * z = - z"*)
51.785 - Thm ("sym_real_mult_minus_eq1",
51.786 - num_str (real_mult_minus_eq1 RS sym)),
51.787 - (*- (?x * ?y) = "- ?x * ?y"*)
51.788 - (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel),
51.789 - (*"- ?x * - ?y = ?x * ?y"*)---*)
51.790 - Thm ("real_mult_0",num_str real_mult_0),
51.791 - (*"0 * z = 0"*)
51.792 - Thm ("real_add_zero_left",num_str real_add_zero_left),
51.793 - (*"0 + z = z"*)
51.794 - Thm ("real_add_minus",num_str real_add_minus),
51.795 - (*"?z + - ?z = 0"*)
51.796 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
51.797 - (*"z1 + z1 = 2 * z1"*)
51.798 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc)
51.799 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
51.800 - ], scr = EmptyScr}:rls;
51.801 -(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*)
51.802 -val discard_parentheses =
51.803 - append_rls "discard_parentheses" e_rls
51.804 - [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)),
51.805 - Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))];
51.806 -
51.807 -val scr_make_polynomial =
51.808 -"Script Expand_binoms t_ =\
51.809 -\(Repeat \
51.810 -\((Try (Repeat (Rewrite real_diff_minus False))) @@ \
51.811 -
51.812 -\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \
51.813 -\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \
51.814 -\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \
51.815 -\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \
51.816 -
51.817 -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
51.818 -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
51.819 -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
51.820 -
51.821 -\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \
51.822 -\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \
51.823 -\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \
51.824 -\ (Try (Repeat (Rewrite real_add_commute False))) @@ \
51.825 -\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \
51.826 -\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \
51.827 -
51.828 -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
51.829 -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
51.830 -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
51.831 -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
51.832 -
51.833 -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
51.834 -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
51.835 -
51.836 -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
51.837 -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
51.838 -
51.839 -\ (Try (Repeat (Calculate plus ))) @@ \
51.840 -\ (Try (Repeat (Calculate times ))) @@ \
51.841 -\ (Try (Repeat (Calculate power_)))) \
51.842 -\ t_)";
51.843 -
51.844 -(*version used by MG.02/03, overwritten by version AG in 04 below
51.845 -val make_polynomial = prep_rls(
51.846 - Seq{id = "make_polynomial", preconds = []:term list,
51.847 - rew_ord = ("dummy_ord", dummy_ord),
51.848 - erls = Atools_erls, srls = Erls,
51.849 - calc = [],(*asm_thm = [],*)
51.850 - rules = [Rls_ expand_poly,
51.851 - Rls_ order_add_mult,
51.852 - Rls_ simplify_power, (*realpow_eq_oneI, eg. x^1 --> x *)
51.853 - Rls_ collect_numerals, (*eg. x^(2+ -1) --> x^1 *)
51.854 - Rls_ reduce_012,
51.855 - Thm ("realpow_oneI",num_str realpow_oneI),(*in --^*)
51.856 - Rls_ discard_parentheses
51.857 - ],
51.858 - scr = EmptyScr
51.859 - }:rls); *)
51.860 -
51.861 -val scr_expand_binoms =
51.862 -"Script Expand_binoms t_ =\
51.863 -\(Repeat \
51.864 -\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \
51.865 -\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \
51.866 -\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \
51.867 -\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \
51.868 -\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \
51.869 -\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \
51.870 -
51.871 -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
51.872 -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
51.873 -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
51.874 -
51.875 -\ (Try (Repeat (Calculate plus ))) @@ \
51.876 -\ (Try (Repeat (Calculate times ))) @@ \
51.877 -\ (Try (Repeat (Calculate power_))) @@ \
51.878 -
51.879 -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
51.880 -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
51.881 -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
51.882 -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
51.883 -
51.884 -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
51.885 -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
51.886 -
51.887 -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
51.888 -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
51.889 -
51.890 -\ (Try (Repeat (Calculate plus ))) @@ \
51.891 -\ (Try (Repeat (Calculate times ))) @@ \
51.892 -\ (Try (Repeat (Calculate power_)))) \
51.893 -\ t_)";
51.894 -
51.895 -val expand_binoms =
51.896 - Rls{id = "expand_binoms", preconds = [], rew_ord = ("termlessI",termlessI),
51.897 - erls = Atools_erls, srls = Erls,
51.898 - calc = [("PLUS" , ("op +", eval_binop "#add_")),
51.899 - ("TIMES" , ("op *", eval_binop "#mult_")),
51.900 - ("POWER", ("Atools.pow", eval_binop "#power_"))
51.901 - ],
51.902 - (*asm_thm = [],*)
51.903 - rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
51.904 - (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
51.905 - Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
51.906 - (*"(a + b)*(a + b) = ...*)
51.907 - Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
51.908 - (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
51.909 - Thm ("real_minus_binom_times",num_str real_minus_binom_times),
51.910 - (*"(a - b)*(a - b) = ...*)
51.911 - Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
51.912 - (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
51.913 - Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
51.914 - (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
51.915 - (*RL 020915*)
51.916 - Thm ("real_pp_binom_times",num_str real_pp_binom_times),
51.917 - (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
51.918 - Thm ("real_pm_binom_times",num_str real_pm_binom_times),
51.919 - (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
51.920 - Thm ("real_mp_binom_times",num_str real_mp_binom_times),
51.921 - (*(a - b)*(c + d) = a*c + a*d - b*c - b*d*)
51.922 - Thm ("real_mm_binom_times",num_str real_mm_binom_times),
51.923 - (*(a - b)*(c - d) = a*c - a*d - b*c + b*d*)
51.924 - Thm ("realpow_multI",num_str realpow_multI),
51.925 - (*(a*b)^^^n = a^^^n * b^^^n*)
51.926 - Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
51.927 - (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *)
51.928 - Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3),
51.929 - (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *)
51.930 -
51.931 -
51.932 - (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
51.933 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
51.934 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
51.935 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
51.936 - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
51.937 - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
51.938 - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
51.939 - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
51.940 - *)
51.941 -
51.942 - Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
51.943 - Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
51.944 - Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*)
51.945 -
51.946 - Calc ("op +", eval_binop "#add_"),
51.947 - Calc ("op *", eval_binop "#mult_"),
51.948 - Calc ("Atools.pow", eval_binop "#power_"),
51.949 - (*
51.950 - Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
51.951 - Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
51.952 - Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
51.953 - Thm ("real_add_commute",num_str real_add_commute), (**)
51.954 - Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
51.955 - Thm ("real_add_assoc",num_str real_add_assoc), (**)
51.956 - *)
51.957 -
51.958 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
51.959 - (*"r1 * r1 = r1 ^^^ 2"*)
51.960 - Thm ("realpow_plus_1",num_str realpow_plus_1),
51.961 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
51.962 - (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
51.963 - (*"z1 + z1 = 2 * z1"*)*)
51.964 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
51.965 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
51.966 -
51.967 - Thm ("real_num_collect",num_str real_num_collect),
51.968 - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
51.969 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
51.970 - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
51.971 - Thm ("real_one_collect",num_str real_one_collect),
51.972 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
51.973 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
51.974 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
51.975 -
51.976 - Calc ("op +", eval_binop "#add_"),
51.977 - Calc ("op *", eval_binop "#mult_"),
51.978 - Calc ("Atools.pow", eval_binop "#power_")
51.979 - ],
51.980 - scr = Script ((term_of o the o (parse thy)) scr_expand_binoms)
51.981 - }:rls;
51.982 -
51.983 -
51.984 -"******* Poly.ML end ******* ...RL";
51.985 -
51.986 -
51.987 -(**. MG.03: make_polynomial_ ... uses SML-fun for ordering .**)
51.988 -
51.989 -(*FIXME.0401: make SML-order local to make_polynomial(_) *)
51.990 -(*FIXME.0401: replace 'make_polynomial'(old) by 'make_polynomial_'(MG) *)
51.991 -(* Polynom --> List von Monomen *)
51.992 -fun poly2list (Const ("op +",_) $ t1 $ t2) =
51.993 - (poly2list t1) @ (poly2list t2)
51.994 - | poly2list t = [t];
51.995 -
51.996 -(* Monom --> Liste von Variablen *)
51.997 -fun monom2list (Const ("op *",_) $ t1 $ t2) =
51.998 - (monom2list t1) @ (monom2list t2)
51.999 - | monom2list t = [t];
51.1000 -
51.1001 -(* liefert Variablenname (String) einer Variablen und Basis bei Potenz *)
51.1002 -fun get_basStr (Const ("Atools.pow",_) $ Free (str, _) $ _) = str
51.1003 - | get_basStr (Free (str, _)) = str
51.1004 - | get_basStr t = "|||"; (* gross gewichtet; für Brüch ect. *)
51.1005 -(*| get_basStr t =
51.1006 - raise error("get_basStr: called with t= "^(term2str t));*)
51.1007 -
51.1008 -(* liefert Hochzahl (String) einer Variablen bzw Gewichtstring (zum Sortieren) *)
51.1009 -fun get_potStr (Const ("Atools.pow",_) $ Free _ $ Free (str, _)) = str
51.1010 - | get_potStr (Const ("Atools.pow",_) $ Free _ $ _ ) = "|||" (* gross gewichtet *)
51.1011 - | get_potStr (Free (str, _)) = "---" (* keine Hochzahl --> kleinst gewichtet *)
51.1012 - | get_potStr t = "||||||"; (* gross gewichtet; für Brüch ect. *)
51.1013 -(*| get_potStr t =
51.1014 - raise error("get_potStr: called with t= "^(term2str t));*)
51.1015 -
51.1016 -(* Umgekehrte string_ord *)
51.1017 -val string_ord_rev = rev_order o string_ord;
51.1018 -
51.1019 - (* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen)
51.1020 - innerhalb eines Monomes:
51.1021 - - zuerst lexikographisch nach Variablenname
51.1022 - - wenn gleich: nach steigender Potenz *)
51.1023 -fun var_ord (a,b: term) = prod_ord string_ord string_ord
51.1024 - ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b));
51.1025 -
51.1026 -(* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen);
51.1027 - verwendet zum Sortieren von Monomen mittels Gesamtgradordnung:
51.1028 - - zuerst lexikographisch nach Variablenname
51.1029 - - wenn gleich: nach sinkender Potenz*)
51.1030 -fun var_ord_revPow (a,b: term) = prod_ord string_ord string_ord_rev
51.1031 - ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b));
51.1032 -
51.1033 -
51.1034 -(* Ordnet ein Liste von Variablen (und Potenzen) lexikographisch *)
51.1035 -val sort_varList = sort var_ord;
51.1036 -
51.1037 -(* Entfernet aeussersten Operator (Wurzel) aus einem Term und schreibt
51.1038 - Argumente in eine Liste *)
51.1039 -fun args u : term list =
51.1040 - let fun stripc (f$t, ts) = stripc (f, t::ts)
51.1041 - | stripc (t as Free _, ts) = (t::ts)
51.1042 - | stripc (_, ts) = ts
51.1043 - in stripc (u, []) end;
51.1044 -
51.1045 -(* liefert True, falls der Term (Liste von Termen) nur Zahlen
51.1046 - (keine Variablen) enthaelt *)
51.1047 -fun filter_num [] = true
51.1048 - | filter_num [Free x] = if (is_num (Free x)) then true
51.1049 - else false
51.1050 - | filter_num ((Free _)::_) = false
51.1051 - | filter_num ts =
51.1052 - (filter_num o (filter_out is_num) o flat o (map args)) ts;
51.1053 -
51.1054 -(* liefert True, falls der Term nur Zahlen (keine Variablen) enthaelt
51.1055 - dh. er ist ein numerischer Wert und entspricht einem Koeffizienten *)
51.1056 -fun is_nums t = filter_num [t];
51.1057 -
51.1058 -(* Berechnet den Gesamtgrad eines Monoms *)
51.1059 -local
51.1060 - fun counter (n, []) = n
51.1061 - | counter (n, x :: xs) =
51.1062 - if (is_nums x) then
51.1063 - counter (n, xs)
51.1064 - else
51.1065 - (case x of
51.1066 - (Const ("Atools.pow", _) $ Free (str_b, _) $ Free (str_h, T)) =>
51.1067 - if (is_nums (Free (str_h, T))) then
51.1068 - counter (n + (the (int_of_str str_h)), xs)
51.1069 - else counter (n + 1000, xs) (*FIXME.MG?!*)
51.1070 - | (Const ("Atools.pow", _) $ Free (str_b, _) $ _ ) =>
51.1071 - counter (n + 1000, xs) (*FIXME.MG?!*)
51.1072 - | (Free (str, _)) => counter (n + 1, xs)
51.1073 - (*| _ => raise error("monom_degree: called with factor: "^(term2str x)))*)
51.1074 - | _ => counter (n + 10000, xs)) (*FIXME.MG?! ... Brüche ect.*)
51.1075 -in
51.1076 - fun monom_degree l = counter (0, l)
51.1077 -end;
51.1078 -
51.1079 -(* wie Ordnung dict_ord (lexicographische Ordnung zweier Listen, mit Vergleich
51.1080 - der Listen-Elemente mit elem_ord) - Elemente die Bedingung cond erfuellen,
51.1081 - werden jedoch dabei ignoriert (uebersprungen) *)
51.1082 -fun dict_cond_ord _ _ ([], []) = EQUAL
51.1083 - | dict_cond_ord _ _ ([], _ :: _) = LESS
51.1084 - | dict_cond_ord _ _ (_ :: _, []) = GREATER
51.1085 - | dict_cond_ord elem_ord cond (x :: xs, y :: ys) =
51.1086 - (case (cond x, cond y) of
51.1087 - (false, false) => (case elem_ord (x, y) of
51.1088 - EQUAL => dict_cond_ord elem_ord cond (xs, ys)
51.1089 - | ord => ord)
51.1090 - | (false, true) => dict_cond_ord elem_ord cond (x :: xs, ys)
51.1091 - | (true, false) => dict_cond_ord elem_ord cond (xs, y :: ys)
51.1092 - | (true, true) => dict_cond_ord elem_ord cond (xs, ys) );
51.1093 -
51.1094 -(* Gesamtgradordnung zum Vergleich von Monomen (Liste von Variablen/Potenzen):
51.1095 - zuerst nach Gesamtgrad, bei gleichem Gesamtgrad lexikographisch ordnen -
51.1096 - dabei werden Koeffizienten ignoriert (2*3*a^^^2*4*b gilt wie a^^^2*b) *)
51.1097 -fun degree_ord (xs, ys) =
51.1098 - prod_ord int_ord (dict_cond_ord var_ord_revPow is_nums)
51.1099 - ((monom_degree xs, xs), (monom_degree ys, ys));
51.1100 -
51.1101 -fun hd_str str = substring (str, 0, 1);
51.1102 -fun tl_str str = substring (str, 1, (size str) - 1);
51.1103 -
51.1104 -(* liefert nummerischen Koeffizienten eines Monoms oder NONE *)
51.1105 -fun get_koeff_of_mon [] = raise error("get_koeff_of_mon: called with l = []")
51.1106 - | get_koeff_of_mon (l as x::xs) = if is_nums x then SOME x
51.1107 - else NONE;
51.1108 -
51.1109 -(* wandelt Koeffizient in (zum sortieren geeigneten) String um *)
51.1110 -fun koeff2ordStr (SOME x) = (case x of
51.1111 - (Free (str, T)) =>
51.1112 - if (hd_str str) = "-" then (tl_str str)^"0" (* 3 < -3 *)
51.1113 - else str
51.1114 - | _ => "aaa") (* "num.Ausdruck" --> gross *)
51.1115 - | koeff2ordStr NONE = "---"; (* "kein Koeff" --> kleinste *)
51.1116 -
51.1117 -(* Order zum Vergleich von Koeffizienten (strings):
51.1118 - "kein Koeff" < "0" < "1" < "-1" < "2" < "-2" < ... < "num.Ausdruck" *)
51.1119 -fun compare_koeff_ord (xs, ys) =
51.1120 - string_ord ((koeff2ordStr o get_koeff_of_mon) xs,
51.1121 - (koeff2ordStr o get_koeff_of_mon) ys);
51.1122 -
51.1123 -(* Gesamtgradordnung degree_ord + Ordnen nach Koeffizienten falls EQUAL *)
51.1124 -fun koeff_degree_ord (xs, ys) =
51.1125 - prod_ord degree_ord compare_koeff_ord ((xs, xs), (ys, ys));
51.1126 -
51.1127 -(* Ordnet ein Liste von Monomen (Monom = Liste von Variablen) mittels
51.1128 - Gesamtgradordnung *)
51.1129 -val sort_monList = sort koeff_degree_ord;
51.1130 -
51.1131 -(* Alternativ zu degree_ord koennte auch die viel einfachere und
51.1132 - kuerzere Ordnung simple_ord verwendet werden - ist aber nicht
51.1133 - fuer unsere Zwecke geeignet!
51.1134 -
51.1135 -fun simple_ord (al,bl: term list) = dict_ord string_ord
51.1136 - (map get_basStr al, map get_basStr bl);
51.1137 -
51.1138 -val sort_monList = sort simple_ord; *)
51.1139 -
51.1140 -(* aus 2 Variablen wird eine Summe bzw ein Produkt erzeugt
51.1141 - (mit gewuenschtem Typen T) *)
51.1142 -fun plus T = Const ("op +", [T,T] ---> T);
51.1143 -fun mult T = Const ("op *", [T,T] ---> T);
51.1144 -fun binop op_ t1 t2 = op_ $ t1 $ t2;
51.1145 -fun create_prod T (a,b) = binop (mult T) a b;
51.1146 -fun create_sum T (a,b) = binop (plus T) a b;
51.1147 -
51.1148 -(* löscht letztes Element einer Liste *)
51.1149 -fun drop_last l = take ((length l)-1,l);
51.1150 -
51.1151 -(* Liste von Variablen --> Monom *)
51.1152 -fun create_monom T vl = foldr (create_prod T) (drop_last vl, last_elem vl);
51.1153 -(* Bemerkung:
51.1154 - foldr bewirkt rechtslastige Klammerung des Monoms - ist notwendig, damit zwei
51.1155 - gleiche Monome zusammengefasst werden können (collect_numerals)!
51.1156 - zB: 2*(x*(y*z)) + 3*(x*(y*z)) --> (2+3)*(x*(y*z))*)
51.1157 -
51.1158 -(* Liste von Monomen --> Polynom *)
51.1159 -fun create_polynom T ml = foldl (create_sum T) (hd ml, tl ml);
51.1160 -(* Bemerkung:
51.1161 - foldl bewirkt linkslastige Klammerung des Polynoms (der Summanten) -
51.1162 - bessere Darstellung, da keine Klammern sichtbar!
51.1163 - (und discard_parentheses in make_polynomial hat weniger zu tun) *)
51.1164 -
51.1165 -(* sorts the variables (faktors) of an expanded polynomial lexicographical *)
51.1166 -fun sort_variables t =
51.1167 - let
51.1168 - val ll = map monom2list (poly2list t);
51.1169 - val lls = map sort_varList ll;
51.1170 - val T = type_of t;
51.1171 - val ls = map (create_monom T) lls;
51.1172 - in create_polynom T ls end;
51.1173 -
51.1174 -(* sorts the monoms of an expanded and variable-sorted polynomial
51.1175 - by total_degree *)
51.1176 -fun sort_monoms t =
51.1177 - let
51.1178 - val ll = map monom2list (poly2list t);
51.1179 - val lls = sort_monList ll;
51.1180 - val T = type_of t;
51.1181 - val ls = map (create_monom T) lls;
51.1182 - in create_polynom T ls end;
51.1183 -
51.1184 -(* auch Klammerung muss übereinstimmen;
51.1185 - sort_variables klammert Produkte rechtslastig*)
51.1186 -fun is_multUnordered t = ((is_polyexp t) andalso not (t = sort_variables t));
51.1187 -
51.1188 -fun eval_is_multUnordered (thmid:string) _
51.1189 - (t as (Const("Poly.is'_multUnordered", _) $ arg)) thy =
51.1190 - if is_multUnordered arg
51.1191 - then SOME (mk_thmid thmid ""
51.1192 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
51.1193 - Trueprop $ (mk_equality (t, HOLogic.true_const)))
51.1194 - else SOME (mk_thmid thmid ""
51.1195 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
51.1196 - Trueprop $ (mk_equality (t, HOLogic.false_const)))
51.1197 - | eval_is_multUnordered _ _ _ _ = NONE;
51.1198 -
51.1199 -
51.1200 -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
51.1201 - []:(rule * (term * term list)) list;
51.1202 -fun init_state (_:term) = e_rrlsstate;
51.1203 -fun locate_rule (_:rule list list) (_:term) (_:rule) =
51.1204 - ([]:(rule * (term * term list)) list);
51.1205 -fun next_rule (_:rule list list) (_:term) = (NONE:rule option);
51.1206 -fun normal_form t = SOME (sort_variables t,[]:term list);
51.1207 -
51.1208 -val order_mult_ =
51.1209 - Rrls {id = "order_mult_",
51.1210 - prepat =
51.1211 - [([(term_of o the o (parse thy)) "p is_multUnordered"],
51.1212 - (term_of o the o (parse thy)) "?p" )],
51.1213 - rew_ord = ("dummy_ord", dummy_ord),
51.1214 - erls = append_rls "e_rls-is_multUnordered" e_rls(*MG: poly_erls*)
51.1215 - [Calc ("Poly.is'_multUnordered", eval_is_multUnordered "")
51.1216 - ],
51.1217 - calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
51.1218 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
51.1219 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
51.1220 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
51.1221 - (*asm_thm=[],*)
51.1222 - scr=Rfuns {init_state = init_state,
51.1223 - normal_form = normal_form,
51.1224 - locate_rule = locate_rule,
51.1225 - next_rule = next_rule,
51.1226 - attach_form = attach_form}};
51.1227 -
51.1228 -val order_mult_rls_ =
51.1229 - Rls{id = "order_mult_rls_", preconds = [],
51.1230 - rew_ord = ("dummy_ord", dummy_ord),
51.1231 - erls = e_rls,srls = Erls,
51.1232 - calc = [],
51.1233 - (*asm_thm = [],*)
51.1234 - rules = [Rls_ order_mult_
51.1235 - ], scr = EmptyScr}:rls;
51.1236 -
51.1237 -fun is_addUnordered t = ((is_polyexp t) andalso not (t = sort_monoms t));
51.1238 -
51.1239 -(*WN.18.6.03 *)
51.1240 -(*("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered ""))*)
51.1241 -fun eval_is_addUnordered (thmid:string) _
51.1242 - (t as (Const("Poly.is'_addUnordered", _) $ arg)) thy =
51.1243 - if is_addUnordered arg
51.1244 - then SOME (mk_thmid thmid ""
51.1245 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
51.1246 - Trueprop $ (mk_equality (t, HOLogic.true_const)))
51.1247 - else SOME (mk_thmid thmid ""
51.1248 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
51.1249 - Trueprop $ (mk_equality (t, HOLogic.false_const)))
51.1250 - | eval_is_addUnordered _ _ _ _ = NONE;
51.1251 -
51.1252 -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
51.1253 - []:(rule * (term * term list)) list;
51.1254 -fun init_state (_:term) = e_rrlsstate;
51.1255 -fun locate_rule (_:rule list list) (_:term) (_:rule) =
51.1256 - ([]:(rule * (term * term list)) list);
51.1257 -fun next_rule (_:rule list list) (_:term) = (NONE:rule option);
51.1258 -fun normal_form t = SOME (sort_monoms t,[]:term list);
51.1259 -
51.1260 -val order_add_ =
51.1261 - Rrls {id = "order_add_",
51.1262 - prepat = (*WN.18.6.03 Preconditions und Pattern,
51.1263 - die beide passen muessen, damit das Rrls angewandt wird*)
51.1264 - [([(term_of o the o (parse thy)) "p is_addUnordered"],
51.1265 - (term_of o the o (parse thy)) "?p"
51.1266 - (*WN.18.6.03 also KEIN pattern, dieses erzeugt nur das Environment
51.1267 - fuer die Evaluation der Precondition "p is_addUnordered"*))],
51.1268 - rew_ord = ("dummy_ord", dummy_ord),
51.1269 - erls = append_rls "e_rls-is_addUnordered" e_rls(*MG: poly_erls*)
51.1270 - [Calc ("Poly.is'_addUnordered", eval_is_addUnordered "")
51.1271 - (*WN.18.6.03 definiert in Poly.thy,
51.1272 - evaluiert prepat*)],
51.1273 - calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
51.1274 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
51.1275 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
51.1276 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
51.1277 - (*asm_thm=[],*)
51.1278 - scr=Rfuns {init_state = init_state,
51.1279 - normal_form = normal_form,
51.1280 - locate_rule = locate_rule,
51.1281 - next_rule = next_rule,
51.1282 - attach_form = attach_form}};
51.1283 -
51.1284 -val order_add_rls_ =
51.1285 - Rls{id = "order_add_rls_", preconds = [],
51.1286 - rew_ord = ("dummy_ord", dummy_ord),
51.1287 - erls = e_rls,srls = Erls,
51.1288 - calc = [],
51.1289 - (*asm_thm = [],*)
51.1290 - rules = [Rls_ order_add_
51.1291 - ], scr = EmptyScr}:rls;
51.1292 -
51.1293 -(*. see MG-DA.p.52ff .*)
51.1294 -val make_polynomial(*MG.03, overwrites version from above,
51.1295 - previously 'make_polynomial_'*) =
51.1296 - Seq {id = "make_polynomial", preconds = []:term list,
51.1297 - rew_ord = ("dummy_ord", dummy_ord),
51.1298 - erls = Atools_erls, srls = Erls,calc = [],
51.1299 - rules = [Rls_ discard_minus_,
51.1300 - Rls_ expand_poly_,
51.1301 - Calc ("op *", eval_binop "#mult_"),
51.1302 - Rls_ order_mult_rls_,
51.1303 - Rls_ simplify_power_,
51.1304 - Rls_ calc_add_mult_pow_,
51.1305 - Rls_ reduce_012_mult_,
51.1306 - Rls_ order_add_rls_,
51.1307 - Rls_ collect_numerals_,
51.1308 - Rls_ reduce_012_,
51.1309 - Rls_ discard_parentheses_
51.1310 - ],
51.1311 - scr = EmptyScr
51.1312 - }:rls;
51.1313 -val norm_Poly(*=make_polynomial*) =
51.1314 - Seq {id = "norm_Poly", preconds = []:term list,
51.1315 - rew_ord = ("dummy_ord", dummy_ord),
51.1316 - erls = Atools_erls, srls = Erls, calc = [],
51.1317 - rules = [Rls_ discard_minus_,
51.1318 - Rls_ expand_poly_,
51.1319 - Calc ("op *", eval_binop "#mult_"),
51.1320 - Rls_ order_mult_rls_,
51.1321 - Rls_ simplify_power_,
51.1322 - Rls_ calc_add_mult_pow_,
51.1323 - Rls_ reduce_012_mult_,
51.1324 - Rls_ order_add_rls_,
51.1325 - Rls_ collect_numerals_,
51.1326 - Rls_ reduce_012_,
51.1327 - Rls_ discard_parentheses_
51.1328 - ],
51.1329 - scr = EmptyScr
51.1330 - }:rls;
51.1331 -
51.1332 -(* MG:03 Like make_polynomial_ but without Rls_ discard_parentheses_
51.1333 - and expand_poly_rat_ instead of expand_poly_, see MG-DA.p.56ff*)
51.1334 -(* MG necessary for termination of norm_Rational(*_mg*) in Rational.ML*)
51.1335 -val make_rat_poly_with_parentheses =
51.1336 - Seq{id = "make_rat_poly_with_parentheses", preconds = []:term list,
51.1337 - rew_ord = ("dummy_ord", dummy_ord),
51.1338 - erls = Atools_erls, srls = Erls, calc = [],
51.1339 - rules = [Rls_ discard_minus_,
51.1340 - Rls_ expand_poly_rat_,(*ignors rationals*)
51.1341 - Calc ("op *", eval_binop "#mult_"),
51.1342 - Rls_ order_mult_rls_,
51.1343 - Rls_ simplify_power_,
51.1344 - Rls_ calc_add_mult_pow_,
51.1345 - Rls_ reduce_012_mult_,
51.1346 - Rls_ order_add_rls_,
51.1347 - Rls_ collect_numerals_,
51.1348 - Rls_ reduce_012_
51.1349 - (*Rls_ discard_parentheses_ *)
51.1350 - ],
51.1351 - scr = EmptyScr
51.1352 - }:rls;
51.1353 -
51.1354 -(*.a minimal ruleset for reverse rewriting of factions [2];
51.1355 - compare expand_binoms.*)
51.1356 -val rev_rew_p =
51.1357 -Seq{id = "reverse_rewriting", preconds = [], rew_ord = ("termlessI",termlessI),
51.1358 - erls = Atools_erls, srls = Erls,
51.1359 - calc = [(*("PLUS" , ("op +", eval_binop "#add_")),
51.1360 - ("TIMES" , ("op *", eval_binop "#mult_")),
51.1361 - ("POWER", ("Atools.pow", eval_binop "#power_"))*)
51.1362 - ],
51.1363 - rules = [Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
51.1364 - (*"(a + b)*(a + b) = a ^ 2 + 2 * a * b + b ^ 2*)
51.1365 - Thm ("real_plus_binom_times1" ,num_str real_plus_binom_times1),
51.1366 - (*"(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2"*)
51.1367 - Thm ("real_plus_binom_times2" ,num_str real_plus_binom_times2),
51.1368 - (*"(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2"*)
51.1369 -
51.1370 - Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*)
51.1371 -
51.1372 - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
51.1373 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
51.1374 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
51.1375 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
51.1376 -
51.1377 - Thm ("real_mult_assoc", num_str real_mult_assoc),
51.1378 - (*"?z1.1 * ?z2.1 * ?z3. =1 ?z1.1 * (?z2.1 * ?z3.1)"*)
51.1379 - Rls_ order_mult_rls_,
51.1380 - (*Rls_ order_add_rls_,*)
51.1381 -
51.1382 - Calc ("op +", eval_binop "#add_"),
51.1383 - Calc ("op *", eval_binop "#mult_"),
51.1384 - Calc ("Atools.pow", eval_binop "#power_"),
51.1385 -
51.1386 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
51.1387 - (*"r1 * r1 = r1 ^^^ 2"*)
51.1388 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
51.1389 - (*"z1 + z1 = 2 * z1"*)
51.1390 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
51.1391 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
51.1392 -
51.1393 - Thm ("real_num_collect",num_str real_num_collect),
51.1394 - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
51.1395 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
51.1396 - (*"[| l is_const; m is_const |] ==>
51.1397 - l * n + (m * n + k) = (l + m) * n + k"*)
51.1398 - Thm ("real_one_collect",num_str real_one_collect),
51.1399 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
51.1400 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
51.1401 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
51.1402 -
51.1403 - Thm ("realpow_multI", num_str realpow_multI),
51.1404 - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
51.1405 -
51.1406 - Calc ("op +", eval_binop "#add_"),
51.1407 - Calc ("op *", eval_binop "#mult_"),
51.1408 - Calc ("Atools.pow", eval_binop "#power_"),
51.1409 -
51.1410 - Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*)
51.1411 - Thm ("real_mult_0",num_str real_mult_0),(*"0 * z = 0"*)
51.1412 - Thm ("real_add_zero_left",num_str real_add_zero_left)(*0 + z = z*)
51.1413 -
51.1414 - (*Rls_ order_add_rls_*)
51.1415 - ],
51.1416 -
51.1417 - scr = EmptyScr}:rls;
51.1418 -
51.1419 -ruleset' :=
51.1420 -overwritelthy thy (!ruleset',
51.1421 - [("norm_Poly", prep_rls norm_Poly),
51.1422 - ("Poly_erls",Poly_erls)(*FIXXXME:del with rls.rls'*),
51.1423 - ("expand", prep_rls expand),
51.1424 - ("expand_poly", prep_rls expand_poly),
51.1425 - ("simplify_power", prep_rls simplify_power),
51.1426 - ("order_add_mult", prep_rls order_add_mult),
51.1427 - ("collect_numerals", prep_rls collect_numerals),
51.1428 - ("collect_numerals_", prep_rls collect_numerals_),
51.1429 - ("reduce_012", prep_rls reduce_012),
51.1430 - ("discard_parentheses", prep_rls discard_parentheses),
51.1431 - ("make_polynomial", prep_rls make_polynomial),
51.1432 - ("expand_binoms", prep_rls expand_binoms),
51.1433 - ("rev_rew_p", prep_rls rev_rew_p),
51.1434 - ("discard_minus_", prep_rls discard_minus_),
51.1435 - ("expand_poly_", prep_rls expand_poly_),
51.1436 - ("expand_poly_rat_", prep_rls expand_poly_rat_),
51.1437 - ("simplify_power_", prep_rls simplify_power_),
51.1438 - ("calc_add_mult_pow_", prep_rls calc_add_mult_pow_),
51.1439 - ("reduce_012_mult_", prep_rls reduce_012_mult_),
51.1440 - ("reduce_012_", prep_rls reduce_012_),
51.1441 - ("discard_parentheses_",prep_rls discard_parentheses_),
51.1442 - ("order_mult_rls_", prep_rls order_mult_rls_),
51.1443 - ("order_add_rls_", prep_rls order_add_rls_),
51.1444 - ("make_rat_poly_with_parentheses",
51.1445 - prep_rls make_rat_poly_with_parentheses)
51.1446 - (*("", prep_rls ),
51.1447 - ("", prep_rls ),
51.1448 - ("", prep_rls )
51.1449 - *)
51.1450 - ]);
51.1451 -
51.1452 -calclist':= overwritel (!calclist',
51.1453 - [("is_polyrat_in", ("Poly.is'_polyrat'_in",
51.1454 - eval_is_polyrat_in "#eval_is_polyrat_in")),
51.1455 - ("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in "")),
51.1456 - ("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in "")),
51.1457 - ("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in "")),
51.1458 - ("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp "")),
51.1459 - ("is_multUnordered", ("Poly.is'_multUnordered", eval_is_multUnordered"")),
51.1460 - ("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered ""))
51.1461 - ]);
51.1462 -
51.1463 -
51.1464 -(** problems **)
51.1465 -
51.1466 -store_pbt
51.1467 - (prep_pbt Poly.thy "pbl_simp_poly" [] e_pblID
51.1468 - (["polynomial","simplification"],
51.1469 - [("#Given" ,["term t_"]),
51.1470 - ("#Where" ,["t_ is_polyexp"]),
51.1471 - ("#Find" ,["normalform n_"])
51.1472 - ],
51.1473 - append_rls "e_rls" e_rls [(*for preds in where_*)
51.1474 - Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
51.1475 - SOME "Simplify t_",
51.1476 - [["simplification","for_polynomials"]]));
51.1477 -
51.1478 -
51.1479 -(** methods **)
51.1480 -
51.1481 -store_met
51.1482 - (prep_met Poly.thy "met_simp_poly" [] e_metID
51.1483 - (["simplification","for_polynomials"],
51.1484 - [("#Given" ,["term t_"]),
51.1485 - ("#Where" ,["t_ is_polyexp"]),
51.1486 - ("#Find" ,["normalform n_"])
51.1487 - ],
51.1488 - {rew_ord'="tless_true",
51.1489 - rls' = e_rls,
51.1490 - calc = [],
51.1491 - srls = e_rls,
51.1492 - prls = append_rls "simplification_for_polynomials_prls" e_rls
51.1493 - [(*for preds in where_*)
51.1494 - Calc ("Poly.is'_polyexp",eval_is_polyexp"")],
51.1495 - crls = e_rls, nrls = norm_Poly},
51.1496 - "Script SimplifyScript (t_::real) = \
51.1497 - \ ((Rewrite_Set norm_Poly False) t_)"
51.1498 - ));
52.1 --- a/src/Tools/isac/IsacKnowledge/Poly.thy Wed Aug 25 15:15:01 2010 +0200
52.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
52.3 @@ -1,147 +0,0 @@
52.4 -(* WN.020812: theorems in the Reals,
52.5 - necessary for special rule sets, in addition to Isabelle2002.
52.6 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
52.7 - !!! THIS IS THE _least_ NUMBER OF ADDITIONAL THEOREMS !!!
52.8 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
52.9 - xxxI contain ^^^ instead of ^ in the respective theorem xxx in 2002
52.10 - changed by: Richard Lang 020912
52.11 -*)
52.12 -
52.13 -(*
52.14 - use_thy"IsacKnowledge/Poly";
52.15 - use_thy"Poly";
52.16 - use_thy_only"IsacKnowledge/Poly";
52.17 -
52.18 - remove_thy"Poly";
52.19 - use_thy"IsacKnowledge/Isac";
52.20 -
52.21 -
52.22 - use"ROOT.ML";
52.23 - cd"IsacKnowledge";
52.24 - *)
52.25 -
52.26 -Poly = Simplify +
52.27 -
52.28 -(*-------------------- consts-----------------------------------------------*)
52.29 -consts
52.30 -
52.31 - is'_expanded'_in :: "[real, real] => bool" ("_ is'_expanded'_in _")
52.32 - is'_poly'_in :: "[real, real] => bool" ("_ is'_poly'_in _") (*RL DA *)
52.33 - has'_degree'_in :: "[real, real] => real" ("_ has'_degree'_in _")(*RL DA *)
52.34 - is'_polyrat'_in :: "[real, real] => bool" ("_ is'_polyrat'_in _")(*RL030626*)
52.35 -
52.36 - is'_multUnordered :: "real => bool" ("_ is'_multUnordered")
52.37 - is'_addUnordered :: "real => bool" ("_ is'_addUnordered") (*WN030618*)
52.38 - is'_polyexp :: "real => bool" ("_ is'_polyexp")
52.39 -
52.40 - Expand'_binoms
52.41 - :: "['y, \
52.42 - \ 'y] => 'y"
52.43 - ("((Script Expand'_binoms (_ =))// \
52.44 - \ (_))" 9)
52.45 -
52.46 -(*-------------------- rules------------------------------------------------*)
52.47 -rules (*.not contained in Isabelle2002,
52.48 - stated as axioms, TODO: prove as theorems;
52.49 - theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*)
52.50 -
52.51 - realpow_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)"
52.52 - realpow_addI "r ^^^ (n + m) = r ^^^ n * r ^^^ m"
52.53 - realpow_addI_assoc_l "r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s"
52.54 - realpow_addI_assoc_r "s * r ^^^ n * r ^^^ m = s * r ^^^ (n + m)"
52.55 -
52.56 - realpow_oneI "r ^^^ 1 = r"
52.57 - realpow_zeroI "r ^^^ 0 = 1"
52.58 - realpow_eq_oneI "1 ^^^ n = 1"
52.59 - realpow_multI "(r * s) ^^^ n = r ^^^ n * s ^^^ n"
52.60 - realpow_multI_poly "[| r is_polyexp; s is_polyexp |] ==> \
52.61 - \(r * s) ^^^ n = r ^^^ n * s ^^^ n"
52.62 - realpow_minus_oneI "-1 ^^^ (2 * n) = 1"
52.63 -
52.64 - realpow_twoI "r ^^^ 2 = r * r"
52.65 - realpow_twoI_assoc_l "r * (r * s) = r ^^^ 2 * s"
52.66 - realpow_twoI_assoc_r "s * r * r = s * r ^^^ 2"
52.67 - realpow_two_atom "r is_atom ==> r * r = r ^^^ 2"
52.68 - realpow_plus_1 "r * r ^^^ n = r ^^^ (n + 1)"
52.69 - realpow_plus_1_assoc_l "r * (r ^^^ m * s) = r ^^^ (1 + m) * s"
52.70 - realpow_plus_1_assoc_l2 "r ^^^ m * (r * s) = r ^^^ (1 + m) * s"
52.71 - realpow_plus_1_assoc_r "s * r * r ^^^ m = s * r ^^^ (1 + m)"
52.72 - realpow_plus_1_atom "r is_atom ==> r * r ^^^ n = r ^^^ (1 + n)"
52.73 - realpow_def_atom "[| Not (r is_atom); 1 < n |] \
52.74 - \ ==> r ^^^ n = r * r ^^^ (n + -1)"
52.75 - realpow_addI_atom "r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"
52.76 -
52.77 -
52.78 - realpow_minus_even "n is_even ==> (- r) ^^^ n = r ^^^ n"
52.79 - realpow_minus_odd "Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"
52.80 -
52.81 -
52.82 -(* RL 020914 *)
52.83 - real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d"
52.84 - real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d"
52.85 - real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d"
52.86 - real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d"
52.87 - real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
52.88 - real_plus_binom_pow3_poly "[| a is_polyexp; b is_polyexp |] ==> \
52.89 - \(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
52.90 - real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3"
52.91 - real_minus_binom_pow3_p "(a + -1 * b)^^^3 = a^^^3 + -3*a^^^2*b + 3*a*b^^^2 + -1*b^^^3"
52.92 -(* real_plus_binom_pow "[| n is_const; 3 < n |] ==> \
52.93 - \(a + b)^^^n = (a + b) * (a + b)^^^(n - 1)" *)
52.94 - real_plus_binom_pow4 "(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)"
52.95 - real_plus_binom_pow4_poly "[| a is_polyexp; b is_polyexp |] ==> \
52.96 - \(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)"
52.97 - real_plus_binom_pow5 "(a + b)^^^5 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a^^^2 + 2*a*b + b^^^2)"
52.98 -
52.99 - real_plus_binom_pow5_poly "[| a is_polyexp; b is_polyexp |] ==> \
52.100 - \(a + b)^^^5 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a^^^2 + 2*a*b + b^^^2)"
52.101 -
52.102 - real_diff_plus "a - b = a + -b" (*17.3.03: do_NOT_use*)
52.103 - real_diff_minus "a - b = a + -1 * b"
52.104 - real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2"
52.105 - real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2"
52.106 - (*WN071229 changed for Schaerding -----vvv*)
52.107 - (*real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
52.108 - real_plus_binom_pow2 "(a + b)^^^2 = (a + b) * (a + b)"
52.109 - (*WN071229 changed for Schaerding -----^^^*)
52.110 - real_plus_binom_pow2_poly "[| a is_polyexp; b is_polyexp |] ==> \
52.111 - \(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"
52.112 - real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2"
52.113 - real_minus_binom_pow2_p "(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2"
52.114 - real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2"
52.115 - real_plus_minus_binom1_p "(a + b)*(a - b) = a^^^2 + -1*b^^^2"
52.116 - real_plus_minus_binom1_p_p "(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"
52.117 - real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2"
52.118 - real_plus_minus_binom2_p "(a - b)*(a + b) = a^^^2 + -1*b^^^2"
52.119 - real_plus_minus_binom2_p_p "(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"
52.120 - real_plus_binom_times1 "(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2"
52.121 - real_plus_binom_times2 "(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2"
52.122 -
52.123 - real_num_collect "[| l is_const; m is_const |] ==> \
52.124 - \l * n + m * n = (l + m) * n"
52.125 -(* FIXME.MG.0401: replace 'real_num_collect_assoc'
52.126 - by 'real_num_collect_assoc_l' ... are equal, introduced by MG ! *)
52.127 - real_num_collect_assoc "[| l is_const; m is_const |] ==> \
52.128 - \l * n + (m * n + k) = (l + m) * n + k"
52.129 - real_num_collect_assoc_l "[| l is_const; m is_const |] ==> \
52.130 - \l * n + (m * n + k) = (l + m)
52.131 - * n + k"
52.132 - real_num_collect_assoc_r "[| l is_const; m is_const |] ==> \
52.133 - \(k + m * n) + l * n = k + (l + m) * n"
52.134 - real_one_collect "m is_const ==> n + m * n = (1 + m) * n"
52.135 -(* FIXME.MG.0401: replace 'real_one_collect_assoc'
52.136 - by 'real_one_collect_assoc_l' ... are equal, introduced by MG ! *)
52.137 - real_one_collect_assoc "m is_const ==> n + (m * n + k) = (1 + m)* n + k"
52.138 -
52.139 - real_one_collect_assoc_l "m is_const ==> n + (m * n + k) = (1 + m) * n + k"
52.140 - real_one_collect_assoc_r "m is_const ==>(k + n) + m * n = k + (1 + m) * n"
52.141 -
52.142 -(* FIXME.MG.0401: replace 'real_mult_2_assoc'
52.143 - by 'real_mult_2_assoc_l' ... are equal, introduced by MG ! *)
52.144 - real_mult_2_assoc "z1 + (z1 + k) = 2 * z1 + k"
52.145 - real_mult_2_assoc_l "z1 + (z1 + k) = 2 * z1 + k"
52.146 - real_mult_2_assoc_r "(k + z1) + z1 = k + 2 * z1"
52.147 -
52.148 - real_add_mult_distrib_poly "w is_polyexp ==> (z1 + z2) * w = z1 * w + z2 * w"
52.149 - real_add_mult_distrib2_poly "w is_polyexp ==> w * (z1 + z2) = w * z1 + w * z2"
52.150 -end
53.1 --- a/src/Tools/isac/IsacKnowledge/PolyEq.ML Wed Aug 25 15:15:01 2010 +0200
53.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
53.3 @@ -1,1162 +0,0 @@
53.4 -(*. (c) by Richard Lang, 2003 .*)
53.5 -(* collecting all knowledge for PolynomialEquations
53.6 - created by: rlang
53.7 - date: 02.07
53.8 - changed by: rlang
53.9 - last change by: rlang
53.10 - date: 02.11.26
53.11 -*)
53.12 -
53.13 -(* use"IsacKnowledge/PolyEq.ML";
53.14 - use"PolyEq.ML";
53.15 -
53.16 - use"ROOT.ML";
53.17 - cd"IsacKnowledge";
53.18 -
53.19 - remove_thy"PolyEq";
53.20 - use_thy"IsacKnowledge/Isac";
53.21 - *)
53.22 -"******* PolyEq.ML begin *******";
53.23 -
53.24 -theory' := overwritel (!theory', [("PolyEq.thy",PolyEq.thy)]);
53.25 -(*-------------------------functions---------------------*)
53.26 -(* just for try
53.27 -local
53.28 - fun add0 l d d_ = if (d_+1) < d then add0 (str2term"0"::l) d (d_+1) else l;
53.29 - fun poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("Atools.pow",_) $ v_ $ Free (d_,_)))) v l d =
53.30 - if (v=v_)
53.31 - then poly2list_ t1 v (((str2term("1")))::(add0 l d (int_of_str' d_))) (int_of_str' d_)
53.32 - else t::(add0 l d 0)
53.33 - | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $
53.34 - (Const ("Atools.pow",_) $ v_ $ Free (d_,_))))) v l d =
53.35 - if (v=v_)
53.36 - then poly2list_ t1 v (((t11))::(add0 l d (int_of_str' d_))) (int_of_str' d_)
53.37 - else t::(add0 l d 0)
53.38 - | poly2list_ (t as (Const ("op +",_) $ t1 $ (Free (v_ , _)) )) v l d =
53.39 - if (v = (str2term v_))
53.40 - then poly2list_ t1 v (((str2term("1")))::(add0 l d 1 )) 1
53.41 - else t::(add0 l d 0)
53.42 - | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $ (Free (v_,_)) ))) v l d =
53.43 - if (v= (str2term v_))
53.44 - then poly2list_ t1 v ( (t11)::(add0 l d 1 )) 1
53.45 - else t::(add0 l d 0)
53.46 - | poly2list_ (t as (Const ("op +",_) $ _ $ _))_ l d = t::(add0 l d 0)
53.47 - | poly2list_ (t as (Free (_,_))) _ l d = t::(add0 l d 0)
53.48 - | poly2list_ t _ l d = t::(add0 l d 0);
53.49 -
53.50 - fun poly2list t v = poly2list_ t v [] 0;
53.51 - fun diffpolylist_ [] _ = []
53.52 - | diffpolylist_ (x::xs) d = (str2term (if term2str(x)="0"
53.53 - then "0"
53.54 - else term2str(x)^"*"^str_of_int(d)))::diffpolylist_ xs (d+1);
53.55 - fun diffpolylist [] = []
53.56 - | diffpolylist (x::xs) = diffpolylist_ xs 1;
53.57 - (* diffpolylist(poly2list (str2term "1+ x +3*x^^^3") (str2term "x"));*)
53.58 -in
53.59 -
53.60 -end;
53.61 -*)
53.62 -(*-------------------------rulse-------------------------*)
53.63 -val PolyEq_prls = (*3.10.02:just the following order due to subterm evaluation*)
53.64 - append_rls "PolyEq_prls" e_rls
53.65 - [Calc ("Atools.ident",eval_ident "#ident_"),
53.66 - Calc ("Tools.matches",eval_matches ""),
53.67 - Calc ("Tools.lhs" ,eval_lhs ""),
53.68 - Calc ("Tools.rhs" ,eval_rhs ""),
53.69 - Calc ("Poly.is'_expanded'_in",eval_is_expanded_in ""),
53.70 - Calc ("Poly.is'_poly'_in",eval_is_poly_in ""),
53.71 - Calc ("Poly.has'_degree'_in",eval_has_degree_in ""),
53.72 - Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""),
53.73 - (*Calc ("Atools.occurs'_in",eval_occurs_in ""), *)
53.74 - (*Calc ("Atools.is'_const",eval_const "#is_const_"),*)
53.75 - Calc ("op =",eval_equal "#equal_"),
53.76 - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""),
53.77 - Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""),
53.78 - Thm ("not_true",num_str not_true),
53.79 - Thm ("not_false",num_str not_false),
53.80 - Thm ("and_true",num_str and_true),
53.81 - Thm ("and_false",num_str and_false),
53.82 - Thm ("or_true",num_str or_true),
53.83 - Thm ("or_false",num_str or_false)
53.84 - ];
53.85 -
53.86 -val PolyEq_erls =
53.87 - merge_rls "PolyEq_erls" LinEq_erls
53.88 - (append_rls "ops_preds" calculate_Rational
53.89 - [Calc ("op =",eval_equal "#equal_"),
53.90 - Thm ("plus_leq", num_str plus_leq),
53.91 - Thm ("minus_leq", num_str minus_leq),
53.92 - Thm ("rat_leq1", num_str rat_leq1),
53.93 - Thm ("rat_leq2", num_str rat_leq2),
53.94 - Thm ("rat_leq3", num_str rat_leq3)
53.95 - ]);
53.96 -
53.97 -val PolyEq_crls =
53.98 - merge_rls "PolyEq_crls" LinEq_crls
53.99 - (append_rls "ops_preds" calculate_Rational
53.100 - [Calc ("op =",eval_equal "#equal_"),
53.101 - Thm ("plus_leq", num_str plus_leq),
53.102 - Thm ("minus_leq", num_str minus_leq),
53.103 - Thm ("rat_leq1", num_str rat_leq1),
53.104 - Thm ("rat_leq2", num_str rat_leq2),
53.105 - Thm ("rat_leq3", num_str rat_leq3)
53.106 - ]);
53.107 -(*------
53.108 -val PolyEq_erls =
53.109 - merge_rls "PolyEq_erls"
53.110 - (append_rls "" (Rls {(*asm_thm=[],*)calc=[],
53.111 - erls= Rls {(*asm_thm=[],*)calc=[],
53.112 - erls= Erls,
53.113 - id="e_rls",preconds=[],
53.114 - rew_ord=("dummy_ord",dummy_ord),
53.115 - rules=[Thm ("",
53.116 - num_str ),
53.117 - Thm ("",
53.118 - num_str ),
53.119 - Thm ("",
53.120 - num_str )
53.121 - ],
53.122 - scr=EmptyScr,srls=Erls},
53.123 - id="e_rls",preconds=[],rew_ord=("dummy_ord",
53.124 - dummy_ord),
53.125 - rules=[],scr=EmptyScr,srls=Erls}
53.126 - )
53.127 - ((#rules o rep_rls) LinEq_erls))
53.128 - (append_rls "ops_preds" calculate_Rational
53.129 - [Calc ("op =",eval_equal "#equal_"),
53.130 - Thm ("plus_leq", num_str plus_leq),
53.131 - Thm ("minus_leq", num_str minus_leq),
53.132 - Thm ("rat_leq1", num_str rat_leq1),
53.133 - Thm ("rat_leq2", num_str rat_leq2),
53.134 - Thm ("rat_leq3", num_str rat_leq3)
53.135 - ]);
53.136 ------*)
53.137 -
53.138 -
53.139 -val cancel_leading_coeff = prep_rls(
53.140 - Rls {id = "cancel_leading_coeff", preconds = [],
53.141 - rew_ord = ("e_rew_ord",e_rew_ord),
53.142 - erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*)
53.143 - rules = [Thm ("cancel_leading_coeff1",num_str cancel_leading_coeff1),
53.144 - Thm ("cancel_leading_coeff2",num_str cancel_leading_coeff2),
53.145 - Thm ("cancel_leading_coeff3",num_str cancel_leading_coeff3),
53.146 - Thm ("cancel_leading_coeff4",num_str cancel_leading_coeff4),
53.147 - Thm ("cancel_leading_coeff5",num_str cancel_leading_coeff5),
53.148 - Thm ("cancel_leading_coeff6",num_str cancel_leading_coeff6),
53.149 - Thm ("cancel_leading_coeff7",num_str cancel_leading_coeff7),
53.150 - Thm ("cancel_leading_coeff8",num_str cancel_leading_coeff8),
53.151 - Thm ("cancel_leading_coeff9",num_str cancel_leading_coeff9),
53.152 - Thm ("cancel_leading_coeff10",num_str cancel_leading_coeff10),
53.153 - Thm ("cancel_leading_coeff11",num_str cancel_leading_coeff11),
53.154 - Thm ("cancel_leading_coeff12",num_str cancel_leading_coeff12),
53.155 - Thm ("cancel_leading_coeff13",num_str cancel_leading_coeff13)
53.156 - ],
53.157 - scr = Script ((term_of o the o (parse thy))
53.158 - "empty_script")
53.159 - }:rls);
53.160 -val complete_square = prep_rls(
53.161 - Rls {id = "complete_square", preconds = [],
53.162 - rew_ord = ("e_rew_ord",e_rew_ord),
53.163 - erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*)
53.164 - rules = [Thm ("complete_square1",num_str complete_square1),
53.165 - Thm ("complete_square2",num_str complete_square2),
53.166 - Thm ("complete_square3",num_str complete_square3),
53.167 - Thm ("complete_square4",num_str complete_square4),
53.168 - Thm ("complete_square5",num_str complete_square5)
53.169 - ],
53.170 - scr = Script ((term_of o the o (parse thy))
53.171 - "empty_script")
53.172 - }:rls);
53.173 -ruleset' := overwritelthy thy (!ruleset',
53.174 - [("cancel_leading_coeff",cancel_leading_coeff),
53.175 - ("complete_square",complete_square),
53.176 - ("PolyEq_erls",PolyEq_erls)(*FIXXXME:del with rls.rls'*)
53.177 - ]);
53.178 -val polyeq_simplify = prep_rls(
53.179 - Rls {id = "polyeq_simplify", preconds = [],
53.180 - rew_ord = ("termlessI",termlessI),
53.181 - erls = PolyEq_erls,
53.182 - srls = Erls,
53.183 - calc = [],
53.184 - (*asm_thm = [],*)
53.185 - rules = [Thm ("real_assoc_1",num_str real_assoc_1),
53.186 - Thm ("real_assoc_2",num_str real_assoc_2),
53.187 - Thm ("real_diff_minus",num_str real_diff_minus),
53.188 - Thm ("real_unari_minus",num_str real_unari_minus),
53.189 - Thm ("realpow_multI",num_str realpow_multI),
53.190 - Calc ("op +",eval_binop "#add_"),
53.191 - Calc ("op -",eval_binop "#sub_"),
53.192 - Calc ("op *",eval_binop "#mult_"),
53.193 - Calc ("HOL.divide", eval_cancel "#divide_"),
53.194 - Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
53.195 - Calc ("Atools.pow" ,eval_binop "#power_"),
53.196 - Rls_ reduce_012
53.197 - ],
53.198 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.199 - }:rls);
53.200 -ruleset' := overwritelthy thy (!ruleset',
53.201 - [("polyeq_simplify",polyeq_simplify)]);
53.202 -
53.203 -
53.204 -(* ------------- polySolve ------------------ *)
53.205 -(* -- d0 -- *)
53.206 -(*isolate the bound variable in an d0 equation; 'bdv' is a meta-constant*)
53.207 -val d0_polyeq_simplify = prep_rls(
53.208 - Rls {id = "d0_polyeq_simplify", preconds = [],
53.209 - rew_ord = ("e_rew_ord",e_rew_ord),
53.210 - erls = PolyEq_erls,
53.211 - srls = Erls,
53.212 - calc = [],
53.213 - (*asm_thm = [],*)
53.214 - rules = [Thm("d0_true",num_str d0_true),
53.215 - Thm("d0_false",num_str d0_false)
53.216 - ],
53.217 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.218 - }:rls);
53.219 -(* -- d1 -- *)
53.220 -(*isolate the bound variable in an d1 equation; 'bdv' is a meta-constant*)
53.221 -val d1_polyeq_simplify = prep_rls(
53.222 - Rls {id = "d1_polyeq_simplify", preconds = [],
53.223 - rew_ord = ("e_rew_ord",e_rew_ord),
53.224 - erls = PolyEq_erls,
53.225 - srls = Erls,
53.226 - calc = [],
53.227 - (*asm_thm = [("d1_isolate_div","")],*)
53.228 - rules = [
53.229 - Thm("d1_isolate_add1",num_str d1_isolate_add1),
53.230 - (* a+bx=0 -> bx=-a *)
53.231 - Thm("d1_isolate_add2",num_str d1_isolate_add2),
53.232 - (* a+ x=0 -> x=-a *)
53.233 - Thm("d1_isolate_div",num_str d1_isolate_div)
53.234 - (* bx=c -> x=c/b *)
53.235 - ],
53.236 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.237 - }:rls);
53.238 -(* -- d2 -- *)
53.239 -(*isolate the bound variable in an d2 equation with bdv only; 'bdv' is a meta-constant*)
53.240 -val d2_polyeq_bdv_only_simplify = prep_rls(
53.241 - Rls {id = "d2_polyeq_bdv_only_simplify", preconds = [],
53.242 - rew_ord = ("e_rew_ord",e_rew_ord),
53.243 - erls = PolyEq_erls,
53.244 - srls = Erls,
53.245 - calc = [],
53.246 - (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""),
53.247 - ("d2_isolate_div","")],*)
53.248 - rules = [
53.249 - Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *)
53.250 - Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *)
53.251 - Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *)
53.252 - Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *)
53.253 - Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*)
53.254 - Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg), (* [0<c] x^2=c -> [] *)
53.255 - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *)
53.256 - Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*)
53.257 - Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*)
53.258 - Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*)
53.259 - ],
53.260 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.261 - }:rls);
53.262 -(*isolate the bound variable in an d2 equation with sqrt only; 'bdv' is a meta-constant*)
53.263 -val d2_polyeq_sq_only_simplify = prep_rls(
53.264 - Rls {id = "d2_polyeq_sq_only_simplify", preconds = [],
53.265 - rew_ord = ("e_rew_ord",e_rew_ord),
53.266 - erls = PolyEq_erls,
53.267 - srls = Erls,
53.268 - calc = [],
53.269 - (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""),
53.270 - ("d2_isolate_div","")],*)
53.271 - rules = [
53.272 - Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*)
53.273 - Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*)
53.274 - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *)
53.275 - Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*)
53.276 - Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[] *)
53.277 - Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*)
53.278 - ],
53.279 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.280 - }:rls);
53.281 -(*isolate the bound variable in an d2 equation with pqFormula; 'bdv' is a meta-constant*)
53.282 -val d2_polyeq_pqFormula_simplify = prep_rls(
53.283 - Rls {id = "d2_polyeq_pqFormula_simplify", preconds = [],
53.284 - rew_ord = ("e_rew_ord",e_rew_ord),
53.285 - erls = PolyEq_erls,
53.286 - srls = Erls,
53.287 - calc = [],
53.288 - (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""),
53.289 - ("d2_pqformula5",""),("d2_pqformula6",""),("d2_pqformula7",""),("d2_pqformula8",""),
53.290 - ("d2_pqformula9",""),("d2_pqformula10",""),
53.291 - ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),
53.292 - ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""),("d2_pqformula10_neg","")],*)
53.293 - rules = [
53.294 - Thm("d2_pqformula1",num_str d2_pqformula1), (* q+px+ x^2=0 *)
53.295 - Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* q+px+ x^2=0 *)
53.296 - Thm("d2_pqformula2",num_str d2_pqformula2), (* q+px+1x^2=0 *)
53.297 - Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* q+px+1x^2=0 *)
53.298 - Thm("d2_pqformula3",num_str d2_pqformula3), (* q+ x+ x^2=0 *)
53.299 - Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* q+ x+ x^2=0 *)
53.300 - Thm("d2_pqformula4",num_str d2_pqformula4), (* q+ x+1x^2=0 *)
53.301 - Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* q+ x+1x^2=0 *)
53.302 - Thm("d2_pqformula5",num_str d2_pqformula5), (* qx+ x^2=0 *)
53.303 - Thm("d2_pqformula6",num_str d2_pqformula6), (* qx+1x^2=0 *)
53.304 - Thm("d2_pqformula7",num_str d2_pqformula7), (* x+ x^2=0 *)
53.305 - Thm("d2_pqformula8",num_str d2_pqformula8), (* x+1x^2=0 *)
53.306 - Thm("d2_pqformula9",num_str d2_pqformula9), (* q +1x^2=0 *)
53.307 - Thm("d2_pqformula9_neg",num_str d2_pqformula9_neg), (* q +1x^2=0 *)
53.308 - Thm("d2_pqformula10",num_str d2_pqformula10), (* q + x^2=0 *)
53.309 - Thm("d2_pqformula10_neg",num_str d2_pqformula10_neg), (* q + x^2=0 *)
53.310 - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *)
53.311 - Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* 1x^2=0 *)
53.312 - ],
53.313 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.314 - }:rls);
53.315 -(*isolate the bound variable in an d2 equation with abcFormula; 'bdv' is a meta-constant*)
53.316 -val d2_polyeq_abcFormula_simplify = prep_rls(
53.317 - Rls {id = "d2_polyeq_abcFormula_simplify", preconds = [],
53.318 - rew_ord = ("e_rew_ord",e_rew_ord),
53.319 - erls = PolyEq_erls,
53.320 - srls = Erls,
53.321 - calc = [],
53.322 - (*asm_thm = [("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""),
53.323 - ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""),
53.324 - ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""),
53.325 - ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""),
53.326 - ("d2_abcformula3_neg",""),("d2_abcformula4_neg",""),("d2_abcformula5_neg",""),
53.327 - ("d2_abcformula6_neg","")],*)
53.328 - rules = [
53.329 - Thm("d2_abcformula1",num_str d2_abcformula1), (*c+bx+cx^2=0 *)
53.330 - Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (*c+bx+cx^2=0 *)
53.331 - Thm("d2_abcformula2",num_str d2_abcformula2), (*c+ x+cx^2=0 *)
53.332 - Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (*c+ x+cx^2=0 *)
53.333 - Thm("d2_abcformula3",num_str d2_abcformula3), (*c+bx+ x^2=0 *)
53.334 - Thm("d2_abcformula3_neg",num_str d2_abcformula3_neg), (*c+bx+ x^2=0 *)
53.335 - Thm("d2_abcformula4",num_str d2_abcformula4), (*c+ x+ x^2=0 *)
53.336 - Thm("d2_abcformula4_neg",num_str d2_abcformula4_neg), (*c+ x+ x^2=0 *)
53.337 - Thm("d2_abcformula5",num_str d2_abcformula5), (*c+ cx^2=0 *)
53.338 - Thm("d2_abcformula5_neg",num_str d2_abcformula5_neg), (*c+ cx^2=0 *)
53.339 - Thm("d2_abcformula6",num_str d2_abcformula6), (*c+ x^2=0 *)
53.340 - Thm("d2_abcformula6_neg",num_str d2_abcformula6_neg), (*c+ x^2=0 *)
53.341 - Thm("d2_abcformula7",num_str d2_abcformula7), (* bx+ax^2=0 *)
53.342 - Thm("d2_abcformula8",num_str d2_abcformula8), (* bx+ x^2=0 *)
53.343 - Thm("d2_abcformula9",num_str d2_abcformula9), (* x+ax^2=0 *)
53.344 - Thm("d2_abcformula10",num_str d2_abcformula10), (* x+ x^2=0 *)
53.345 - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *)
53.346 - Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* bx^2=0 *)
53.347 - ],
53.348 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.349 - }:rls);
53.350 -(*isolate the bound variable in an d2 equation; 'bdv' is a meta-constant*)
53.351 -val d2_polyeq_simplify = prep_rls(
53.352 - Rls {id = "d2_polyeq_simplify", preconds = [],
53.353 - rew_ord = ("e_rew_ord",e_rew_ord),
53.354 - erls = PolyEq_erls,
53.355 - srls = Erls,
53.356 - calc = [],
53.357 - (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""),
53.358 - ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),
53.359 - ("d2_pqformula4_neg",""),
53.360 - ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""),
53.361 - ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""),
53.362 - ("d2_sqrt_equation1_neg",""),("d2_isolate_div","")],*)
53.363 - rules = [
53.364 - Thm("d2_pqformula1",num_str d2_pqformula1), (* p+qx+ x^2=0 *)
53.365 - Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* p+qx+ x^2=0 *)
53.366 - Thm("d2_pqformula2",num_str d2_pqformula2), (* p+qx+1x^2=0 *)
53.367 - Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* p+qx+1x^2=0 *)
53.368 - Thm("d2_pqformula3",num_str d2_pqformula3), (* p+ x+ x^2=0 *)
53.369 - Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* p+ x+ x^2=0 *)
53.370 - Thm("d2_pqformula4",num_str d2_pqformula4), (* p+ x+1x^2=0 *)
53.371 - Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* p+ x+1x^2=0 *)
53.372 - Thm("d2_abcformula1",num_str d2_abcformula1), (* c+bx+cx^2=0 *)
53.373 - Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (* c+bx+cx^2=0 *)
53.374 - Thm("d2_abcformula2",num_str d2_abcformula2), (* c+ x+cx^2=0 *)
53.375 - Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (* c+ x+cx^2=0 *)
53.376 - Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *)
53.377 - Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *)
53.378 - Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *)
53.379 - Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *)
53.380 - Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*)
53.381 - Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*)
53.382 - Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*)
53.383 - Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[]*)
53.384 - Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *)
53.385 - Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*)
53.386 - Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*)
53.387 - Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*)
53.388 - ],
53.389 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.390 - }:rls);
53.391 -(* -- d3 -- *)
53.392 -(*isolate the bound variable in an d3 equation; 'bdv' is a meta-constant*)
53.393 -val d3_polyeq_simplify = prep_rls(
53.394 - Rls {id = "d3_polyeq_simplify", preconds = [],
53.395 - rew_ord = ("e_rew_ord",e_rew_ord),
53.396 - erls = PolyEq_erls,
53.397 - srls = Erls,
53.398 - calc = [],
53.399 - (*asm_thm = [("d3_isolate_div","")],*)
53.400 - rules = [
53.401 - Thm("d3_reduce_equation1",num_str d3_reduce_equation1),
53.402 - (*a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0)*)
53.403 - Thm("d3_reduce_equation2",num_str d3_reduce_equation2),
53.404 - (* bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0)*)
53.405 - Thm("d3_reduce_equation3",num_str d3_reduce_equation3),
53.406 - (*a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0)*)
53.407 - Thm("d3_reduce_equation4",num_str d3_reduce_equation4),
53.408 - (* bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0)*)
53.409 - Thm("d3_reduce_equation5",num_str d3_reduce_equation5),
53.410 - (*a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0)*)
53.411 - Thm("d3_reduce_equation6",num_str d3_reduce_equation6),
53.412 - (* bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0)*)
53.413 - Thm("d3_reduce_equation7",num_str d3_reduce_equation7),
53.414 - (*a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*)
53.415 - Thm("d3_reduce_equation8",num_str d3_reduce_equation8),
53.416 - (* bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*)
53.417 - Thm("d3_reduce_equation9",num_str d3_reduce_equation9),
53.418 - (*a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0)*)
53.419 - Thm("d3_reduce_equation10",num_str d3_reduce_equation10),
53.420 - (* bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0)*)
53.421 - Thm("d3_reduce_equation11",num_str d3_reduce_equation11),
53.422 - (*a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0)*)
53.423 - Thm("d3_reduce_equation12",num_str d3_reduce_equation12),
53.424 - (* bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0)*)
53.425 - Thm("d3_reduce_equation13",num_str d3_reduce_equation13),
53.426 - (* b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0)*)
53.427 - Thm("d3_reduce_equation14",num_str d3_reduce_equation14),
53.428 - (* bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0)*)
53.429 - Thm("d3_reduce_equation15",num_str d3_reduce_equation15),
53.430 - (* b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0)*)
53.431 - Thm("d3_reduce_equation16",num_str d3_reduce_equation16),
53.432 - (* bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0)*)
53.433 - Thm("d3_isolate_add1",num_str d3_isolate_add1),
53.434 - (*[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (bdv=0 | (b*bdv^^^3=a)*)
53.435 - Thm("d3_isolate_add2",num_str d3_isolate_add2),
53.436 - (*[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = (bdv=0 | ( bdv^^^3=a)*)
53.437 - Thm("d3_isolate_div",num_str d3_isolate_div),
53.438 - (*[|Not(b=0)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b*)
53.439 - Thm("d3_root_equation2",num_str d3_root_equation2),
53.440 - (*(bdv^^^3=0) = (bdv=0) *)
53.441 - Thm("d3_root_equation1",num_str d3_root_equation1)
53.442 - (*bdv^^^3=c) = (bdv = nroot 3 c*)
53.443 - ],
53.444 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.445 - }:rls);
53.446 -(* -- d4 -- *)
53.447 -(*isolate the bound variable in an d4 equation; 'bdv' is a meta-constant*)
53.448 -val d4_polyeq_simplify = prep_rls(
53.449 - Rls {id = "d4_polyeq_simplify", preconds = [],
53.450 - rew_ord = ("e_rew_ord",e_rew_ord),
53.451 - erls = PolyEq_erls,
53.452 - srls = Erls,
53.453 - calc = [],
53.454 - (*asm_thm = [],*)
53.455 - rules = [Thm("d4_sub_u1",num_str d4_sub_u1)
53.456 - (* ax^4+bx^2+c=0 -> x=+-sqrt(ax^2+bx^+c) *)
53.457 - ],
53.458 - scr = Script ((term_of o the o (parse thy)) "empty_script")
53.459 - }:rls);
53.460 -
53.461 -ruleset' := overwritelthy thy (!ruleset',
53.462 - [("d0_polyeq_simplify", d0_polyeq_simplify),
53.463 - ("d1_polyeq_simplify", d1_polyeq_simplify),
53.464 - ("d2_polyeq_simplify", d2_polyeq_simplify),
53.465 - ("d2_polyeq_bdv_only_simplify", d2_polyeq_bdv_only_simplify),
53.466 - ("d2_polyeq_sq_only_simplify", d2_polyeq_sq_only_simplify),
53.467 - ("d2_polyeq_pqFormula_simplify", d2_polyeq_pqFormula_simplify),
53.468 - ("d2_polyeq_abcFormula_simplify", d2_polyeq_abcFormula_simplify),
53.469 - ("d3_polyeq_simplify", d3_polyeq_simplify),
53.470 - ("d4_polyeq_simplify", d4_polyeq_simplify)
53.471 - ]);
53.472 -
53.473 -(*------------------------problems------------------------*)
53.474 -(*
53.475 -(get_pbt ["degree_2","polynomial","univariate","equation"]);
53.476 -show_ptyps();
53.477 -*)
53.478 -
53.479 -(*-------------------------poly-----------------------*)
53.480 -store_pbt
53.481 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly" [] e_pblID
53.482 - (["polynomial","univariate","equation"],
53.483 - [("#Given" ,["equality e_","solveFor v_"]),
53.484 - ("#Where" ,["~((e_::bool) is_ratequation_in (v_::real))",
53.485 - "~((lhs e_) is_rootTerm_in (v_::real))",
53.486 - "~((rhs e_) is_rootTerm_in (v_::real))"]),
53.487 - ("#Find" ,["solutions v_i_"])
53.488 - ],
53.489 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.490 - []));
53.491 -(*--- d0 ---*)
53.492 -store_pbt
53.493 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg0" [] e_pblID
53.494 - (["degree_0","polynomial","univariate","equation"],
53.495 - [("#Given" ,["equality e_","solveFor v_"]),
53.496 - ("#Where" ,["matches (?a = 0) e_",
53.497 - "(lhs e_) is_poly_in v_",
53.498 - "((lhs e_) has_degree_in v_ ) = 0"
53.499 - ]),
53.500 - ("#Find" ,["solutions v_i_"])
53.501 - ],
53.502 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.503 - [["PolyEq","solve_d0_polyeq_equation"]]));
53.504 -
53.505 -(*--- d1 ---*)
53.506 -store_pbt
53.507 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg1" [] e_pblID
53.508 - (["degree_1","polynomial","univariate","equation"],
53.509 - [("#Given" ,["equality e_","solveFor v_"]),
53.510 - ("#Where" ,["matches (?a = 0) e_",
53.511 - "(lhs e_) is_poly_in v_",
53.512 - "((lhs e_) has_degree_in v_ ) = 1"
53.513 - ]),
53.514 - ("#Find" ,["solutions v_i_"])
53.515 - ],
53.516 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.517 - [["PolyEq","solve_d1_polyeq_equation"]]));
53.518 -
53.519 -(*--- d2 ---*)
53.520 -store_pbt
53.521 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2" [] e_pblID
53.522 - (["degree_2","polynomial","univariate","equation"],
53.523 - [("#Given" ,["equality e_","solveFor v_"]),
53.524 - ("#Where" ,["matches (?a = 0) e_",
53.525 - "(lhs e_) is_poly_in v_ ",
53.526 - "((lhs e_) has_degree_in v_ ) = 2"]),
53.527 - ("#Find" ,["solutions v_i_"])
53.528 - ],
53.529 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.530 - [["PolyEq","solve_d2_polyeq_equation"]]));
53.531 -
53.532 - store_pbt
53.533 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_sqonly" [] e_pblID
53.534 - (["sq_only","degree_2","polynomial","univariate","equation"],
53.535 - [("#Given" ,["equality e_","solveFor v_"]),
53.536 - ("#Where" ,["matches ( ?a + ?v_^^^2 = 0) e_ | \
53.537 - \matches ( ?a + ?b*?v_^^^2 = 0) e_ | \
53.538 - \matches ( ?v_^^^2 = 0) e_ | \
53.539 - \matches ( ?b*?v_^^^2 = 0) e_" ,
53.540 - "Not (matches (?a + ?v_ + ?v_^^^2 = 0) e_) &\
53.541 - \Not (matches (?a + ?b*?v_ + ?v_^^^2 = 0) e_) &\
53.542 - \Not (matches (?a + ?v_ + ?c*?v_^^^2 = 0) e_) &\
53.543 - \Not (matches (?a + ?b*?v_ + ?c*?v_^^^2 = 0) e_) &\
53.544 - \Not (matches ( ?v_ + ?v_^^^2 = 0) e_) &\
53.545 - \Not (matches ( ?b*?v_ + ?v_^^^2 = 0) e_) &\
53.546 - \Not (matches ( ?v_ + ?c*?v_^^^2 = 0) e_) &\
53.547 - \Not (matches ( ?b*?v_ + ?c*?v_^^^2 = 0) e_)"]),
53.548 - ("#Find" ,["solutions v_i_"])
53.549 - ],
53.550 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.551 - [["PolyEq","solve_d2_polyeq_sqonly_equation"]]));
53.552 -
53.553 -store_pbt
53.554 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_bdvonly" [] e_pblID
53.555 - (["bdv_only","degree_2","polynomial","univariate","equation"],
53.556 - [("#Given" ,["equality e_","solveFor v_"]),
53.557 - ("#Where" ,["matches (?a*?v_ + ?v_^^^2 = 0) e_ | \
53.558 - \matches ( ?v_ + ?v_^^^2 = 0) e_ | \
53.559 - \matches ( ?v_ + ?b*?v_^^^2 = 0) e_ | \
53.560 - \matches (?a*?v_ + ?b*?v_^^^2 = 0) e_ | \
53.561 - \matches ( ?v_^^^2 = 0) e_ | \
53.562 - \matches ( ?b*?v_^^^2 = 0) e_ "]),
53.563 - ("#Find" ,["solutions v_i_"])
53.564 - ],
53.565 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.566 - [["PolyEq","solve_d2_polyeq_bdvonly_equation"]]));
53.567 -
53.568 -store_pbt
53.569 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_pq" [] e_pblID
53.570 - (["pqFormula","degree_2","polynomial","univariate","equation"],
53.571 - [("#Given" ,["equality e_","solveFor v_"]),
53.572 - ("#Where" ,["matches (?a + 1*?v_^^^2 = 0) e_ | \
53.573 - \matches (?a + ?v_^^^2 = 0) e_"]),
53.574 - ("#Find" ,["solutions v_i_"])
53.575 - ],
53.576 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.577 - [["PolyEq","solve_d2_polyeq_pq_equation"]]));
53.578 -
53.579 -store_pbt
53.580 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_abc" [] e_pblID
53.581 - (["abcFormula","degree_2","polynomial","univariate","equation"],
53.582 - [("#Given" ,["equality e_","solveFor v_"]),
53.583 - ("#Where" ,["matches (?a + ?v_^^^2 = 0) e_ | \
53.584 - \matches (?a + ?b*?v_^^^2 = 0) e_"]),
53.585 - ("#Find" ,["solutions v_i_"])
53.586 - ],
53.587 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.588 - [["PolyEq","solve_d2_polyeq_abc_equation"]]));
53.589 -
53.590 -(*--- d3 ---*)
53.591 -store_pbt
53.592 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg3" [] e_pblID
53.593 - (["degree_3","polynomial","univariate","equation"],
53.594 - [("#Given" ,["equality e_","solveFor v_"]),
53.595 - ("#Where" ,["matches (?a = 0) e_",
53.596 - "(lhs e_) is_poly_in v_ ",
53.597 - "((lhs e_) has_degree_in v_) = 3"]),
53.598 - ("#Find" ,["solutions v_i_"])
53.599 - ],
53.600 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.601 - [["PolyEq","solve_d3_polyeq_equation"]]));
53.602 -
53.603 -(*--- d4 ---*)
53.604 -store_pbt
53.605 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg4" [] e_pblID
53.606 - (["degree_4","polynomial","univariate","equation"],
53.607 - [("#Given" ,["equality e_","solveFor v_"]),
53.608 - ("#Where" ,["matches (?a = 0) e_",
53.609 - "(lhs e_) is_poly_in v_ ",
53.610 - "((lhs e_) has_degree_in v_) = 4"]),
53.611 - ("#Find" ,["solutions v_i_"])
53.612 - ],
53.613 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.614 - [(*["PolyEq","solve_d4_polyeq_equation"]*)]));
53.615 -
53.616 -(*--- normalize ---*)
53.617 -store_pbt
53.618 - (prep_pbt PolyEq.thy "pbl_equ_univ_poly_norm" [] e_pblID
53.619 - (["normalize","polynomial","univariate","equation"],
53.620 - [("#Given" ,["equality e_","solveFor v_"]),
53.621 - ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\
53.622 - \(Not(((lhs e_) is_poly_in v_)))"]),
53.623 - ("#Find" ,["solutions v_i_"])
53.624 - ],
53.625 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.626 - [["PolyEq","normalize_poly"]]));
53.627 -(*-------------------------expanded-----------------------*)
53.628 -store_pbt
53.629 - (prep_pbt PolyEq.thy "pbl_equ_univ_expand" [] e_pblID
53.630 - (["expanded","univariate","equation"],
53.631 - [("#Given" ,["equality e_","solveFor v_"]),
53.632 - ("#Where" ,["matches (?a = 0) e_",
53.633 - "(lhs e_) is_expanded_in v_ "]),
53.634 - ("#Find" ,["solutions v_i_"])
53.635 - ],
53.636 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.637 - []));
53.638 -
53.639 -(*--- d2 ---*)
53.640 -store_pbt
53.641 - (prep_pbt PolyEq.thy "pbl_equ_univ_expand_deg2" [] e_pblID
53.642 - (["degree_2","expanded","univariate","equation"],
53.643 - [("#Given" ,["equality e_","solveFor v_"]),
53.644 - ("#Where" ,["((lhs e_) has_degree_in v_) = 2"]),
53.645 - ("#Find" ,["solutions v_i_"])
53.646 - ],
53.647 - PolyEq_prls, SOME "solve (e_::bool, v_)",
53.648 - [["PolyEq","complete_square"]]));
53.649 -
53.650 -
53.651 -"-------------------------methods-----------------------";
53.652 -store_met
53.653 - (prep_met PolyEq.thy "met_polyeq" [] e_metID
53.654 - (["PolyEq"],
53.655 - [],
53.656 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
53.657 - crls=PolyEq_crls, nrls=norm_Rational
53.658 - (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
53.659 -
53.660 -store_met
53.661 - (prep_met PolyEq.thy "met_polyeq_norm" [] e_metID
53.662 - (["PolyEq","normalize_poly"],
53.663 - [("#Given" ,["equality e_","solveFor v_"]),
53.664 - ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\
53.665 - \(Not(((lhs e_) is_poly_in v_)))"]),
53.666 - ("#Find" ,["solutions v_i_"])
53.667 - ],
53.668 - {rew_ord'="termlessI",
53.669 - rls'=PolyEq_erls,
53.670 - srls=e_rls,
53.671 - prls=PolyEq_prls,
53.672 - calc=[],
53.673 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.674 - asm_rls=[],
53.675 - asm_thm=[]*)},
53.676 - (*RL: Ratpoly loest Brueche ohne bdv*)
53.677 - "Script Normalize_poly (e_::bool) (v_::real) = \
53.678 - \(let e_ =((Try (Rewrite all_left False)) @@ \
53.679 - \ (Try (Repeat (Rewrite makex1_x False))) @@ \
53.680 - \ (Try (Repeat (Rewrite_Set expand_binoms False))) @@ \
53.681 - \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \
53.682 - \ make_ratpoly_in False))) @@ \
53.683 - \ (Try (Repeat (Rewrite_Set polyeq_simplify False)))) e_ \
53.684 - \ in (SubProblem (PolyEq_,[polynomial,univariate,equation], \
53.685 - \ [no_met]) [bool_ e_, real_ v_]))"
53.686 - ));
53.687 -
53.688 -store_met
53.689 - (prep_met PolyEq.thy "met_polyeq_d0" [] e_metID
53.690 - (["PolyEq","solve_d0_polyeq_equation"],
53.691 - [("#Given" ,["equality e_","solveFor v_"]),
53.692 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.693 - "((lhs e_) has_degree_in v_) = 0"]),
53.694 - ("#Find" ,["solutions v_i_"])
53.695 - ],
53.696 - {rew_ord'="termlessI",
53.697 - rls'=PolyEq_erls,
53.698 - srls=e_rls,
53.699 - prls=PolyEq_prls,
53.700 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.701 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.702 - asm_rls=[],
53.703 - asm_thm=[]*)},
53.704 - "Script Solve_d0_polyeq_equation (e_::bool) (v_::real) = \
53.705 - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.706 - \ d0_polyeq_simplify False))) e_ \
53.707 - \ in ((Or_to_List e_)::bool list))"
53.708 - ));
53.709 -
53.710 -store_met
53.711 - (prep_met PolyEq.thy "met_polyeq_d1" [] e_metID
53.712 - (["PolyEq","solve_d1_polyeq_equation"],
53.713 - [("#Given" ,["equality e_","solveFor v_"]),
53.714 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.715 - "((lhs e_) has_degree_in v_) = 1"]),
53.716 - ("#Find" ,["solutions v_i_"])
53.717 - ],
53.718 - {rew_ord'="termlessI",
53.719 - rls'=PolyEq_erls,
53.720 - srls=e_rls,
53.721 - prls=PolyEq_prls,
53.722 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.723 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.724 - (* asm_rls=["d1_polyeq_simplify"],*)
53.725 - asm_rls=[],
53.726 - asm_thm=[("d1_isolate_div","")]*)},
53.727 - "Script Solve_d1_polyeq_equation (e_::bool) (v_::real) = \
53.728 - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.729 - \ d1_polyeq_simplify True)) @@ \
53.730 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.731 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
53.732 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.733 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.734 - ));
53.735 -
53.736 -store_met
53.737 - (prep_met PolyEq.thy "met_polyeq_d22" [] e_metID
53.738 - (["PolyEq","solve_d2_polyeq_equation"],
53.739 - [("#Given" ,["equality e_","solveFor v_"]),
53.740 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.741 - "((lhs e_) has_degree_in v_) = 2"]),
53.742 - ("#Find" ,["solutions v_i_"])
53.743 - ],
53.744 - {rew_ord'="termlessI",
53.745 - rls'=PolyEq_erls,
53.746 - srls=e_rls,
53.747 - prls=PolyEq_prls,
53.748 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.749 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.750 - (*asm_rls=["d2_polyeq_simplify","d1_polyeq_simplify"],*)
53.751 - asm_rls=[],
53.752 - asm_thm = [("d1_isolate_div",""),("d2_pqformula1",""),("d2_pqformula2",""),
53.753 - ("d2_pqformula3",""),("d2_pqformula4",""),("d2_pqformula1_neg",""),
53.754 - ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),("d2_pqformula4_neg",""),
53.755 - ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""),
53.756 - ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""),
53.757 - ("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)},
53.758 - "Script Solve_d2_polyeq_equation (e_::bool) (v_::real) = \
53.759 - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.760 - \ d2_polyeq_simplify True)) @@ \
53.761 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.762 - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.763 - \ d1_polyeq_simplify True)) @@ \
53.764 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.765 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
53.766 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.767 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.768 - ));
53.769 -
53.770 -store_met
53.771 - (prep_met PolyEq.thy "met_polyeq_d2_bdvonly" [] e_metID
53.772 - (["PolyEq","solve_d2_polyeq_bdvonly_equation"],
53.773 - [("#Given" ,["equality e_","solveFor v_"]),
53.774 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.775 - "((lhs e_) has_degree_in v_) = 2"]),
53.776 - ("#Find" ,["solutions v_i_"])
53.777 - ],
53.778 - {rew_ord'="termlessI",
53.779 - rls'=PolyEq_erls,
53.780 - srls=e_rls,
53.781 - prls=PolyEq_prls,
53.782 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.783 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.784 - (*asm_rls=["d2_polyeq_bdv_only_simplify","d1_polyeq_simplify "],*)
53.785 - asm_rls=[],
53.786 - asm_thm=[("d1_isolate_div",""),("d2_isolate_div",""),
53.787 - ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg","")]*)},
53.788 - "Script Solve_d2_polyeq_bdvonly_equation (e_::bool) (v_::real) =\
53.789 - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.790 - \ d2_polyeq_bdv_only_simplify True)) @@ \
53.791 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.792 - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.793 - \ d1_polyeq_simplify True)) @@ \
53.794 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.795 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
53.796 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.797 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.798 - ));
53.799 -
53.800 -store_met
53.801 - (prep_met PolyEq.thy "met_polyeq_d2_sqonly" [] e_metID
53.802 - (["PolyEq","solve_d2_polyeq_sqonly_equation"],
53.803 - [("#Given" ,["equality e_","solveFor v_"]),
53.804 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.805 - "((lhs e_) has_degree_in v_) = 2"]),
53.806 - ("#Find" ,["solutions v_i_"])
53.807 - ],
53.808 - {rew_ord'="termlessI",
53.809 - rls'=PolyEq_erls,
53.810 - srls=e_rls,
53.811 - prls=PolyEq_prls,
53.812 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.813 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.814 - (*asm_rls=["d2_polyeq_sq_only_simplify"],*)
53.815 - asm_rls=[],
53.816 - asm_thm=[("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""),
53.817 - ("d2_isolate_div","")]*)},
53.818 - "Script Solve_d2_polyeq_sqonly_equation (e_::bool) (v_::real) =\
53.819 - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.820 - \ d2_polyeq_sq_only_simplify True)) @@ \
53.821 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.822 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_; \
53.823 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.824 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.825 - ));
53.826 -
53.827 -store_met
53.828 - (prep_met PolyEq.thy "met_polyeq_d2_pq" [] e_metID
53.829 - (["PolyEq","solve_d2_polyeq_pq_equation"],
53.830 - [("#Given" ,["equality e_","solveFor v_"]),
53.831 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.832 - "((lhs e_) has_degree_in v_) = 2"]),
53.833 - ("#Find" ,["solutions v_i_"])
53.834 - ],
53.835 - {rew_ord'="termlessI",
53.836 - rls'=PolyEq_erls,
53.837 - srls=e_rls,
53.838 - prls=PolyEq_prls,
53.839 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.840 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.841 - (*asm_rls=["d2_polyeq_pqFormula_simplify"],*)
53.842 - asm_rls=[],
53.843 - asm_thm=[("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),
53.844 - ("d2_pqformula4",""),("d2_pqformula5",""),("d2_pqformula6",""),
53.845 - ("d2_pqformula7",""),("d2_pqformula8",""),("d2_pqformula9",""),
53.846 - ("d2_pqformula10",""),("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),
53.847 - ("d2_pqformula3_neg",""), ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""),
53.848 - ("d2_pqformula10_neg","")]*)},
53.849 - "Script Solve_d2_polyeq_pq_equation (e_::bool) (v_::real) = \
53.850 - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.851 - \ d2_polyeq_pqFormula_simplify True)) @@ \
53.852 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.853 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
53.854 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.855 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.856 - ));
53.857 -
53.858 -store_met
53.859 - (prep_met PolyEq.thy "met_polyeq_d2_abc" [] e_metID
53.860 - (["PolyEq","solve_d2_polyeq_abc_equation"],
53.861 - [("#Given" ,["equality e_","solveFor v_"]),
53.862 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.863 - "((lhs e_) has_degree_in v_) = 2"]),
53.864 - ("#Find" ,["solutions v_i_"])
53.865 - ],
53.866 - {rew_ord'="termlessI",
53.867 - rls'=PolyEq_erls,
53.868 - srls=e_rls,
53.869 - prls=PolyEq_prls,
53.870 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.871 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.872 - (*asm_rls=["d2_polyeq_abcFormula_simplify"],*)
53.873 - asm_rls=[],
53.874 - asm_thm=[("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""),
53.875 - ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""),
53.876 - ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""),
53.877 - ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""),
53.878 - ("d2_abcformula3_neg",""), ("d2_abcformula4_neg",""),("d2_abcformula5_neg",""),
53.879 - ("d2_abcformula6_neg","")]*)},
53.880 - "Script Solve_d2_polyeq_abc_equation (e_::bool) (v_::real) = \
53.881 - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.882 - \ d2_polyeq_abcFormula_simplify True)) @@ \
53.883 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.884 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
53.885 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.886 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.887 - ));
53.888 -
53.889 -store_met
53.890 - (prep_met PolyEq.thy "met_polyeq_d3" [] e_metID
53.891 - (["PolyEq","solve_d3_polyeq_equation"],
53.892 - [("#Given" ,["equality e_","solveFor v_"]),
53.893 - ("#Where" ,["(lhs e_) is_poly_in v_ ",
53.894 - "((lhs e_) has_degree_in v_) = 3"]),
53.895 - ("#Find" ,["solutions v_i_"])
53.896 - ],
53.897 - {rew_ord'="termlessI",
53.898 - rls'=PolyEq_erls,
53.899 - srls=e_rls,
53.900 - prls=PolyEq_prls,
53.901 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.902 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.903 - (* asm_rls=["d1_polyeq_simplify","d2_polyeq_simplify","d1_polyeq_simplify"],*)
53.904 - asm_rls=[],
53.905 - asm_thm=[("d3_isolate_div",""),("d1_isolate_div",""),("d2_pqformula1",""),
53.906 - ("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""),
53.907 - ("d2_pqformula1_neg",""), ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),
53.908 - ("d2_pqformula4_neg",""), ("d2_abcformula1",""),("d2_abcformula2",""),
53.909 - ("d2_abcformula1_neg",""),("d2_abcformula2_neg",""),
53.910 - ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)},
53.911 - "Script Solve_d3_polyeq_equation (e_::bool) (v_::real) = \
53.912 - \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.913 - \ d3_polyeq_simplify True)) @@ \
53.914 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.915 - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.916 - \ d2_polyeq_simplify True)) @@ \
53.917 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.918 - \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
53.919 - \ d1_polyeq_simplify True)) @@ \
53.920 - \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
53.921 - \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
53.922 - \ (L_::bool list) = ((Or_to_List e_)::bool list) \
53.923 - \ in Check_elementwise L_ {(v_::real). Assumptions} )"
53.924 - ));
53.925 -
53.926 - (*.solves all expanded (ie. normalized) terms of degree 2.*)
53.927 - (*Oct.02 restriction: 'eval_true 0 =< discriminant' ony for integer values
53.928 - by 'PolyEq_erls'; restricted until Float.thy is implemented*)
53.929 -store_met
53.930 - (prep_met PolyEq.thy "met_polyeq_complsq" [] e_metID
53.931 - (["PolyEq","complete_square"],
53.932 - [("#Given" ,["equality e_","solveFor v_"]),
53.933 - ("#Where" ,["matches (?a = 0) e_",
53.934 - "((lhs e_) has_degree_in v_) = 2"]),
53.935 - ("#Find" ,["solutions v_i_"])
53.936 - ],
53.937 - {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls,
53.938 - calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
53.939 - crls=PolyEq_crls, nrls=norm_Rational(*,
53.940 - asm_rls=[],
53.941 - asm_thm=[("root_plus_minus","")]*)},
53.942 - "Script Complete_square (e_::bool) (v_::real) = \
53.943 - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\
53.944 - \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \
53.945 - \ @@ (Try (Rewrite square_explicit1 False)) \
53.946 - \ @@ (Try (Rewrite square_explicit2 False)) \
53.947 - \ @@ (Rewrite root_plus_minus True) \
53.948 - \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False))) \
53.949 - \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \
53.950 - \ @@ (Try (Repeat \
53.951 - \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \
53.952 - \ @@ (Try (Rewrite_Set calculate_RootRat False)) \
53.953 - \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \
53.954 - \ in ((Or_to_List e_)::bool list))"
53.955 - ));
53.956 -(*6.10.02: x^2=64: root_plus_minus -/-/->
53.957 - "Script Complete_square (e_::bool) (v_::real) = \
53.958 - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\
53.959 - \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \
53.960 - \ @@ (Try ((Rewrite square_explicit1 False) \
53.961 - \ Or (Rewrite square_explicit2 False))) \
53.962 - \ @@ (Rewrite root_plus_minus True) \
53.963 - \ @@ ((Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False)) \
53.964 - \ Or (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \
53.965 - \ @@ (Try (Repeat \
53.966 - \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \
53.967 - \ @@ (Try (Rewrite_Set calculate_RootRat False)) \
53.968 - \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \
53.969 - \ in ((Or_to_List e_)::bool list))"*)
53.970 -
53.971 -"******* PolyEq.ML end *******";
53.972 -
53.973 -(*eine gehackte termorder*)
53.974 -local (*. for make_polynomial_in .*)
53.975 -
53.976 -open Term; (* for type order = EQUAL | LESS | GREATER *)
53.977 -
53.978 -fun pr_ord EQUAL = "EQUAL"
53.979 - | pr_ord LESS = "LESS"
53.980 - | pr_ord GREATER = "GREATER";
53.981 -
53.982 -fun dest_hd' x (Const (a, T)) = (((a, 0), T), 0)
53.983 - | dest_hd' x (t as Free (a, T)) =
53.984 - if x = t then ((("|||||||||||||", 0), T), 0) (*WN*)
53.985 - else (((a, 0), T), 1)
53.986 - | dest_hd' x (Var v) = (v, 2)
53.987 - | dest_hd' x (Bound i) = ((("", i), dummyT), 3)
53.988 - | dest_hd' x (Abs (_, T, _)) = ((("", 0), T), 4);
53.989 -
53.990 -fun size_of_term' x (Const ("Atools.pow",_) $ Free (var,_) $ Free (pot,_)) =
53.991 - (case x of (*WN*)
53.992 - (Free (xstr,_)) =>
53.993 - (if xstr = var then 1000*(the (int_of_str pot)) else 3)
53.994 - | _ => raise error ("size_of_term' called with subst = "^
53.995 - (term2str x)))
53.996 - | size_of_term' x (Free (subst,_)) =
53.997 - (case x of
53.998 - (Free (xstr,_)) => (if xstr = subst then 1000 else 1)
53.999 - | _ => raise error ("size_of_term' called with subst = "^
53.1000 - (term2str x)))
53.1001 - | size_of_term' x (Abs (_,_,body)) = 1 + size_of_term' x body
53.1002 - | size_of_term' x (f$t) = size_of_term' x f + size_of_term' x t
53.1003 - | size_of_term' x _ = 1;
53.1004 -
53.1005 -
53.1006 -fun term_ord' x pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
53.1007 - (case term_ord' x pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
53.1008 - | term_ord' x pr thy (t, u) =
53.1009 - (if pr then
53.1010 - let
53.1011 - val (f, ts) = strip_comb t and (g, us) = strip_comb u;
53.1012 - val _=writeln("t= f@ts= \""^
53.1013 - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
53.1014 - (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\"");
53.1015 - val _=writeln("u= g@us= \""^
53.1016 - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
53.1017 - (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\"");
53.1018 - val _=writeln("size_of_term(t,u)= ("^
53.1019 - (string_of_int(size_of_term' x t))^", "^
53.1020 - (string_of_int(size_of_term' x u))^")");
53.1021 - val _=writeln("hd_ord(f,g) = "^((pr_ord o (hd_ord x))(f,g)));
53.1022 - val _=writeln("terms_ord(ts,us) = "^
53.1023 - ((pr_ord o (terms_ord x) str false)(ts,us)));
53.1024 - val _=writeln("-------");
53.1025 - in () end
53.1026 - else ();
53.1027 - case int_ord (size_of_term' x t, size_of_term' x u) of
53.1028 - EQUAL =>
53.1029 - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
53.1030 - (case hd_ord x (f, g) of EQUAL => (terms_ord x str pr) (ts, us)
53.1031 - | ord => ord)
53.1032 - end
53.1033 - | ord => ord)
53.1034 -and hd_ord x (f, g) = (* ~ term.ML *)
53.1035 - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' x f,
53.1036 - dest_hd' x g)
53.1037 -and terms_ord x str pr (ts, us) =
53.1038 - list_ord (term_ord' x pr (assoc_thy "Isac.thy"))(ts, us);
53.1039 -(*val x = (term_of o the o (parse thy)) "x"; (*FIXXXXXXME*)
53.1040 -*)
53.1041 -
53.1042 -in
53.1043 -
53.1044 -fun ord_make_polynomial_in (pr:bool) thy subst tu =
53.1045 - let
53.1046 - (* val _=writeln("*** subs variable is: "^(subst2str subst)); *)
53.1047 - in
53.1048 - case subst of
53.1049 - (_,x)::_ => (term_ord' x pr thy tu = LESS)
53.1050 - | _ => raise error ("ord_make_polynomial_in called with subst = "^
53.1051 - (subst2str subst))
53.1052 - end;
53.1053 -end;
53.1054 -
53.1055 -val order_add_mult_in = prep_rls(
53.1056 - Rls{id = "order_add_mult_in", preconds = [],
53.1057 - rew_ord = ("ord_make_polynomial_in",
53.1058 - ord_make_polynomial_in false Poly.thy),
53.1059 - erls = e_rls,srls = Erls,
53.1060 - calc = [],
53.1061 - (*asm_thm = [],*)
53.1062 - rules = [Thm ("real_mult_commute",num_str real_mult_commute),
53.1063 - (* z * w = w * z *)
53.1064 - Thm ("real_mult_left_commute",num_str real_mult_left_commute),
53.1065 - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
53.1066 - Thm ("real_mult_assoc",num_str real_mult_assoc),
53.1067 - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
53.1068 - Thm ("real_add_commute",num_str real_add_commute),
53.1069 - (*z + w = w + z*)
53.1070 - Thm ("real_add_left_commute",num_str real_add_left_commute),
53.1071 - (*x + (y + z) = y + (x + z)*)
53.1072 - Thm ("real_add_assoc",num_str real_add_assoc)
53.1073 - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
53.1074 - ], scr = EmptyScr}:rls);
53.1075 -
53.1076 -val collect_bdv = prep_rls(
53.1077 - Rls{id = "collect_bdv", preconds = [],
53.1078 - rew_ord = ("dummy_ord", dummy_ord),
53.1079 - erls = e_rls,srls = Erls,
53.1080 - calc = [],
53.1081 - (*asm_thm = [],*)
53.1082 - rules = [Thm ("bdv_collect_1",num_str bdv_collect_1),
53.1083 - Thm ("bdv_collect_2",num_str bdv_collect_2),
53.1084 - Thm ("bdv_collect_3",num_str bdv_collect_3),
53.1085 -
53.1086 - Thm ("bdv_collect_assoc1_1",num_str bdv_collect_assoc1_1),
53.1087 - Thm ("bdv_collect_assoc1_2",num_str bdv_collect_assoc1_2),
53.1088 - Thm ("bdv_collect_assoc1_3",num_str bdv_collect_assoc1_3),
53.1089 -
53.1090 - Thm ("bdv_collect_assoc2_1",num_str bdv_collect_assoc2_1),
53.1091 - Thm ("bdv_collect_assoc2_2",num_str bdv_collect_assoc2_2),
53.1092 - Thm ("bdv_collect_assoc2_3",num_str bdv_collect_assoc2_3),
53.1093 -
53.1094 -
53.1095 - Thm ("bdv_n_collect_1",num_str bdv_n_collect_1),
53.1096 - Thm ("bdv_n_collect_2",num_str bdv_n_collect_2),
53.1097 - Thm ("bdv_n_collect_3",num_str bdv_n_collect_3),
53.1098 -
53.1099 - Thm ("bdv_n_collect_assoc1_1",num_str bdv_n_collect_assoc1_1),
53.1100 - Thm ("bdv_n_collect_assoc1_2",num_str bdv_n_collect_assoc1_2),
53.1101 - Thm ("bdv_n_collect_assoc1_3",num_str bdv_n_collect_assoc1_3),
53.1102 -
53.1103 - Thm ("bdv_n_collect_assoc2_1",num_str bdv_n_collect_assoc2_1),
53.1104 - Thm ("bdv_n_collect_assoc2_2",num_str bdv_n_collect_assoc2_2),
53.1105 - Thm ("bdv_n_collect_assoc2_3",num_str bdv_n_collect_assoc2_3)
53.1106 - ], scr = EmptyScr}:rls);
53.1107 -
53.1108 -(*.transforms an arbitrary term without roots to a polynomial [4]
53.1109 - according to knowledge/Poly.sml.*)
53.1110 -val make_polynomial_in = prep_rls(
53.1111 - Seq {id = "make_polynomial_in", preconds = []:term list,
53.1112 - rew_ord = ("dummy_ord", dummy_ord),
53.1113 - erls = Atools_erls, srls = Erls,
53.1114 - calc = [], (*asm_thm = [],*)
53.1115 - rules = [Rls_ expand_poly,
53.1116 - Rls_ order_add_mult_in,
53.1117 - Rls_ simplify_power,
53.1118 - Rls_ collect_numerals,
53.1119 - Rls_ reduce_012,
53.1120 - Thm ("realpow_oneI",num_str realpow_oneI),
53.1121 - Rls_ discard_parentheses,
53.1122 - Rls_ collect_bdv
53.1123 - ],
53.1124 - scr = EmptyScr
53.1125 - }:rls);
53.1126 -
53.1127 -val separate_bdvs =
53.1128 - append_rls "separate_bdvs"
53.1129 - collect_bdv
53.1130 - [Thm ("separate_bdv", num_str separate_bdv),
53.1131 - (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*)
53.1132 - Thm ("separate_bdv_n", num_str separate_bdv_n),
53.1133 - Thm ("separate_1_bdv", num_str separate_1_bdv),
53.1134 - (*"?bdv / ?b = (1 / ?b) * ?bdv"*)
53.1135 - Thm ("separate_1_bdv_n", num_str separate_1_bdv_n),
53.1136 - (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*)
53.1137 - Thm ("real_add_divide_distrib",
53.1138 - num_str real_add_divide_distrib)
53.1139 - (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"
53.1140 - WN051031 DOES NOT BELONG TO HERE*)
53.1141 - ];
53.1142 -val make_ratpoly_in = prep_rls(
53.1143 - Seq {id = "make_ratpoly_in", preconds = []:term list,
53.1144 - rew_ord = ("dummy_ord", dummy_ord),
53.1145 - erls = Atools_erls, srls = Erls,
53.1146 - calc = [], (*asm_thm = [],*)
53.1147 - rules = [Rls_ norm_Rational,
53.1148 - Rls_ order_add_mult_in,
53.1149 - Rls_ discard_parentheses,
53.1150 - Rls_ separate_bdvs,
53.1151 - (* Rls_ rearrange_assoc, WN060916 why does cancel_p not work?*)
53.1152 - Rls_ cancel_p
53.1153 - (*Calc ("HOL.divide" ,eval_cancel "#divide_") too weak!*)
53.1154 - ],
53.1155 - scr = EmptyScr}:rls);
53.1156 -
53.1157 -
53.1158 -ruleset' := overwritelthy thy (!ruleset',
53.1159 - [("order_add_mult_in", order_add_mult_in),
53.1160 - ("collect_bdv", collect_bdv),
53.1161 - ("make_polynomial_in", make_polynomial_in),
53.1162 - ("make_ratpoly_in", make_ratpoly_in),
53.1163 - ("separate_bdvs", separate_bdvs)
53.1164 - ]);
53.1165 -
54.1 --- a/src/Tools/isac/IsacKnowledge/PolyEq.thy Wed Aug 25 15:15:01 2010 +0200
54.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
54.3 @@ -1,407 +0,0 @@
54.4 -(*.(c) by Richard Lang, 2003 .*)
54.5 -(* theory collecting all knowledge
54.6 - (predicates 'is_rootEq_in', 'is_sqrt_in', 'is_ratEq_in')
54.7 - for PolynomialEquations.
54.8 - alternative dependencies see Isac.thy
54.9 - created by: rlang
54.10 - date: 02.07
54.11 - changed by: rlang
54.12 - last change by: rlang
54.13 - date: 03.06.03
54.14 -*)
54.15 -
54.16 -(* remove_thy"PolyEq";
54.17 - use_thy"IsacKnowledge/Isac";
54.18 - use_thy"IsacKnowledge/PolyEq";
54.19 -
54.20 - remove_thy"PolyEq";
54.21 - use_thy"Isac";
54.22 -
54.23 - use"ROOT.ML";
54.24 - cd"knowledge";
54.25 - *)
54.26 -
54.27 -PolyEq = LinEq + RootRatEq +
54.28 -(*-------------------- consts ------------------------------------------------*)
54.29 -consts
54.30 -
54.31 -(*---------scripts--------------------------*)
54.32 - Complete'_square
54.33 - :: "[bool,real, \
54.34 - \ bool list] => bool list"
54.35 - ("((Script Complete'_square (_ _ =))// \
54.36 - \ (_))" 9)
54.37 - (*----- poly ----- *)
54.38 - Normalize'_poly
54.39 - :: "[bool,real, \
54.40 - \ bool list] => bool list"
54.41 - ("((Script Normalize'_poly (_ _=))// \
54.42 - \ (_))" 9)
54.43 - Solve'_d0'_polyeq'_equation
54.44 - :: "[bool,real, \
54.45 - \ bool list] => bool list"
54.46 - ("((Script Solve'_d0'_polyeq'_equation (_ _ =))// \
54.47 - \ (_))" 9)
54.48 - Solve'_d1'_polyeq'_equation
54.49 - :: "[bool,real, \
54.50 - \ bool list] => bool list"
54.51 - ("((Script Solve'_d1'_polyeq'_equation (_ _ =))// \
54.52 - \ (_))" 9)
54.53 - Solve'_d2'_polyeq'_equation
54.54 - :: "[bool,real, \
54.55 - \ bool list] => bool list"
54.56 - ("((Script Solve'_d2'_polyeq'_equation (_ _ =))// \
54.57 - \ (_))" 9)
54.58 - Solve'_d2'_polyeq'_sqonly'_equation
54.59 - :: "[bool,real, \
54.60 - \ bool list] => bool list"
54.61 - ("((Script Solve'_d2'_polyeq'_sqonly'_equation (_ _ =))// \
54.62 - \ (_))" 9)
54.63 - Solve'_d2'_polyeq'_bdvonly'_equation
54.64 - :: "[bool,real, \
54.65 - \ bool list] => bool list"
54.66 - ("((Script Solve'_d2'_polyeq'_bdvonly'_equation (_ _ =))// \
54.67 - \ (_))" 9)
54.68 - Solve'_d2'_polyeq'_pq'_equation
54.69 - :: "[bool,real, \
54.70 - \ bool list] => bool list"
54.71 - ("((Script Solve'_d2'_polyeq'_pq'_equation (_ _ =))// \
54.72 - \ (_))" 9)
54.73 - Solve'_d2'_polyeq'_abc'_equation
54.74 - :: "[bool,real, \
54.75 - \ bool list] => bool list"
54.76 - ("((Script Solve'_d2'_polyeq'_abc'_equation (_ _ =))// \
54.77 - \ (_))" 9)
54.78 - Solve'_d3'_polyeq'_equation
54.79 - :: "[bool,real, \
54.80 - \ bool list] => bool list"
54.81 - ("((Script Solve'_d3'_polyeq'_equation (_ _ =))// \
54.82 - \ (_))" 9)
54.83 - Solve'_d4'_polyeq'_equation
54.84 - :: "[bool,real, \
54.85 - \ bool list] => bool list"
54.86 - ("((Script Solve'_d4'_polyeq'_equation (_ _ =))// \
54.87 - \ (_))" 9)
54.88 - Biquadrat'_poly
54.89 - :: "[bool,real, \
54.90 - \ bool list] => bool list"
54.91 - ("((Script Biquadrat'_poly (_ _=))// \
54.92 - \ (_))" 9)
54.93 -
54.94 -(*-------------------- rules -------------------------------------------------*)
54.95 -rules
54.96 -
54.97 - cancel_leading_coeff1 "Not (c =!= 0) ==> (a + b*bdv + c*bdv^^^2 = 0) = \
54.98 - \ (a/c + b/c*bdv + bdv^^^2 = 0)"
54.99 - cancel_leading_coeff2 "Not (c =!= 0) ==> (a - b*bdv + c*bdv^^^2 = 0) = \
54.100 - \ (a/c - b/c*bdv + bdv^^^2 = 0)"
54.101 - cancel_leading_coeff3 "Not (c =!= 0) ==> (a + b*bdv - c*bdv^^^2 = 0) = \
54.102 - \ (a/c + b/c*bdv - bdv^^^2 = 0)"
54.103 -
54.104 - cancel_leading_coeff4 "Not (c =!= 0) ==> (a + bdv + c*bdv^^^2 = 0) = \
54.105 - \ (a/c + 1/c*bdv + bdv^^^2 = 0)"
54.106 - cancel_leading_coeff5 "Not (c =!= 0) ==> (a - bdv + c*bdv^^^2 = 0) = \
54.107 - \ (a/c - 1/c*bdv + bdv^^^2 = 0)"
54.108 - cancel_leading_coeff6 "Not (c =!= 0) ==> (a + bdv - c*bdv^^^2 = 0) = \
54.109 - \ (a/c + 1/c*bdv - bdv^^^2 = 0)"
54.110 -
54.111 - cancel_leading_coeff7 "Not (c =!= 0) ==> ( b*bdv + c*bdv^^^2 = 0) = \
54.112 - \ ( b/c*bdv + bdv^^^2 = 0)"
54.113 - cancel_leading_coeff8 "Not (c =!= 0) ==> ( b*bdv - c*bdv^^^2 = 0) = \
54.114 - \ ( b/c*bdv - bdv^^^2 = 0)"
54.115 -
54.116 - cancel_leading_coeff9 "Not (c =!= 0) ==> ( bdv + c*bdv^^^2 = 0) = \
54.117 - \ ( 1/c*bdv + bdv^^^2 = 0)"
54.118 - cancel_leading_coeff10"Not (c =!= 0) ==> ( bdv - c*bdv^^^2 = 0) = \
54.119 - \ ( 1/c*bdv - bdv^^^2 = 0)"
54.120 -
54.121 - cancel_leading_coeff11"Not (c =!= 0) ==> (a + b*bdv^^^2 = 0) = \
54.122 - \ (a/b + bdv^^^2 = 0)"
54.123 - cancel_leading_coeff12"Not (c =!= 0) ==> (a - b*bdv^^^2 = 0) = \
54.124 - \ (a/b - bdv^^^2 = 0)"
54.125 - cancel_leading_coeff13"Not (c =!= 0) ==> ( b*bdv^^^2 = 0) = \
54.126 - \ ( bdv^^^2 = 0/b)"
54.127 -
54.128 - complete_square1 "(q + p*bdv + bdv^^^2 = 0) = \
54.129 - \(q + (p/2 + bdv)^^^2 = (p/2)^^^2)"
54.130 - complete_square2 "( p*bdv + bdv^^^2 = 0) = \
54.131 - \( (p/2 + bdv)^^^2 = (p/2)^^^2)"
54.132 - complete_square3 "( bdv + bdv^^^2 = 0) = \
54.133 - \( (1/2 + bdv)^^^2 = (1/2)^^^2)"
54.134 -
54.135 - complete_square4 "(q - p*bdv + bdv^^^2 = 0) = \
54.136 - \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)"
54.137 - complete_square5 "(q + p*bdv - bdv^^^2 = 0) = \
54.138 - \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)"
54.139 -
54.140 - square_explicit1 "(a + b^^^2 = c) = ( b^^^2 = c - a)"
54.141 - square_explicit2 "(a - b^^^2 = c) = (-(b^^^2) = c - a)"
54.142 -
54.143 - bdv_explicit1 "(a + bdv = b) = (bdv = - a + b)"
54.144 - bdv_explicit2 "(a - bdv = b) = ((-1)*bdv = - a + b)"
54.145 - bdv_explicit3 "((-1)*bdv = b) = (bdv = (-1)*b)"
54.146 -
54.147 - plus_leq "(0 <= a + b) = ((-1)*b <= a)"(*Isa?*)
54.148 - minus_leq "(0 <= a - b) = ( b <= a)"(*Isa?*)
54.149 -
54.150 -(*-- normalize --*)
54.151 - (*WN0509 compare LinEq.all_left "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)"*)
54.152 - all_left
54.153 - "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)"
54.154 - makex1_x
54.155 - "a^^^1 = a"
54.156 - real_assoc_1
54.157 - "a+(b+c) = a+b+c"
54.158 - real_assoc_2
54.159 - "a*(b*c) = a*b*c"
54.160 -
54.161 -(* ---- degree 0 ----*)
54.162 - d0_true
54.163 - "(0=0) = True"
54.164 - d0_false
54.165 - "[|Not(bdv occurs_in a);Not(a=0)|] ==> (a=0) = False"
54.166 -(* ---- degree 1 ----*)
54.167 - d1_isolate_add1
54.168 - "[|Not(bdv occurs_in a)|] ==> (a + b*bdv = 0) = (b*bdv = (-1)*a)"
54.169 - d1_isolate_add2
54.170 - "[|Not(bdv occurs_in a)|] ==> (a + bdv = 0) = ( bdv = (-1)*a)"
54.171 - d1_isolate_div
54.172 - "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv = c) = (bdv = c/b)"
54.173 -(* ---- degree 2 ----*)
54.174 - d2_isolate_add1
54.175 - "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^2=0) = (b*bdv^^^2= (-1)*a)"
54.176 - d2_isolate_add2
54.177 - "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^2=0) = ( bdv^^^2= (-1)*a)"
54.178 - d2_isolate_div
54.179 - "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv^^^2=c) = (bdv^^^2=c/b)"
54.180 - d2_prescind1
54.181 - "(a*bdv + b*bdv^^^2 = 0) = (bdv*(a +b*bdv)=0)"
54.182 - d2_prescind2
54.183 - "(a*bdv + bdv^^^2 = 0) = (bdv*(a + bdv)=0)"
54.184 - d2_prescind3
54.185 - "( bdv + b*bdv^^^2 = 0) = (bdv*(1+b*bdv)=0)"
54.186 - d2_prescind4
54.187 - "( bdv + bdv^^^2 = 0) = (bdv*(1+ bdv)=0)"
54.188 - (* eliminate degree 2 *)
54.189 - (* thm for neg arguments in sqroot have postfix _neg *)
54.190 - d2_sqrt_equation1
54.191 - "[|(0<=c);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = ((bdv=sqrt c) | (bdv=(-1)*sqrt c ))"
54.192 - d2_sqrt_equation1_neg
54.193 - "[|(c<0);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = False"
54.194 - d2_sqrt_equation2
54.195 - "(bdv^^^2=0) = (bdv=0)"
54.196 - d2_sqrt_equation3
54.197 - "(b*bdv^^^2=0) = (bdv=0)"
54.198 - d2_reduce_equation1
54.199 - "(bdv*(a +b*bdv)=0) = ((bdv=0)|(a+b*bdv=0))"
54.200 - d2_reduce_equation2
54.201 - "(bdv*(a + bdv)=0) = ((bdv=0)|(a+ bdv=0))"
54.202 - d2_pqformula1
54.203 - "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+ bdv^^^2=0) =
54.204 - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2)
54.205 - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))"
54.206 - d2_pqformula1_neg
54.207 - "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+ bdv^^^2=0) = False"
54.208 - d2_pqformula2
54.209 - "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+1*bdv^^^2=0) =
54.210 - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2)
54.211 - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))"
54.212 - d2_pqformula2_neg
54.213 - "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+1*bdv^^^2=0) = False"
54.214 - d2_pqformula3
54.215 - "[|0<=1 - 4*q|] ==> (q+ bdv+ bdv^^^2=0) =
54.216 - ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2)
54.217 - | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))"
54.218 - d2_pqformula3_neg
54.219 - "[|1 - 4*q<0|] ==> (q+ bdv+ bdv^^^2=0) = False"
54.220 - d2_pqformula4
54.221 - "[|0<=1 - 4*q|] ==> (q+ bdv+1*bdv^^^2=0) =
54.222 - ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2)
54.223 - | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))"
54.224 - d2_pqformula4_neg
54.225 - "[|1 - 4*q<0|] ==> (q+ bdv+1*bdv^^^2=0) = False"
54.226 - d2_pqformula5
54.227 - "[|0<=p^^^2 - 0|] ==> ( p*bdv+ bdv^^^2=0) =
54.228 - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2)
54.229 - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))"
54.230 - (* d2_pqformula5_neg not need p^2 never less zero in R *)
54.231 - d2_pqformula6
54.232 - "[|0<=p^^^2 - 0|] ==> ( p*bdv+1*bdv^^^2=0) =
54.233 - ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2)
54.234 - | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))"
54.235 - (* d2_pqformula6_neg not need p^2 never less zero in R *)
54.236 - d2_pqformula7
54.237 - "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) =
54.238 - ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2)
54.239 - | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))"
54.240 - (* d2_pqformula7_neg not need, because 1<0 ==> False*)
54.241 - d2_pqformula8
54.242 - "[|0<=1 - 0|] ==> ( bdv+1*bdv^^^2=0) =
54.243 - ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2)
54.244 - | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))"
54.245 - (* d2_pqformula8_neg not need, because 1<0 ==> False*)
54.246 - d2_pqformula9
54.247 - "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ 1*bdv^^^2=0) =
54.248 - ((bdv= 0 + sqrt(0 - 4*q)/2)
54.249 - | (bdv= 0 - sqrt(0 - 4*q)/2))"
54.250 - d2_pqformula9_neg
54.251 - "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ 1*bdv^^^2=0) = False"
54.252 - d2_pqformula10
54.253 - "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ bdv^^^2=0) =
54.254 - ((bdv= 0 + sqrt(0 - 4*q)/2)
54.255 - | (bdv= 0 - sqrt(0 - 4*q)/2))"
54.256 - d2_pqformula10_neg
54.257 - "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ bdv^^^2=0) = False"
54.258 - d2_abcformula1
54.259 - "[|0<=b^^^2 - 4*a*c|] ==> (c + b*bdv+a*bdv^^^2=0) =
54.260 - ((bdv=( -b + sqrt(b^^^2 - 4*a*c))/(2*a))
54.261 - | (bdv=( -b - sqrt(b^^^2 - 4*a*c))/(2*a)))"
54.262 - d2_abcformula1_neg
54.263 - "[|b^^^2 - 4*a*c<0|] ==> (c + b*bdv+a*bdv^^^2=0) = False"
54.264 - d2_abcformula2
54.265 - "[|0<=1 - 4*a*c|] ==> (c+ bdv+a*bdv^^^2=0) =
54.266 - ((bdv=( -1 + sqrt(1 - 4*a*c))/(2*a))
54.267 - | (bdv=( -1 - sqrt(1 - 4*a*c))/(2*a)))"
54.268 - d2_abcformula2_neg
54.269 - "[|1 - 4*a*c<0|] ==> (c+ bdv+a*bdv^^^2=0) = False"
54.270 - d2_abcformula3
54.271 - "[|0<=b^^^2 - 4*1*c|] ==> (c + b*bdv+ bdv^^^2=0) =
54.272 - ((bdv=( -b + sqrt(b^^^2 - 4*1*c))/(2*1))
54.273 - | (bdv=( -b - sqrt(b^^^2 - 4*1*c))/(2*1)))"
54.274 - d2_abcformula3_neg
54.275 - "[|b^^^2 - 4*1*c<0|] ==> (c + b*bdv+ bdv^^^2=0) = False"
54.276 - d2_abcformula4
54.277 - "[|0<=1 - 4*1*c|] ==> (c + bdv+ bdv^^^2=0) =
54.278 - ((bdv=( -1 + sqrt(1 - 4*1*c))/(2*1))
54.279 - | (bdv=( -1 - sqrt(1 - 4*1*c))/(2*1)))"
54.280 - d2_abcformula4_neg
54.281 - "[|1 - 4*1*c<0|] ==> (c + bdv+ bdv^^^2=0) = False"
54.282 - d2_abcformula5
54.283 - "[|Not(bdv occurs_in c); 0<=0 - 4*a*c|] ==> (c + a*bdv^^^2=0) =
54.284 - ((bdv=( 0 + sqrt(0 - 4*a*c))/(2*a))
54.285 - | (bdv=( 0 - sqrt(0 - 4*a*c))/(2*a)))"
54.286 - d2_abcformula5_neg
54.287 - "[|Not(bdv occurs_in c); 0 - 4*a*c<0|] ==> (c + a*bdv^^^2=0) = False"
54.288 - d2_abcformula6
54.289 - "[|Not(bdv occurs_in c); 0<=0 - 4*1*c|] ==> (c+ bdv^^^2=0) =
54.290 - ((bdv=( 0 + sqrt(0 - 4*1*c))/(2*1))
54.291 - | (bdv=( 0 - sqrt(0 - 4*1*c))/(2*1)))"
54.292 - d2_abcformula6_neg
54.293 - "[|Not(bdv occurs_in c); 0 - 4*1*c<0|] ==> (c+ bdv^^^2=0) = False"
54.294 - d2_abcformula7
54.295 - "[|0<=b^^^2 - 0|] ==> ( b*bdv+a*bdv^^^2=0) =
54.296 - ((bdv=( -b + sqrt(b^^^2 - 0))/(2*a))
54.297 - | (bdv=( -b - sqrt(b^^^2 - 0))/(2*a)))"
54.298 - (* d2_abcformula7_neg not need b^2 never less zero in R *)
54.299 - d2_abcformula8
54.300 - "[|0<=b^^^2 - 0|] ==> ( b*bdv+ bdv^^^2=0) =
54.301 - ((bdv=( -b + sqrt(b^^^2 - 0))/(2*1))
54.302 - | (bdv=( -b - sqrt(b^^^2 - 0))/(2*1)))"
54.303 - (* d2_abcformula8_neg not need b^2 never less zero in R *)
54.304 - d2_abcformula9
54.305 - "[|0<=1 - 0|] ==> ( bdv+a*bdv^^^2=0) =
54.306 - ((bdv=( -1 + sqrt(1 - 0))/(2*a))
54.307 - | (bdv=( -1 - sqrt(1 - 0))/(2*a)))"
54.308 - (* d2_abcformula9_neg not need, because 1<0 ==> False*)
54.309 - d2_abcformula10
54.310 - "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) =
54.311 - ((bdv=( -1 + sqrt(1 - 0))/(2*1))
54.312 - | (bdv=( -1 - sqrt(1 - 0))/(2*1)))"
54.313 - (* d2_abcformula10_neg not need, because 1<0 ==> False*)
54.314 -
54.315 -(* ---- degree 3 ----*)
54.316 - d3_reduce_equation1
54.317 - "(a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0))"
54.318 - d3_reduce_equation2
54.319 - "( bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0))"
54.320 - d3_reduce_equation3
54.321 - "(a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0))"
54.322 - d3_reduce_equation4
54.323 - "( bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0))"
54.324 - d3_reduce_equation5
54.325 - "(a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0))"
54.326 - d3_reduce_equation6
54.327 - "( bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0))"
54.328 - d3_reduce_equation7
54.329 - "(a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))"
54.330 - d3_reduce_equation8
54.331 - "( bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))"
54.332 - d3_reduce_equation9
54.333 - "(a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0))"
54.334 - d3_reduce_equation10
54.335 - "( bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0))"
54.336 - d3_reduce_equation11
54.337 - "(a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0))"
54.338 - d3_reduce_equation12
54.339 - "( bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0))"
54.340 - d3_reduce_equation13
54.341 - "( b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0))"
54.342 - d3_reduce_equation14
54.343 - "( bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0))"
54.344 - d3_reduce_equation15
54.345 - "( b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0))"
54.346 - d3_reduce_equation16
54.347 - "( bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0))"
54.348 - d3_isolate_add1
54.349 - "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (b*bdv^^^3= (-1)*a)"
54.350 - d3_isolate_add2
54.351 - "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = ( bdv^^^3= (-1)*a)"
54.352 - d3_isolate_div
54.353 - "[|Not(b=0);Not(bdv occurs_in a)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b)"
54.354 - d3_root_equation2
54.355 - "(bdv^^^3=0) = (bdv=0)"
54.356 - d3_root_equation1
54.357 - "(bdv^^^3=c) = (bdv = nroot 3 c)"
54.358 -
54.359 -(* ---- degree 4 ----*)
54.360 - (* RL03.FIXME es wir nicht getestet ob u>0 *)
54.361 - d4_sub_u1
54.362 - "(c+b*bdv^^^2+a*bdv^^^4=0) =
54.363 - ((a*u^^^2+b*u+c=0) & (bdv^^^2=u))"
54.364 -
54.365 -(* ---- 7.3.02 von Termorder ---- *)
54.366 -
54.367 - bdv_collect_1 "l * bdv + m * bdv = (l + m) * bdv"
54.368 - bdv_collect_2 "bdv + m * bdv = (1 + m) * bdv"
54.369 - bdv_collect_3 "l * bdv + bdv = (l + 1) * bdv"
54.370 -
54.371 -(* bdv_collect_assoc0_1 "l * bdv + m * bdv + k = (l + m) * bdv + k"
54.372 - bdv_collect_assoc0_2 "bdv + m * bdv + k = (1 + m) * bdv + k"
54.373 - bdv_collect_assoc0_3 "l * bdv + bdv + k = (l + 1) * bdv + k"
54.374 -*)
54.375 - bdv_collect_assoc1_1 "l * bdv + (m * bdv + k) = (l + m) * bdv + k"
54.376 - bdv_collect_assoc1_2 "bdv + (m * bdv + k) = (1 + m) * bdv + k"
54.377 - bdv_collect_assoc1_3 "l * bdv + (bdv + k) = (l + 1) * bdv + k"
54.378 -
54.379 - bdv_collect_assoc2_1 "k + l * bdv + m * bdv = k + (l + m) * bdv"
54.380 - bdv_collect_assoc2_2 "k + bdv + m * bdv = k + (1 + m) * bdv"
54.381 - bdv_collect_assoc2_3 "k + l * bdv + bdv = k + (l + 1) * bdv"
54.382 -
54.383 -
54.384 - bdv_n_collect_1 "l * bdv^^^n + m * bdv^^^n = (l + m) * bdv^^^n"
54.385 - bdv_n_collect_2 " bdv^^^n + m * bdv^^^n = (1 + m) * bdv^^^n"
54.386 - bdv_n_collect_3 "l * bdv^^^n + bdv^^^n = (l + 1) * bdv^^^n" (*order!*)
54.387 -
54.388 - bdv_n_collect_assoc1_1 "l * bdv^^^n + (m * bdv^^^n + k) = (l + m) * bdv^^^n + k"
54.389 - bdv_n_collect_assoc1_2 "bdv^^^n + (m * bdv^^^n + k) = (1 + m) * bdv^^^n + k"
54.390 - bdv_n_collect_assoc1_3 "l * bdv^^^n + (bdv^^^n + k) = (l + 1) * bdv^^^n + k"
54.391 -
54.392 - bdv_n_collect_assoc2_1 "k + l * bdv^^^n + m * bdv^^^n = k + (l + m) * bdv^^^n"
54.393 - bdv_n_collect_assoc2_2 "k + bdv^^^n + m * bdv^^^n = k + (1 + m) * bdv^^^n"
54.394 - bdv_n_collect_assoc2_3 "k + l * bdv^^^n + bdv^^^n = k + (l + 1) * bdv^^^n"
54.395 -
54.396 -(*WN.14.3.03*)
54.397 - real_minus_div "- (a / b) = (-1 * a) / b"
54.398 -
54.399 - separate_bdv "(a * bdv) / b = (a / b) * bdv"
54.400 - separate_bdv_n "(a * bdv ^^^ n) / b = (a / b) * bdv ^^^ n"
54.401 - separate_1_bdv "bdv / b = (1 / b) * bdv"
54.402 - separate_1_bdv_n "bdv ^^^ n / b = (1 / b) * bdv ^^^ n"
54.403 -
54.404 -end
54.405 -
54.406 -
54.407 -
54.408 -
54.409 -
54.410 -
55.1 --- a/src/Tools/isac/IsacKnowledge/PolyMinus.ML Wed Aug 25 15:15:01 2010 +0200
55.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
55.3 @@ -1,521 +0,0 @@
55.4 -(* questionable attempts to perserve binary minus as wanted by teachers
55.5 - WN071207
55.6 - (c) due to copyright terms
55.7 -remove_thy"PolyMinus";
55.8 -use_thy"IsacKnowledge/PolyMinus";
55.9 -
55.10 -use_thy"IsacKnowledge/Isac";
55.11 -use"IsacKnowledge/PolyMinus.ML";
55.12 -*)
55.13 -
55.14 -(** interface isabelle -- isac **)
55.15 -theory' := overwritel (!theory', [("PolyMinus.thy",PolyMinus.thy)]);
55.16 -
55.17 -(** eval functions **)
55.18 -
55.19 -(*. get the identifier from specific monomials; see fun ist_monom .*)
55.20 -(*HACK.WN080107*)
55.21 -fun increase str =
55.22 - let val s::ss = explode str
55.23 - in implode ((chr (ord s + 1))::ss) end;
55.24 -fun identifier (Free (id,_)) = id (* 2, a *)
55.25 - | identifier (Const ("op *", _) $ Free (num, _) $ Free (id, _)) =
55.26 - id (* 2*a, a*b *)
55.27 - | identifier (Const ("op *", _) $ (* 3*a*b *)
55.28 - (Const ("op *", _) $
55.29 - Free (num, _) $ Free _) $ Free (id, _)) =
55.30 - if is_numeral num then id
55.31 - else "|||||||||||||"
55.32 - | identifier (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) =
55.33 - if is_numeral base then "|||||||||||||" (* a^2 *)
55.34 - else (*increase*) base
55.35 - | identifier (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *)
55.36 - (Const ("Atools.pow", _) $
55.37 - Free (base, _) $ Free (exp, _))) =
55.38 - if is_numeral num andalso not (is_numeral base) then (*increase*) base
55.39 - else "|||||||||||||"
55.40 - | identifier _ = "|||||||||||||"(*the "largest" string*);
55.41 -
55.42 -(*("kleiner", ("PolyMinus.kleiner", eval_kleiner ""))*)
55.43 -(* order "by alphabet" w.r.t. var: num < (var | num*var) > (var*var | ..) *)
55.44 -fun eval_kleiner _ _ (p as (Const ("PolyMinus.kleiner",_) $ a $ b)) _ =
55.45 - if is_num b then
55.46 - if is_num a then (*123 kleiner 32 = True !!!*)
55.47 - if int_of_Free a < int_of_Free b then
55.48 - SOME ((term2str p) ^ " = True",
55.49 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
55.50 - else SOME ((term2str p) ^ " = False",
55.51 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
55.52 - else (* -1 * -2 kleiner 0 *)
55.53 - SOME ((term2str p) ^ " = False",
55.54 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
55.55 - else
55.56 - if identifier a < identifier b then
55.57 - SOME ((term2str p) ^ " = True",
55.58 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
55.59 - else SOME ((term2str p) ^ " = False",
55.60 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
55.61 - | eval_kleiner _ _ _ _ = NONE;
55.62 -
55.63 -fun ist_monom (Free (id,_)) = true
55.64 - | ist_monom (Const ("op *", _) $ Free (num, _) $ Free (id, _)) =
55.65 - if is_numeral num then true else false
55.66 - | ist_monom _ = false;
55.67 -(*. this function only accepts the most simple monoms vvvvvvvvvv .*)
55.68 -fun ist_monom (Free (id,_)) = true (* 2, a *)
55.69 - | ist_monom (Const ("op *", _) $ Free _ $ Free (id, _)) = (* 2*a, a*b *)
55.70 - if is_numeral id then false else true
55.71 - | ist_monom (Const ("op *", _) $ (* 3*a*b *)
55.72 - (Const ("op *", _) $
55.73 - Free (num, _) $ Free _) $ Free (id, _)) =
55.74 - if is_numeral num andalso not (is_numeral id) then true else false
55.75 - | ist_monom (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) =
55.76 - true (* a^2 *)
55.77 - | ist_monom (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *)
55.78 - (Const ("Atools.pow", _) $
55.79 - Free (base, _) $ Free (exp, _))) =
55.80 - if is_numeral num then true else false
55.81 - | ist_monom _ = false;
55.82 -
55.83 -(* is this a univariate monomial ? *)
55.84 -(*("ist_monom", ("PolyMinus.ist'_monom", eval_ist_monom ""))*)
55.85 -fun eval_ist_monom _ _ (p as (Const ("PolyMinus.ist'_monom",_) $ a)) _ =
55.86 - if ist_monom a then
55.87 - SOME ((term2str p) ^ " = True",
55.88 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
55.89 - else SOME ((term2str p) ^ " = False",
55.90 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
55.91 - | eval_ist_monom _ _ _ _ = NONE;
55.92 -
55.93 -
55.94 -(** rewrite order **)
55.95 -
55.96 -(** rulesets **)
55.97 -
55.98 -val erls_ordne_alphabetisch =
55.99 - append_rls "erls_ordne_alphabetisch" e_rls
55.100 - [Calc ("PolyMinus.kleiner", eval_kleiner ""),
55.101 - Calc ("PolyMinus.ist'_monom", eval_ist_monom "")
55.102 - ];
55.103 -
55.104 -val ordne_alphabetisch =
55.105 - Rls{id = "ordne_alphabetisch", preconds = [],
55.106 - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [],
55.107 - erls = erls_ordne_alphabetisch,
55.108 - rules = [Thm ("tausche_plus",num_str tausche_plus),
55.109 - (*"b kleiner a ==> (b + a) = (a + b)"*)
55.110 - Thm ("tausche_minus",num_str tausche_minus),
55.111 - (*"b kleiner a ==> (b - a) = (-a + b)"*)
55.112 - Thm ("tausche_vor_plus",num_str tausche_vor_plus),
55.113 - (*"[| b ist_monom; a kleiner b |] ==> (- b + a) = (a - b)"*)
55.114 - Thm ("tausche_vor_minus",num_str tausche_vor_minus),
55.115 - (*"[| b ist_monom; a kleiner b |] ==> (- b - a) = (-a - b)"*)
55.116 - Thm ("tausche_plus_plus",num_str tausche_plus_plus),
55.117 - (*"c kleiner b ==> (a + c + b) = (a + b + c)"*)
55.118 - Thm ("tausche_plus_minus",num_str tausche_plus_minus),
55.119 - (*"c kleiner b ==> (a + c - b) = (a - b + c)"*)
55.120 - Thm ("tausche_minus_plus",num_str tausche_minus_plus),
55.121 - (*"c kleiner b ==> (a - c + b) = (a + b - c)"*)
55.122 - Thm ("tausche_minus_minus",num_str tausche_minus_minus)
55.123 - (*"c kleiner b ==> (a - c - b) = (a - b - c)"*)
55.124 - ], scr = EmptyScr}:rls;
55.125 -
55.126 -val fasse_zusammen =
55.127 - Rls{id = "fasse_zusammen", preconds = [],
55.128 - rew_ord = ("dummy_ord", dummy_ord),
55.129 - erls = append_rls "erls_fasse_zusammen" e_rls
55.130 - [Calc ("Atools.is'_const",eval_const "#is_const_")],
55.131 - srls = Erls, calc = [],
55.132 - rules =
55.133 - [Thm ("real_num_collect",num_str real_num_collect),
55.134 - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
55.135 - Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r),
55.136 - (*"[| l is_const; m..|] ==> (k + m * n) + l * n = k + (l + m)*n"*)
55.137 - Thm ("real_one_collect",num_str real_one_collect),
55.138 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
55.139 - Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r),
55.140 - (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*)
55.141 -
55.142 -
55.143 - Thm ("subtrahiere",num_str subtrahiere),
55.144 - (*"[| l is_const; m is_const |] ==> m * v - l * v = (m - l) * v"*)
55.145 - Thm ("subtrahiere_von_1",num_str subtrahiere_von_1),
55.146 - (*"[| l is_const |] ==> v - l * v = (1 - l) * v"*)
55.147 - Thm ("subtrahiere_1",num_str subtrahiere_1),
55.148 - (*"[| l is_const; m is_const |] ==> m * v - v = (m - 1) * v"*)
55.149 -
55.150 - Thm ("subtrahiere_x_plus_minus",num_str subtrahiere_x_plus_minus),
55.151 - (*"[| l is_const; m..|] ==> (k + m * n) - l * n = k + ( m - l) * n"*)
55.152 - Thm ("subtrahiere_x_plus1_minus",num_str subtrahiere_x_plus1_minus),
55.153 - (*"[| l is_const |] ==> (x + v) - l * v = x + (1 - l) * v"*)
55.154 - Thm ("subtrahiere_x_plus_minus1",num_str subtrahiere_x_plus_minus1),
55.155 - (*"[| m is_const |] ==> (x + m * v) - v = x + (m - 1) * v"*)
55.156 -
55.157 - Thm ("subtrahiere_x_minus_plus",num_str subtrahiere_x_minus_plus),
55.158 - (*"[| l is_const; m..|] ==> (k - m * n) + l * n = k + (-m + l) * n"*)
55.159 - Thm ("subtrahiere_x_minus1_plus",num_str subtrahiere_x_minus1_plus),
55.160 - (*"[| l is_const |] ==> (x - v) + l * v = x + (-1 + l) * v"*)
55.161 - Thm ("subtrahiere_x_minus_plus1",num_str subtrahiere_x_minus_plus1),
55.162 - (*"[| m is_const |] ==> (x - m * v) + v = x + (-m + 1) * v"*)
55.163 -
55.164 - Thm ("subtrahiere_x_minus_minus",num_str subtrahiere_x_minus_minus),
55.165 - (*"[| l is_const; m..|] ==> (k - m * n) - l * n = k + (-m - l) * n"*)
55.166 - Thm ("subtrahiere_x_minus1_minus",num_str subtrahiere_x_minus1_minus),
55.167 - (*"[| l is_const |] ==> (x - v) - l * v = x + (-1 - l) * v"*)
55.168 - Thm ("subtrahiere_x_minus_minus1",num_str subtrahiere_x_minus_minus1),
55.169 - (*"[| m is_const |] ==> (x - m * v) - v = x + (-m - 1) * v"*)
55.170 -
55.171 - Calc ("op +", eval_binop "#add_"),
55.172 - Calc ("op -", eval_binop "#subtr_"),
55.173 -
55.174 - (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen
55.175 - (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *)
55.176 - Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r),
55.177 - (*"(k + z1) + z1 = k + 2 * z1"*)
55.178 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
55.179 - (*"z1 + z1 = 2 * z1"*)
55.180 -
55.181 - Thm ("addiere_vor_minus",num_str addiere_vor_minus),
55.182 - (*"[| l is_const; m is_const |] ==> -(l * v) + m * v = (-l + m) *v"*)
55.183 - Thm ("addiere_eins_vor_minus",num_str addiere_eins_vor_minus),
55.184 - (*"[| m is_const |] ==> - v + m * v = (-1 + m) * v"*)
55.185 - Thm ("subtrahiere_vor_minus",num_str subtrahiere_vor_minus),
55.186 - (*"[| l is_const; m is_const |] ==> -(l * v) - m * v = (-l - m) *v"*)
55.187 - Thm ("subtrahiere_eins_vor_minus",num_str subtrahiere_eins_vor_minus)
55.188 - (*"[| m is_const |] ==> - v - m * v = (-1 - m) * v"*)
55.189 -
55.190 - ], scr = EmptyScr}:rls;
55.191 -
55.192 -val verschoenere =
55.193 - Rls{id = "verschoenere", preconds = [],
55.194 - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [],
55.195 - erls = append_rls "erls_verschoenere" e_rls
55.196 - [Calc ("PolyMinus.kleiner", eval_kleiner "")],
55.197 - rules = [Thm ("vorzeichen_minus_weg1",num_str vorzeichen_minus_weg1),
55.198 - (*"l kleiner 0 ==> a + l * b = a - -l * b"*)
55.199 - Thm ("vorzeichen_minus_weg2",num_str vorzeichen_minus_weg2),
55.200 - (*"l kleiner 0 ==> a - l * b = a + -l * b"*)
55.201 - Thm ("vorzeichen_minus_weg3",num_str vorzeichen_minus_weg3),
55.202 - (*"l kleiner 0 ==> k + a - l * b = k + a + -l * b"*)
55.203 - Thm ("vorzeichen_minus_weg4",num_str vorzeichen_minus_weg4),
55.204 - (*"l kleiner 0 ==> k - a - l * b = k - a + -l * b"*)
55.205 -
55.206 - Calc ("op *", eval_binop "#mult_"),
55.207 -
55.208 - Thm ("real_mult_0",num_str real_mult_0),
55.209 - (*"0 * z = 0"*)
55.210 - Thm ("real_mult_1",num_str real_mult_1),
55.211 - (*"1 * z = z"*)
55.212 - Thm ("real_add_zero_left",num_str real_add_zero_left),
55.213 - (*"0 + z = z"*)
55.214 - Thm ("null_minus",num_str null_minus),
55.215 - (*"0 - a = -a"*)
55.216 - Thm ("vor_minus_mal",num_str vor_minus_mal)
55.217 - (*"- a * b = (-a) * b"*)
55.218 -
55.219 - (*Thm ("",num_str ),*)
55.220 - (**)
55.221 - ], scr = EmptyScr}:rls (*end verschoenere*);
55.222 -
55.223 -val klammern_aufloesen =
55.224 - Rls{id = "klammern_aufloesen", preconds = [],
55.225 - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls,
55.226 - rules = [Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym)),
55.227 - (*"a + (b + c) = (a + b) + c"*)
55.228 - Thm ("klammer_plus_minus",num_str klammer_plus_minus),
55.229 - (*"a + (b - c) = (a + b) - c"*)
55.230 - Thm ("klammer_minus_plus",num_str klammer_minus_plus),
55.231 - (*"a - (b + c) = (a - b) - c"*)
55.232 - Thm ("klammer_minus_minus",num_str klammer_minus_minus)
55.233 - (*"a - (b - c) = (a - b) + c"*)
55.234 - ], scr = EmptyScr}:rls;
55.235 -
55.236 -val klammern_ausmultiplizieren =
55.237 - Rls{id = "klammern_ausmultiplizieren", preconds = [],
55.238 - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls,
55.239 - rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
55.240 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
55.241 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
55.242 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
55.243 -
55.244 - Thm ("klammer_mult_minus",num_str klammer_mult_minus),
55.245 - (*"a * (b - c) = a * b - a * c"*)
55.246 - Thm ("klammer_minus_mult",num_str klammer_minus_mult)
55.247 - (*"(b - c) * a = b * a - c * a"*)
55.248 -
55.249 - (*Thm ("",num_str ),
55.250 - (*""*)*)
55.251 - ], scr = EmptyScr}:rls;
55.252 -
55.253 -val ordne_monome =
55.254 - Rls{id = "ordne_monome", preconds = [],
55.255 - rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [],
55.256 - erls = append_rls "erls_ordne_monome" e_rls
55.257 - [Calc ("PolyMinus.kleiner", eval_kleiner ""),
55.258 - Calc ("Atools.is'_atom", eval_is_atom "")
55.259 - ],
55.260 - rules = [Thm ("tausche_mal",num_str tausche_mal),
55.261 - (*"[| b is_atom; a kleiner b |] ==> (b * a) = (a * b)"*)
55.262 - Thm ("tausche_vor_mal",num_str tausche_vor_mal),
55.263 - (*"[| b is_atom; a kleiner b |] ==> (-b * a) = (-a * b)"*)
55.264 - Thm ("tausche_mal_mal",num_str tausche_mal_mal),
55.265 - (*"[| c is_atom; b kleiner c |] ==> (a * c * b) = (a * b *c)"*)
55.266 - Thm ("x_quadrat",num_str x_quadrat)
55.267 - (*"(x * a) * a = x * a ^^^ 2"*)
55.268 -
55.269 - (*Thm ("",num_str ),
55.270 - (*""*)*)
55.271 - ], scr = EmptyScr}:rls;
55.272 -
55.273 -
55.274 -val rls_p_33 =
55.275 - append_rls "rls_p_33" e_rls
55.276 - [Rls_ ordne_alphabetisch,
55.277 - Rls_ fasse_zusammen,
55.278 - Rls_ verschoenere
55.279 - ];
55.280 -val rls_p_34 =
55.281 - append_rls "rls_p_34" e_rls
55.282 - [Rls_ klammern_aufloesen,
55.283 - Rls_ ordne_alphabetisch,
55.284 - Rls_ fasse_zusammen,
55.285 - Rls_ verschoenere
55.286 - ];
55.287 -val rechnen =
55.288 - append_rls "rechnen" e_rls
55.289 - [Calc ("op *", eval_binop "#mult_"),
55.290 - Calc ("op +", eval_binop "#add_"),
55.291 - Calc ("op -", eval_binop "#subtr_")
55.292 - ];
55.293 -
55.294 -ruleset' :=
55.295 -overwritelthy thy (!ruleset',
55.296 - [("ordne_alphabetisch", prep_rls ordne_alphabetisch),
55.297 - ("fasse_zusammen", prep_rls fasse_zusammen),
55.298 - ("verschoenere", prep_rls verschoenere),
55.299 - ("ordne_monome", prep_rls ordne_monome),
55.300 - ("klammern_aufloesen", prep_rls klammern_aufloesen),
55.301 - ("klammern_ausmultiplizieren",
55.302 - prep_rls klammern_ausmultiplizieren)
55.303 - ]);
55.304 -
55.305 -(** problems **)
55.306 -
55.307 -store_pbt
55.308 - (prep_pbt PolyMinus.thy "pbl_vereinf_poly" [] e_pblID
55.309 - (["polynom","vereinfachen"],
55.310 - [], Erls, NONE, []));
55.311 -
55.312 -store_pbt
55.313 - (prep_pbt PolyMinus.thy "pbl_vereinf_poly_minus" [] e_pblID
55.314 - (["plus_minus","polynom","vereinfachen"],
55.315 - [("#Given" ,["term t_"]),
55.316 - ("#Where" ,["t_ is_polyexp",
55.317 - "Not (matchsub (?a + (?b + ?c)) t_ | \
55.318 - \ matchsub (?a + (?b - ?c)) t_ | \
55.319 - \ matchsub (?a - (?b + ?c)) t_ | \
55.320 - \ matchsub (?a + (?b - ?c)) t_ )",
55.321 - "Not (matchsub (?a * (?b + ?c)) t_ | \
55.322 - \ matchsub (?a * (?b - ?c)) t_ | \
55.323 - \ matchsub ((?b + ?c) * ?a) t_ | \
55.324 - \ matchsub ((?b - ?c) * ?a) t_ )"]),
55.325 - ("#Find" ,["normalform n_"])
55.326 - ],
55.327 - append_rls "prls_pbl_vereinf_poly" e_rls
55.328 - [Calc ("Poly.is'_polyexp", eval_is_polyexp ""),
55.329 - Calc ("Tools.matchsub", eval_matchsub ""),
55.330 - Thm ("or_true",or_true),
55.331 - (*"(?a | True) = True"*)
55.332 - Thm ("or_false",or_false),
55.333 - (*"(?a | False) = ?a"*)
55.334 - Thm ("not_true",num_str not_true),
55.335 - (*"(~ True) = False"*)
55.336 - Thm ("not_false",num_str not_false)
55.337 - (*"(~ False) = True"*)],
55.338 - SOME "Vereinfache t_",
55.339 - [["simplification","for_polynomials","with_minus"]]));
55.340 -
55.341 -store_pbt
55.342 - (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer" [] e_pblID
55.343 - (["klammer","polynom","vereinfachen"],
55.344 - [("#Given" ,["term t_"]),
55.345 - ("#Where" ,["t_ is_polyexp",
55.346 - "Not (matchsub (?a * (?b + ?c)) t_ | \
55.347 - \ matchsub (?a * (?b - ?c)) t_ | \
55.348 - \ matchsub ((?b + ?c) * ?a) t_ | \
55.349 - \ matchsub ((?b - ?c) * ?a) t_ )"]),
55.350 - ("#Find" ,["normalform n_"])
55.351 - ],
55.352 - append_rls "prls_pbl_vereinf_poly_klammer" e_rls [Calc ("Poly.is'_polyexp", eval_is_polyexp ""),
55.353 - Calc ("Tools.matchsub", eval_matchsub ""),
55.354 - Thm ("or_true",or_true),
55.355 - (*"(?a | True) = True"*)
55.356 - Thm ("or_false",or_false),
55.357 - (*"(?a | False) = ?a"*)
55.358 - Thm ("not_true",num_str not_true),
55.359 - (*"(~ True) = False"*)
55.360 - Thm ("not_false",num_str not_false)
55.361 - (*"(~ False) = True"*)],
55.362 - SOME "Vereinfache t_",
55.363 - [["simplification","for_polynomials","with_parentheses"]]));
55.364 -
55.365 -store_pbt
55.366 - (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer_mal" [] e_pblID
55.367 - (["binom_klammer","polynom","vereinfachen"],
55.368 - [("#Given" ,["term t_"]),
55.369 - ("#Where" ,["t_ is_polyexp"]),
55.370 - ("#Find" ,["normalform n_"])
55.371 - ],
55.372 - append_rls "e_rls" e_rls [(*for preds in where_*)
55.373 - Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
55.374 - SOME "Vereinfache t_",
55.375 - [["simplification","for_polynomials","with_parentheses_mult"]]));
55.376 -
55.377 -store_pbt
55.378 - (prep_pbt PolyMinus.thy "pbl_probe" [] e_pblID
55.379 - (["probe"],
55.380 - [], Erls, NONE, []));
55.381 -
55.382 -store_pbt
55.383 - (prep_pbt PolyMinus.thy "pbl_probe_poly" [] e_pblID
55.384 - (["polynom","probe"],
55.385 - [("#Given" ,["Pruefe e_", "mitWert ws_"]),
55.386 - ("#Where" ,["e_ is_polyexp"]),
55.387 - ("#Find" ,["Geprueft p_"])
55.388 - ],
55.389 - append_rls "prls_pbl_probe_poly"
55.390 - e_rls [(*for preds in where_*)
55.391 - Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
55.392 - SOME "Probe e_ ws_",
55.393 - [["probe","fuer_polynom"]]));
55.394 -
55.395 -store_pbt
55.396 - (prep_pbt PolyMinus.thy "pbl_probe_bruch" [] e_pblID
55.397 - (["bruch","probe"],
55.398 - [("#Given" ,["Pruefe e_", "mitWert ws_"]),
55.399 - ("#Where" ,["e_ is_ratpolyexp"]),
55.400 - ("#Find" ,["Geprueft p_"])
55.401 - ],
55.402 - append_rls "prls_pbl_probe_bruch"
55.403 - e_rls [(*for preds in where_*)
55.404 - Calc ("Rational.is'_ratpolyexp", eval_is_ratpolyexp "")],
55.405 - SOME "Probe e_ ws_",
55.406 - [["probe","fuer_bruch"]]));
55.407 -
55.408 -
55.409 -(** methods **)
55.410 -
55.411 -store_met
55.412 - (prep_met PolyMinus.thy "met_simp_poly_minus" [] e_metID
55.413 - (["simplification","for_polynomials","with_minus"],
55.414 - [("#Given" ,["term t_"]),
55.415 - ("#Where" ,["t_ is_polyexp",
55.416 - "Not (matchsub (?a + (?b + ?c)) t_ | \
55.417 - \ matchsub (?a + (?b - ?c)) t_ | \
55.418 - \ matchsub (?a - (?b + ?c)) t_ | \
55.419 - \ matchsub (?a + (?b - ?c)) t_ )"]),
55.420 - ("#Find" ,["normalform n_"])
55.421 - ],
55.422 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
55.423 - prls = append_rls "prls_met_simp_poly_minus" e_rls
55.424 - [Calc ("Poly.is'_polyexp", eval_is_polyexp ""),
55.425 - Calc ("Tools.matchsub", eval_matchsub ""),
55.426 - Thm ("and_true",and_true),
55.427 - (*"(?a & True) = ?a"*)
55.428 - Thm ("and_false",and_false),
55.429 - (*"(?a & False) = False"*)
55.430 - Thm ("not_true",num_str not_true),
55.431 - (*"(~ True) = False"*)
55.432 - Thm ("not_false",num_str not_false)
55.433 - (*"(~ False) = True"*)],
55.434 - crls = e_rls, nrls = rls_p_33},
55.435 -"Script SimplifyScript (t_::real) = \
55.436 -\ ((Repeat((Try (Rewrite_Set ordne_alphabetisch False)) @@ \
55.437 -\ (Try (Rewrite_Set fasse_zusammen False)) @@ \
55.438 -\ (Try (Rewrite_Set verschoenere False)))) t_)"
55.439 - ));
55.440 -
55.441 -store_met
55.442 - (prep_met PolyMinus.thy "met_simp_poly_parenth" [] e_metID
55.443 - (["simplification","for_polynomials","with_parentheses"],
55.444 - [("#Given" ,["term t_"]),
55.445 - ("#Where" ,["t_ is_polyexp"]),
55.446 - ("#Find" ,["normalform n_"])
55.447 - ],
55.448 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
55.449 - prls = append_rls "simplification_for_polynomials_prls" e_rls
55.450 - [(*for preds in where_*)
55.451 - Calc("Poly.is'_polyexp",eval_is_polyexp"")],
55.452 - crls = e_rls, nrls = rls_p_34},
55.453 -"Script SimplifyScript (t_::real) = \
55.454 -\ ((Repeat((Try (Rewrite_Set klammern_aufloesen False)) @@ \
55.455 -\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \
55.456 -\ (Try (Rewrite_Set fasse_zusammen False)) @@ \
55.457 -\ (Try (Rewrite_Set verschoenere False)))) t_)"
55.458 - ));
55.459 -
55.460 -store_met
55.461 - (prep_met PolyMinus.thy "met_simp_poly_parenth_mult" [] e_metID
55.462 - (["simplification","for_polynomials","with_parentheses_mult"],
55.463 - [("#Given" ,["term t_"]),
55.464 - ("#Where" ,["t_ is_polyexp"]),
55.465 - ("#Find" ,["normalform n_"])
55.466 - ],
55.467 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
55.468 - prls = append_rls "simplification_for_polynomials_prls" e_rls
55.469 - [(*for preds in where_*)
55.470 - Calc("Poly.is'_polyexp",eval_is_polyexp"")],
55.471 - crls = e_rls, nrls = rls_p_34},
55.472 -"Script SimplifyScript (t_::real) = \
55.473 -\ ((Repeat((Try (Rewrite_Set klammern_ausmultiplizieren False)) @@ \
55.474 -\ (Try (Rewrite_Set discard_parentheses False)) @@ \
55.475 -\ (Try (Rewrite_Set ordne_monome False)) @@ \
55.476 -\ (Try (Rewrite_Set klammern_aufloesen False)) @@ \
55.477 -\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \
55.478 -\ (Try (Rewrite_Set fasse_zusammen False)) @@ \
55.479 -\ (Try (Rewrite_Set verschoenere False)))) t_)"
55.480 - ));
55.481 -
55.482 -store_met
55.483 - (prep_met PolyMinus.thy "met_probe" [] e_metID
55.484 - (["probe"],
55.485 - [],
55.486 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
55.487 - prls = Erls, crls = e_rls, nrls = Erls},
55.488 - "empty_script"));
55.489 -
55.490 -store_met
55.491 - (prep_met PolyMinus.thy "met_probe_poly" [] e_metID
55.492 - (["probe","fuer_polynom"],
55.493 - [("#Given" ,["Pruefe e_", "mitWert ws_"]),
55.494 - ("#Where" ,["e_ is_polyexp"]),
55.495 - ("#Find" ,["Geprueft p_"])
55.496 - ],
55.497 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
55.498 - prls = append_rls "prls_met_probe_bruch"
55.499 - e_rls [(*for preds in where_*)
55.500 - Calc ("Rational.is'_ratpolyexp",
55.501 - eval_is_ratpolyexp "")],
55.502 - crls = e_rls, nrls = rechnen},
55.503 -"Script ProbeScript (e_::bool) (ws_::bool list) = \
55.504 -\ (let e_ = Take e_; \
55.505 -\ e_ = Substitute ws_ e_ \
55.506 -\ in (Repeat((Try (Repeat (Calculate times))) @@ \
55.507 -\ (Try (Repeat (Calculate plus ))) @@ \
55.508 -\ (Try (Repeat (Calculate minus))))) e_)"
55.509 -));
55.510 -
55.511 -store_met
55.512 - (prep_met PolyMinus.thy "met_probe_bruch" [] e_metID
55.513 - (["probe","fuer_bruch"],
55.514 - [("#Given" ,["Pruefe e_", "mitWert ws_"]),
55.515 - ("#Where" ,["e_ is_ratpolyexp"]),
55.516 - ("#Find" ,["Geprueft p_"])
55.517 - ],
55.518 - {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
55.519 - prls = append_rls "prls_met_probe_bruch"
55.520 - e_rls [(*for preds in where_*)
55.521 - Calc ("Rational.is'_ratpolyexp",
55.522 - eval_is_ratpolyexp "")],
55.523 - crls = e_rls, nrls = Erls},
55.524 - "empty_script"));
56.1 --- a/src/Tools/isac/IsacKnowledge/PolyMinus.thy Wed Aug 25 15:15:01 2010 +0200
56.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
56.3 @@ -1,114 +0,0 @@
56.4 -(* attempts to perserve binary minus as wanted by Austrian teachers
56.5 - WN071207
56.6 - (c) due to copyright terms
56.7 -remove_thy"PolyMinus";
56.8 -use_thy_only"IsacKnowledge/PolyMinus";
56.9 -use_thy"IsacKnowledge/Isac";
56.10 -*)
56.11 -
56.12 -PolyMinus = (*Poly// due to "is_ratpolyexp" in...*) Rational +
56.13 -
56.14 -consts
56.15 -
56.16 - (*predicates for conditions in rewriting*)
56.17 - kleiner :: "['a, 'a] => bool" ("_ kleiner _")
56.18 - ist'_monom :: "'a => bool" ("_ ist'_monom")
56.19 -
56.20 - (*the CAS-command*)
56.21 - Probe :: "[bool, bool list] => bool"
56.22 - (*"Probe (3*a+2*b+a = 4*a+2*b) [a=1,b=2]"*)
56.23 -
56.24 - (*descriptions for the pbl and met*)
56.25 - Pruefe :: bool => una
56.26 - mitWert :: bool list => tobooll
56.27 - Geprueft :: bool => una
56.28 -
56.29 - (*Script-name*)
56.30 - ProbeScript :: "[bool, bool list, bool] \
56.31 - \=> bool"
56.32 - ("((Script ProbeScript (_ _ =))// (_))" 9)
56.33 -
56.34 -rules
56.35 -
56.36 - null_minus "0 - a = -a"
56.37 - vor_minus_mal "- a * b = (-a) * b"
56.38 -
56.39 - (*commute with invariant (a.b).c -association*)
56.40 - tausche_plus "[| b ist_monom; a kleiner b |] ==> \
56.41 - \(b + a) = (a + b)"
56.42 - tausche_minus "[| b ist_monom; a kleiner b |] ==> \
56.43 - \(b - a) = (-a + b)"
56.44 - tausche_vor_plus "[| b ist_monom; a kleiner b |] ==> \
56.45 - \(- b + a) = (a - b)"
56.46 - tausche_vor_minus "[| b ist_monom; a kleiner b |] ==> \
56.47 - \(- b - a) = (-a - b)"
56.48 - tausche_plus_plus "b kleiner c ==> (a + c + b) = (a + b + c)"
56.49 - tausche_plus_minus "b kleiner c ==> (a + c - b) = (a - b + c)"
56.50 - tausche_minus_plus "b kleiner c ==> (a - c + b) = (a + b - c)"
56.51 - tausche_minus_minus "b kleiner c ==> (a - c - b) = (a - b - c)"
56.52 -
56.53 - (*commute with invariant (a.b).c -association*)
56.54 - tausche_mal "[| b is_atom; a kleiner b |] ==> \
56.55 - \(b * a) = (a * b)"
56.56 - tausche_vor_mal "[| b is_atom; a kleiner b |] ==> \
56.57 - \(-b * a) = (-a * b)"
56.58 - tausche_mal_mal "[| c is_atom; b kleiner c |] ==> \
56.59 - \(x * c * b) = (x * b * c)"
56.60 - x_quadrat "(x * a) * a = x * a ^^^ 2"
56.61 -
56.62 -
56.63 - subtrahiere "[| l is_const; m is_const |] ==> \
56.64 - \m * v - l * v = (m - l) * v"
56.65 - subtrahiere_von_1 "[| l is_const |] ==> \
56.66 - \v - l * v = (1 - l) * v"
56.67 - subtrahiere_1 "[| l is_const; m is_const |] ==> \
56.68 - \m * v - v = (m - 1) * v"
56.69 -
56.70 - subtrahiere_x_plus_minus "[| l is_const; m is_const |] ==> \
56.71 - \(x + m * v) - l * v = x + (m - l) * v"
56.72 - subtrahiere_x_plus1_minus "[| l is_const |] ==> \
56.73 - \(x + v) - l * v = x + (1 - l) * v"
56.74 - subtrahiere_x_plus_minus1 "[| m is_const |] ==> \
56.75 - \(x + m * v) - v = x + (m - 1) * v"
56.76 -
56.77 - subtrahiere_x_minus_plus "[| l is_const; m is_const |] ==> \
56.78 - \(x - m * v) + l * v = x + (-m + l) * v"
56.79 - subtrahiere_x_minus1_plus "[| l is_const |] ==> \
56.80 - \(x - v) + l * v = x + (-1 + l) * v"
56.81 - subtrahiere_x_minus_plus1 "[| m is_const |] ==> \
56.82 - \(x - m * v) + v = x + (-m + 1) * v"
56.83 -
56.84 - subtrahiere_x_minus_minus "[| l is_const; m is_const |] ==> \
56.85 - \(x - m * v) - l * v = x + (-m - l) * v"
56.86 - subtrahiere_x_minus1_minus"[| l is_const |] ==> \
56.87 - \(x - v) - l * v = x + (-1 - l) * v"
56.88 - subtrahiere_x_minus_minus1"[| m is_const |] ==> \
56.89 - \(x - m * v) - v = x + (-m - 1) * v"
56.90 -
56.91 -
56.92 - addiere_vor_minus "[| l is_const; m is_const |] ==> \
56.93 - \- (l * v) + m * v = (-l + m) * v"
56.94 - addiere_eins_vor_minus "[| m is_const |] ==> \
56.95 - \- v + m * v = (-1 + m) * v"
56.96 - subtrahiere_vor_minus "[| l is_const; m is_const |] ==> \
56.97 - \- (l * v) - m * v = (-l - m) * v"
56.98 - subtrahiere_eins_vor_minus"[| m is_const |] ==> \
56.99 - \- v - m * v = (-1 - m) * v"
56.100 -
56.101 - vorzeichen_minus_weg1 "l kleiner 0 ==> a + l * b = a - -1*l * b"
56.102 - vorzeichen_minus_weg2 "l kleiner 0 ==> a - l * b = a + -1*l * b"
56.103 - vorzeichen_minus_weg3 "l kleiner 0 ==> k + a - l * b = k + a + -1*l * b"
56.104 - vorzeichen_minus_weg4 "l kleiner 0 ==> k - a - l * b = k - a + -1*l * b"
56.105 -
56.106 - (*klammer_plus_plus = (real_add_assoc RS sym)*)
56.107 - klammer_plus_minus "a + (b - c) = (a + b) - c"
56.108 - klammer_minus_plus "a - (b + c) = (a - b) - c"
56.109 - klammer_minus_minus "a - (b - c) = (a - b) + c"
56.110 -
56.111 - klammer_mult_minus "a * (b - c) = a * b - a * c"
56.112 - klammer_minus_mult "(b - c) * a = b * a - c * a"
56.113 -
56.114 -
56.115 -
56.116 -end
56.117 -
57.1 --- a/src/Tools/isac/IsacKnowledge/RatEq.ML Wed Aug 25 15:15:01 2010 +0200
57.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
57.3 @@ -1,203 +0,0 @@
57.4 -(*.(c) by Richard Lang, 2003 .*)
57.5 -(* collecting all knowledge for RationalEquations
57.6 - created by: rlang
57.7 - date: 02.09
57.8 - changed by: rlang
57.9 - last change by: rlang
57.10 - date: 02.11.29
57.11 -*)
57.12 -
57.13 -(* use"IsacKnowledge/RatEq.ML";
57.14 - use"RatEq.ML";
57.15 - remove_thy"RatEq";
57.16 - use_thy"Isac";
57.17 -
57.18 - use"ROOT.ML";
57.19 - cd"IsacKnowledge";
57.20 - *)
57.21 -"******* RatEq.ML begin *******";
57.22 -
57.23 -theory' := overwritel (!theory', [("RatEq.thy",RatEq.thy)]);
57.24 -
57.25 -(*-------------------------functions-----------------------*)
57.26 -(* is_rateqation_in becomes true, if a bdv is in the denominator of a fraction*)
57.27 -fun is_rateqation_in t v =
57.28 - let
57.29 - fun coeff_in c v = member op = (vars c) v;
57.30 - fun finddivide (_ $ _ $ _ $ _) v = raise error("is_rateqation_in:")
57.31 - (* at the moment there is no term like this, but ....*)
57.32 - | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = coeff_in b v
57.33 - | finddivide (_ $ t1 $ t2) v = (finddivide t1 v)
57.34 - orelse (finddivide t2 v)
57.35 - | finddivide (_ $ t1) v = (finddivide t1 v)
57.36 - | finddivide _ _ = false;
57.37 - in
57.38 - finddivide t v
57.39 - end;
57.40 -
57.41 -fun eval_is_ratequation_in _ _ (p as (Const ("RatEq.is'_ratequation'_in",_) $ t $ v)) _ =
57.42 - if is_rateqation_in t v then
57.43 - SOME ((term2str p) ^ " = True",
57.44 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
57.45 - else SOME ((term2str p) ^ " = True",
57.46 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
57.47 - | eval_is_ratequation_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
57.48 -
57.49 -(*-------------------------rulse-----------------------*)
57.50 -val RatEq_prls = (*15.10.02:just the following order due to subterm evaluation*)
57.51 - append_rls "RatEq_prls" e_rls
57.52 - [Calc ("Atools.ident",eval_ident "#ident_"),
57.53 - Calc ("Tools.matches",eval_matches ""),
57.54 - Calc ("Tools.lhs" ,eval_lhs ""),
57.55 - Calc ("Tools.rhs" ,eval_rhs ""),
57.56 - Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""),
57.57 - Calc ("op =",eval_equal "#equal_"),
57.58 - Thm ("not_true",num_str not_true),
57.59 - Thm ("not_false",num_str not_false),
57.60 - Thm ("and_true",num_str and_true),
57.61 - Thm ("and_false",num_str and_false),
57.62 - Thm ("or_true",num_str or_true),
57.63 - Thm ("or_false",num_str or_false)
57.64 - ];
57.65 -
57.66 -
57.67 -(*rls = merge_rls erls Poly_erls *)
57.68 -val rateq_erls =
57.69 - remove_rls "rateq_erls" (*WN: ein Hack*)
57.70 - (merge_rls "is_ratequation_in" calculate_Rational
57.71 - (append_rls "is_ratequation_in"
57.72 - Poly_erls
57.73 - [(*Calc ("HOL.divide", eval_cancel "#divide_"),*)
57.74 - Calc ("RatEq.is'_ratequation'_in",
57.75 - eval_is_ratequation_in "")
57.76 -
57.77 - ]))
57.78 - [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*)
57.79 - Thm ("or_commute",num_str or_commute) (*WN: ein Hack*)
57.80 - ];
57.81 -ruleset' := overwritelthy thy (!ruleset',
57.82 - [("rateq_erls",rateq_erls)(*FIXXXME:del with rls.rls'*)
57.83 - ]);
57.84 -
57.85 -
57.86 -val RatEq_crls =
57.87 - remove_rls "RatEq_crls" (*WN: ein Hack*)
57.88 - (merge_rls "is_ratequation_in" calculate_Rational
57.89 - (append_rls "is_ratequation_in"
57.90 - Poly_erls
57.91 - [(*Calc ("HOL.divide", eval_cancel "#divide_"),*)
57.92 - Calc ("RatEq.is'_ratequation'_in",
57.93 - eval_is_ratequation_in "")
57.94 - ]))
57.95 - [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*)
57.96 - Thm ("or_commute",num_str or_commute) (*WN: ein Hack*)
57.97 - ];
57.98 -
57.99 -val RatEq_eliminate = prep_rls(
57.100 - Rls {id = "RatEq_eliminate", preconds = [], rew_ord = ("termlessI",termlessI),
57.101 - erls = rateq_erls, srls = Erls, calc = [],
57.102 - (*asm_thm = [("rat_mult_denominator_both",""),("rat_mult_denominator_left",""),
57.103 - ("rat_mult_denominator_right","")],*)
57.104 - rules = [
57.105 - Thm("rat_mult_denominator_both",num_str rat_mult_denominator_both),
57.106 - (* a/b=c/d -> ad=cb *)
57.107 - Thm("rat_mult_denominator_left",num_str rat_mult_denominator_left),
57.108 - (* a =c/d -> ad=c *)
57.109 - Thm("rat_mult_denominator_right",num_str rat_mult_denominator_right)
57.110 - (* a/b=c -> a=cb *)
57.111 - ],
57.112 - scr = Script ((term_of o the o (parse thy)) "empty_script")
57.113 - }:rls);
57.114 -ruleset' := overwritelthy thy (!ruleset',
57.115 - [("RatEq_eliminate",RatEq_eliminate)
57.116 - ]);
57.117 -
57.118 -
57.119 -
57.120 -
57.121 -val RatEq_simplify = prep_rls(
57.122 - Rls {id = "RatEq_simplify", preconds = [], rew_ord = ("termlessI",termlessI),
57.123 - erls = rateq_erls, srls = Erls, calc = [],
57.124 - (*asm_thm = [("rat_double_rat_1",""),("rat_double_rat_2",""),
57.125 - ("rat_double_rat_3","")],*)
57.126 - rules = [
57.127 - Thm("real_rat_mult_1",num_str real_rat_mult_1),
57.128 - (*a*(b/c) = (a*b)/c*)
57.129 - Thm("real_rat_mult_2",num_str real_rat_mult_2),
57.130 - (*(a/b)*(c/d) = (a*c)/(b*d)*)
57.131 - Thm("real_rat_mult_3",num_str real_rat_mult_3),
57.132 - (* (a/b)*c = (a*c)/b*)
57.133 - Thm("real_rat_pow",num_str real_rat_pow),
57.134 - (*(a/b)^^^2 = a^^^2/b^^^2*)
57.135 - Thm("real_diff_minus",num_str real_diff_minus),
57.136 - (* a - b = a + (-1) * b *)
57.137 - Thm("rat_double_rat_1",num_str rat_double_rat_1),
57.138 - (* (a / (c/d) = (a*d) / c) *)
57.139 - Thm("rat_double_rat_2",num_str rat_double_rat_2),
57.140 - (* ((a/b) / (c/d) = (a*d) / (b*c)) *)
57.141 - Thm("rat_double_rat_3",num_str rat_double_rat_3)
57.142 - (* ((a/b) / c = a / (b*c) ) *)
57.143 - ],
57.144 - scr = Script ((term_of o the o (parse thy)) "empty_script")
57.145 - }:rls);
57.146 -ruleset' := overwritelthy thy (!ruleset',
57.147 - [("RatEq_simplify",RatEq_simplify)
57.148 - ]);
57.149 -
57.150 -(*-------------------------Problem-----------------------*)
57.151 -(*
57.152 -(get_pbt ["rational","univariate","equation"]);
57.153 -show_ptyps();
57.154 -*)
57.155 -store_pbt
57.156 - (prep_pbt RatEq.thy "pbl_equ_univ_rat" [] e_pblID
57.157 - (["rational","univariate","equation"],
57.158 - [("#Given" ,["equality e_","solveFor v_"]),
57.159 - ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]),
57.160 - ("#Find" ,["solutions v_i_"])
57.161 - ],
57.162 -
57.163 - RatEq_prls, SOME "solve (e_::bool, v_)",
57.164 - [["RatEq","solve_rat_equation"]]));
57.165 -
57.166 -
57.167 -(*-------------------------methods-----------------------*)
57.168 -store_met
57.169 - (prep_met RatEq.thy "met_rateq" [] e_metID
57.170 - (["RatEq"],
57.171 - [],
57.172 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
57.173 - crls=RatEq_crls, nrls=norm_Rational
57.174 - (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
57.175 -store_met
57.176 - (prep_met RatEq.thy "met_rat_eq" [] e_metID
57.177 - (["RatEq","solve_rat_equation"],
57.178 - [("#Given" ,["equality e_","solveFor v_"]),
57.179 - ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]),
57.180 - ("#Find" ,["solutions v_i_"])
57.181 - ],
57.182 - {rew_ord'="termlessI",
57.183 - rls'=rateq_erls,
57.184 - srls=e_rls,
57.185 - prls=RatEq_prls,
57.186 - calc=[],
57.187 - crls=RatEq_crls, nrls=norm_Rational(*,
57.188 - asm_rls=[],
57.189 - asm_thm=[("rat_double_rat_1",""),("rat_double_rat_2",""),("rat_double_rat_3",""),
57.190 - ("rat_mult_denominator_both",""),("rat_mult_denominator_left",""),
57.191 - ("rat_mult_denominator_right","")]*)},
57.192 - "Script Solve_rat_equation (e_::bool) (v_::real) = \
57.193 - \(let e_ = ((Repeat(Try (Rewrite_Set RatEq_simplify True))) @@ \
57.194 - \ (Repeat(Try (Rewrite_Set norm_Rational False))) @@ \
57.195 - \ (Repeat(Try (Rewrite_Set common_nominator_p False))) @@ \
57.196 - \ (Repeat(Try (Rewrite_Set RatEq_eliminate True)))) e_;\
57.197 - \ (L_::bool list) = (SubProblem (RatEq_,[univariate,equation], \
57.198 - \ [no_met]) [bool_ e_, real_ v_]) \
57.199 - \ in Check_elementwise L_ {(v_::real). Assumptions})"
57.200 - ));
57.201 -
57.202 -calclist':= overwritel (!calclist',
57.203 - [("is_ratequation_in", ("RatEq.is_ratequation_in",
57.204 - eval_is_ratequation_in ""))
57.205 - ]);
57.206 -"******* RatEq.ML end *******";
58.1 --- a/src/Tools/isac/IsacKnowledge/RatEq.thy Wed Aug 25 15:15:01 2010 +0200
58.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
58.3 @@ -1,67 +0,0 @@
58.4 -(*.(c) by Richard Lang, 2003 .*)
58.5 -(* theory collecting all knowledge for RationalEquations
58.6 - created by: rlang
58.7 - date: 02.08.12
58.8 - changed by: rlang
58.9 - last change by: rlang
58.10 - date: 02.11.28
58.11 -*)
58.12 -
58.13 -(*
58.14 - RL.020812
58.15 - use_thy"knowledge/RatEq";
58.16 - use_thy"RatEq";
58.17 - use_thy_only"RatEq";
58.18 -
58.19 - remove_thy"RatEq";
58.20 - use_thy"Isac";
58.21 -
58.22 - use"ROOT.ML";
58.23 - cd"knowledge";
58.24 - *)
58.25 -RatEq = Rational +
58.26 -
58.27 -(*-------------------- consts------------------------------------------------*)
58.28 -consts
58.29 -
58.30 - is'_ratequation'_in :: "[bool, real] => bool" ("_ is'_ratequation'_in _")
58.31 -
58.32 - (*----------------------scripts-----------------------*)
58.33 - Solve'_rat'_equation
58.34 - :: "[bool,real, \
58.35 - \ bool list] => bool list"
58.36 - ("((Script Solve'_rat'_equation (_ _ =))// \
58.37 - \ (_))" 9)
58.38 -
58.39 -(*-------------------- rules------------------------------------------------*)
58.40 -rules
58.41 - (* FIXME also in Poly.thy def. --> FIXED*)
58.42 - (*real_diff_minus
58.43 - "a - b = a + (-1) * b"*)
58.44 - real_rat_mult_1
58.45 - "a*(b/c) = (a*b)/c"
58.46 - real_rat_mult_2
58.47 - "(a/b)*(c/d) = (a*c)/(b*d)"
58.48 - real_rat_mult_3
58.49 - "(a/b)*c = (a*c)/b"
58.50 - real_rat_pow
58.51 - "(a/b)^^^2 = a^^^2/b^^^2"
58.52 -
58.53 - rat_double_rat_1
58.54 - "[|Not(c=0); Not(d=0)|] ==> (a / (c/d) = (a*d) / c)"
58.55 - rat_double_rat_2
58.56 - "[|Not(b=0);Not(c=0); Not(d=0)|] ==> ((a/b) / (c/d) = (a*d) / (b*c))"
58.57 - rat_double_rat_3
58.58 - "[|Not(b=0);Not(c=0)|] ==> ((a/b) / c = a / (b*c))"
58.59 -
58.60 -
58.61 - (* equation to same denominator *)
58.62 - rat_mult_denominator_both
58.63 - "[|Not(b=0); Not(d=0)|] ==> ((a::real) / b = c / d) = (a*d = c*b)"
58.64 - rat_mult_denominator_left
58.65 - "[|Not(d=0)|] ==> ((a::real) = c / d) = (a*d = c)"
58.66 - rat_mult_denominator_right
58.67 - "[|Not(b=0)|] ==> ((a::real) / b = c) = (a = c*b)"
58.68 -
58.69 -
58.70 -end
59.1 --- a/src/Tools/isac/IsacKnowledge/Rational-WN.sml Wed Aug 25 15:15:01 2010 +0200
59.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
59.3 @@ -1,257 +0,0 @@
59.4 -(*Stefan K.*)
59.5 -
59.6 -(*protokoll 14.3.02 --------------------------------------------------
59.7 -val ct = parse thy "(a + #1)//(#2*a^^^#2 - #2)";
59.8 -val t = (term_of o the) ct;
59.9 -atomt t;
59.10 -val ct = parse thy "not (#1+a)"; (*HOL.thy ?*)
59.11 -val t = (term_of o the) ct;
59.12 -atomt t;
59.13 -val ct = parse thy "x"; (*momentan ist alles 'real'*)
59.14 -val t = (term_of o the) ct;
59.15 -atomty t;
59.16 -val ct = parse thy "(x::int)"; (* !!! *)
59.17 -val t = (term_of o the) ct;
59.18 -atomty t;
59.19 -
59.20 -val ct = parse thy "(x::int)*(y::real)"; (*momentan ist alles 'real'*)
59.21 -
59.22 -val Const ("RatArith.cancel",_) $ zaehler $ nenner = t;
59.23 ----------------------------------------------------------------------*)
59.24 -
59.25 -
59.26 -(*diese vvv funktionen kommen nach src/Isa99/term_G.sml -------------*)
59.27 -fun term2str t =
59.28 - let fun ato (Const(a,T)) n =
59.29 - "\n"^indent n^"Const ( "^a^")"
59.30 - | ato (Free (a,T)) n =
59.31 - "\n"^indent n^"Free ( "^a^", "^")"
59.32 - | ato (Var ((a,ix),T)) n =
59.33 - "\n"^indent n^"Var (("^a^", "^string_of_int ix^"), "^")"
59.34 - | ato (Bound ix) n =
59.35 - "\n"^indent n^"Bound "^string_of_int ix
59.36 - | ato (Abs(a,T,body)) n =
59.37 - "\n"^indent n^"Abs( "^a^",.."^ato body (n+1)
59.38 - | ato (f$t') n = ato f n^ato t' (n+1)
59.39 - in "\n-------------"^ato t 0^"\n" end;
59.40 -fun free2int (t as Free (s, _)) = (((the o int_of_str) s)
59.41 - handle _ => raise error ("free2int: "^term2str t))
59.42 - | free2int t = raise error ("free2int: "^term2str t);
59.43 -(*diese ^^^ funktionen kommen nach src/Isa99/term_G.sml -------------*)
59.44 -
59.45 -
59.46 -(* remark on exceptions: 'error' is implemented by Isabelle
59.47 - as the typical system error *)
59.48 -
59.49 -
59.50 -type poly = int list;
59.51 -
59.52 -(* transform a Isabelle-term t into internal polynomial format
59.53 - preconditions for t:
59.54 - a-b -> a+(-b)
59.55 - x^1 -> x
59.56 - term ordered ascending
59.57 - parentheses right side (caused by 'ordered rewriting')
59.58 - variable as power (not as product) *)
59.59 -
59.60 -fun mono (Const ("RatArith.pow",_) $ t1 $ t2) v g =
59.61 - if t1 = v then ((replicate ((free2int t2) - g) 0) @ [1]) : poly
59.62 - else raise error ("term2poly.1 "^term2str t1)
59.63 - | mono (t as Const ("op *",_) $ t1 $
59.64 - (Const ("RatArith.pow",_) $ t2 $ t3)) v g =
59.65 - if t2 = v then (replicate ((free2int t3) - g) 0) @ [free2int t1]
59.66 - else raise error ("term2poly.2 "^term2str t)
59.67 - | mono t _ _ = raise error ("term2poly.3 "^term2str t);
59.68 -
59.69 -fun poly (Const ("op +",_) $ t1 $ t2) v g =
59.70 - let val l = mono t1 v g
59.71 - in (l @ (poly t2 v ((length l) + g))) end
59.72 - | poly t v g = mono t v g;
59.73 -
59.74 -fun term2poly (t as Free (s, _)) v =
59.75 - if t = v then SOME ([0,1] : poly) else (SOME [(the o int_of_str) s]
59.76 - handle _ => NONE)
59.77 - | term2poly (Const ("op *",_) $ (Free (s1,_)) $ (t as Free (s2,_))) v =
59.78 - if t = v then SOME [0, (the o int_of_str) s1] else NONE
59.79 - | term2poly (Const ("op +",_) $ (Free (s1,_)) $ t) v =
59.80 - SOME ([(the o int_of_str) s1] @ (poly t v 1))
59.81 - | term2poly t v =
59.82 - SOME (poly t v 0) handle _ => NONE;
59.83 -
59.84 -(*tests*)
59.85 -val v = (term_of o the o (parse thy)) "x::real";
59.86 -val t = (term_of o the o (parse thy)) "#-1::real";
59.87 -term2poly t v;
59.88 -val t = (term_of o the o (parse thy)) "x::real";
59.89 -term2poly t v;
59.90 -val t = (term_of o the o (parse thy)) "#1 * x::real"; (*FIXME: drop it*)
59.91 -term2poly t v;
59.92 -val t = (term_of o the o (parse thy)) "x^^^#1"; (*FIXME: drop it*)
59.93 -term2poly t v;
59.94 -val t = (term_of o the o (parse thy)) "x^^^#3";
59.95 -term2poly t v;
59.96 -val t = (term_of o the o (parse thy)) "#3 * x^^^#3";
59.97 -term2poly t v;
59.98 -val t = (term_of o the o (parse thy)) "#-1 + #3 * x^^^#3";
59.99 -term2poly t v;
59.100 -val t = (term_of o the o (parse thy)) "#-1 + (#3 * x^^^#3 + #5 * x^^^#5)";
59.101 -term2poly t v;
59.102 -val t = (term_of o the o (parse thy))
59.103 - "#-1 + (#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7))";
59.104 -term2poly t v;
59.105 -val t = (term_of o the o (parse thy))
59.106 - "#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7)";
59.107 -term2poly t v;
59.108 -
59.109 -
59.110 -fun is_polynomial_in t v =
59.111 - case term2poly t v of SOME _ => true | NONE => false;
59.112 -
59.113 -(* transform the internal polynomial p into an Isabelle term t
59.114 - where t meets the preconditions of term2poly
59.115 -val mk_mono =
59.116 - fn : typ -> of the coefficients
59.117 - typ -> of the unknown
59.118 - typ -> of the monomial and polynomial
59.119 - typ -> of the exponent of the unknown
59.120 - int -> the coefficient <> 0
59.121 - string -> the unknown
59.122 - int -> the degree, i.e. the value of the exponent
59.123 - term
59.124 -remark: all the typs above are "RealDef.real" due to the typs of * + ^
59.125 -which may change in the future
59.126 -*)
59.127 -fun mk_mono cT vT pT eT c v g =
59.128 - case g of
59.129 - 0 => Free (str_of_int c, cT) (*will cause problems with diff.typs*)
59.130 - | 1 => if c = 1 then Free (v, vT)
59.131 - else Const ("op *", [cT, vT]--->pT) $
59.132 - Free (str_of_int c, cT) $ Free (v, vT)
59.133 - | n => if c = 1 then (Const ("RatArith.pow", [vT, eT]--->pT) $
59.134 - Free (v, vT) $ Free (str_of_int g, eT))
59.135 - else Const ("op *", [cT, vT]--->pT) $
59.136 - Free (str_of_int c, cT) $
59.137 - (Const ("RatArith.pow", [vT, eT]--->pT) $
59.138 - Free (v, vT) $ Free (str_of_int g, eT));
59.139 -(*tests*)
59.140 -val cT = HOLogic.realT; val vT = HOLogic.realT; val pT = HOLogic.realT;
59.141 -val eT = HOLogic.realT;
59.142 -val t = mk_mono cT vT pT eT ~5 "x" 5;
59.143 -(cterm_of thy) t;
59.144 -val t = mk_mono cT vT pT eT ~1 "x" 0;
59.145 -(cterm_of thy) t;
59.146 -val t = mk_mono cT vT pT eT 1 "x" 1;
59.147 -(cterm_of thy) t;
59.148 -
59.149 -
59.150 -fun mk_sum pT t1 t2 = Const ("op +", [pT, pT]--->pT) $ t1 $ t2;
59.151 -
59.152 -
59.153 -fun poly2term cT vT pT eT ([p]:poly) v = mk_mono cT vT pT eT p v 0
59.154 - | poly2term cT vT pT eT (p:poly) v =
59.155 - let
59.156 - fun mk_poly cT vT pT eT [] t v g = t
59.157 - | mk_poly cT vT pT eT [p] t v g =
59.158 - if p = 0 then t
59.159 - else mk_sum pT (mk_mono cT vT pT eT p v g) t
59.160 - | mk_poly cT vT pT eT (p::ps) t v g =
59.161 - if p = 0 then mk_poly cT vT pT eT ps t v (g-1)
59.162 - else mk_poly cT vT pT eT ps
59.163 - (mk_sum pT (mk_mono cT vT pT eT p v g) t) v (g-1)
59.164 - val (p'::ps') = rev p
59.165 - val g = (length p) - 1
59.166 - in mk_poly cT vT pT eT ps' (mk_mono cT vT pT eT p' v g) v (g-1) end;
59.167 -
59.168 -(*tests*)
59.169 -val t = poly2term cT vT pT eT [~1] "x";
59.170 -(cterm_of thy) t;
59.171 -val t = poly2term cT vT pT eT [0,1] "x";
59.172 -(cterm_of thy) t;
59.173 -val t = poly2term cT vT pT eT [0,0,0,1] "x";
59.174 -(cterm_of thy) t;
59.175 -val t = poly2term cT vT pT eT [0,0,0,3] "x";
59.176 -(cterm_of thy) t;
59.177 -val t = poly2term cT vT pT eT [~1,0,0,3] "x";
59.178 -(cterm_of thy) t;
59.179 -val t = poly2term cT vT pT eT [~1,0,0,3,0,5] "x";
59.180 -(cterm_of thy) t;
59.181 -val t = poly2term cT vT pT eT [~1,0,0,3,0,5,0,7] "x";
59.182 -(cterm_of thy) t;
59.183 -val t = poly2term cT vT pT eT [0,0,0,3,0,5,0,7] "x";
59.184 -(cterm_of thy) t;
59.185 -
59.186 -"***************************************************************************";
59.187 -"* reverse-rewriting 12.8.02 *";
59.188 -"***************************************************************************";
59.189 -fun rewrite_set_' thy rls put_asm ruless ct =
59.190 - case ruless of
59.191 - Rrls _ => raise error "rewrite_set_' not for Rrls"
59.192 - | Rls _ =>
59.193 - let
59.194 - datatype switch = Appl | Noap;
59.195 - fun rew_once ruls asm ct Noap [] = (ct,asm)
59.196 - | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls
59.197 - | rew_once ruls asm ct apno (rul::thms) =
59.198 - case rul of
59.199 - Thm (thmid, thm) =>
59.200 - (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
59.201 - rls put_asm (thm_of_thm rul) ct of
59.202 - NONE => rew_once ruls asm ct apno thms
59.203 - | SOME (ct',asm') =>
59.204 - rew_once ruls (asm union asm') ct' Appl (rul::thms))
59.205 - | Calc (cc as (op_,_)) =>
59.206 - (case get_calculation_ thy cc ct of
59.207 - NONE => rew_once ruls asm ct apno thms
59.208 - | SOME (thmid, thm') =>
59.209 - let
59.210 - val pairopt =
59.211 - rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
59.212 - rls put_asm thm' ct;
59.213 - val _ = if pairopt <> NONE then ()
59.214 - else raise error("rewrite_set_, rewrite_ \""^
59.215 - (string_of_thmI thm')^"\" \""^
59.216 - (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE")
59.217 - in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end);
59.218 - val ruls = (#rules o rep_rls) ruless;
59.219 - val (ct',asm') = rew_once ruls [] ct Noap ruls;
59.220 - in if ct = ct' then NONE else SOME (ct',asm') end;
59.221 -
59.222 -(*
59.223 -fun reverse_rewrite t1 t2 rls =
59.224 -*)
59.225 -fun rewrite_set_' thy rls put_asm ruless ct =
59.226 - case ruless of
59.227 - Rrls _ => raise error "rewrite_set_' not for Rrls"
59.228 - | Rls _ =>
59.229 - let
59.230 - datatype switch = Appl | Noap;
59.231 - fun rew_once ruls asm ct Noap [] = (ct,asm)
59.232 - | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls
59.233 - | rew_once ruls asm ct apno (rul::thms) =
59.234 - case rul of
59.235 - Thm (thmid, thm) =>
59.236 - (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
59.237 - rls put_asm (thm_of_thm rul) ct of
59.238 - NONE => rew_once ruls asm ct apno thms
59.239 - | SOME (ct',asm') =>
59.240 - rew_once ruls (asm union asm') ct' Appl (rul::thms))
59.241 - | Calc (cc as (op_,_)) =>
59.242 - (case get_calculation_ thy cc ct of
59.243 - NONE => rew_once ruls asm ct apno thms
59.244 - | SOME (thmid, thm') =>
59.245 - let
59.246 - val pairopt =
59.247 - rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
59.248 - rls put_asm thm' ct;
59.249 - val _ = if pairopt <> NONE then ()
59.250 - else raise error("rewrite_set_, rewrite_ \""^
59.251 - (string_of_thmI thm')^"\" \""^
59.252 - (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE")
59.253 - in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end);
59.254 - val ruls = (#rules o rep_rls) ruless;
59.255 - val (ct',asm') = rew_once ruls [] ct Noap ruls;
59.256 - in if ct = ct' then NONE else SOME (ct',asm') end;
59.257 -
59.258 - realpow_two;
59.259 - real_mult_div_cancel1;
59.260 -
60.1 --- a/src/Tools/isac/IsacKnowledge/Rational.ML Wed Aug 25 15:15:01 2010 +0200
60.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
60.3 @@ -1,3786 +0,0 @@
60.4 -(*.calculate in rationals: gcd, lcm, etc.
60.5 - (c) Stefan Karnel 2002
60.6 - Institute for Mathematics D and Institute for Software Technology,
60.7 - TU-Graz SS 2002
60.8 - Use is subject to license terms.
60.9 -
60.10 -use"IsacKnowledge/Rational.ML";
60.11 -use"Rational.ML";
60.12 -
60.13 -remove_thy"Rational";
60.14 -use_thy"IsacKnowledge/Isac";
60.15 -****************************************************************.*)
60.16 -
60.17 -(*.*****************************************************************
60.18 - Remark on notions in the documentation below:
60.19 - referring to the remark on 'polynomials' in Poly.sml we use
60.20 - [2] 'polynomial' normalform (Polynom)
60.21 - [3] 'expanded_term' normalform (Ausmultiplizierter Term),
60.22 - where normalform [2] is a special case of [3], i.e. [3] implies [2].
60.23 - Instead of
60.24 - 'fraction with numerator and nominator both in normalform [2]'
60.25 - 'fraction with numerator and nominator both in normalform [3]'
60.26 - we say:
60.27 - 'fraction in normalform [2]'
60.28 - 'fraction in normalform [3]'
60.29 - or
60.30 - 'fraction [2]'
60.31 - 'fraction [3]'.
60.32 - a 'simple fraction' is a term with '/' as outmost operator and
60.33 - numerator and nominator in normalform [2] or [3].
60.34 -****************************************************************.*)
60.35 -
60.36 -signature RATIONALI =
60.37 -sig
60.38 - type mv_monom
60.39 - type mv_poly
60.40 - val add_fraction_ : theory -> term -> (term * term list) option
60.41 - val add_fraction_p_ : theory -> term -> (term * term list) option
60.42 - val calculate_Rational : rls
60.43 - val calc_rat_erls:rls
60.44 - val cancel : rls
60.45 - val cancel_ : theory -> term -> (term * term list) option
60.46 - val cancel_p : rls
60.47 - val cancel_p_ : theory -> term -> (term * term list) option
60.48 - val common_nominator : rls
60.49 - val common_nominator_ : theory -> term -> (term * term list) option
60.50 - val common_nominator_p : rls
60.51 - val common_nominator_p_ : theory -> term -> (term * term list) option
60.52 - val eval_is_expanded : string -> 'a -> term -> theory ->
60.53 - (string * term) option
60.54 - val expanded2polynomial : term -> term option
60.55 - val factout_ : theory -> term -> (term * term list) option
60.56 - val factout_p_ : theory -> term -> (term * term list) option
60.57 - val is_expanded : term -> bool
60.58 - val is_polynomial : term -> bool
60.59 -
60.60 - val mv_gcd : (int * int list) list -> mv_poly -> mv_poly
60.61 - val mv_lcm : mv_poly -> mv_poly -> mv_poly
60.62 -
60.63 - val norm_expanded_rat_ : theory -> term -> (term * term list) option
60.64 -(*WN0602.2.6.pull into struct !!!
60.65 - val norm_Rational : rls(*.normalizes an arbitrary rational term without
60.66 - roots into a simple and canceled fraction
60.67 - with normalform [2].*)
60.68 -*)
60.69 -(*val norm_rational_p : 19.10.02 missing FIXXXXXXXXXXXXME
60.70 - rls (*.normalizes an rational term [2] without
60.71 - roots into a simple and canceled fraction
60.72 - with normalform [2].*)
60.73 -*)
60.74 - val norm_rational_ : theory -> term -> (term * term list) option
60.75 - val polynomial2expanded : term -> term option
60.76 - val rational_erls :
60.77 - rls (*.evaluates an arbitrary rational term with numerals.*)
60.78 -
60.79 -(*WN0210???SK: fehlen Funktionen, die exportiert werden sollen ? *)
60.80 -end
60.81 -
60.82 -(*.**************************************************************************
60.83 -survey on the functions
60.84 -~~~~~~~~~~~~~~~~~~~~~~~
60.85 - [2] 'polynomial' :rls | [3]'expanded_term':rls
60.86 ---------------------:------------------+-------------------:-----------------
60.87 - factout_p_ : | factout_ :
60.88 - cancel_p_ : | cancel_ :
60.89 - :cancel_p | :cancel
60.90 ---------------------:------------------+-------------------:-----------------
60.91 - common_nominator_p_: | common_nominator_ :
60.92 - :common_nominator_p| :common_nominator
60.93 - add_fraction_p_ : | add_fraction_ :
60.94 ---------------------:------------------+-------------------:-----------------
60.95 -???SK :norm_rational_p | :norm_rational
60.96 -
60.97 -This survey shows only the principal functions for reuse, and the identifiers
60.98 -of the rls exported. The list below shows some more useful functions.
60.99 -
60.100 -
60.101 -conversion from Isabelle-term to internal representation
60.102 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60.103 -
60.104 -... BITTE FORTSETZEN ...
60.105 -
60.106 -polynomial2expanded = ...
60.107 -expanded2polynomial = ...
60.108 -
60.109 -remark: polynomial2expanded o expanded2polynomial = I,
60.110 - where 'o' is function chaining, and 'I' is identity WN0210???SK
60.111 -
60.112 -functions for greatest common divisor and canceling
60.113 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60.114 -mv_gcd
60.115 -factout_
60.116 -factout_p_
60.117 -cancel_
60.118 -cancel_p_
60.119 -
60.120 -functions for least common multiple and addition of fractions
60.121 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60.122 -mv_lcm
60.123 -common_nominator_
60.124 -common_nominator_p_
60.125 -add_fraction_ (*.add 2 or more fractions.*)
60.126 -add_fraction_p_ (*.add 2 or more fractions.*)
60.127 -
60.128 -functions for normalform of rationals
60.129 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60.130 -WN0210???SK interne Funktionen f"ur norm_rational:
60.131 - schaffen diese SML-Funktionen wirklich ganz allgemeine Terme ?
60.132 -
60.133 -norm_rational_
60.134 -norm_expanded_rat_
60.135 -
60.136 -**************************************************************************.*)
60.137 -
60.138 -
60.139 -(*##*)
60.140 -structure RationalI : RATIONALI =
60.141 -struct
60.142 -(*##*)
60.143 -
60.144 -infix mem ins union; (*WN100819 updating to Isabelle2009-2*)
60.145 -fun x mem [] = false
60.146 - | x mem (y :: ys) = x = y orelse x mem ys;
60.147 -fun (x ins xs) = if x mem xs then xs else x :: xs;
60.148 -fun xs union [] = xs
60.149 - | [] union ys = ys
60.150 - | (x :: xs) union ys = xs union (x ins ys);
60.151 -
60.152 -(*. gcd of integers .*)
60.153 -(* die gcd Funktion von Isabelle funktioniert nicht richtig !!! *)
60.154 -fun gcd_int a b = if b=0 then a
60.155 - else gcd_int b (a mod b);
60.156 -
60.157 -(*. univariate polynomials (uv) .*)
60.158 -(*. univariate polynomials are represented as a list of the coefficent in reverse maximum degree order .*)
60.159 -(*. 5 * x^5 + 4 * x^3 + 2 * x^2 + x + 19 => [19,1,2,4,0,5] .*)
60.160 -type uv_poly = int list;
60.161 -
60.162 -(*. adds two uv polynomials .*)
60.163 -fun uv_mod_add_poly ([]:uv_poly,p2:uv_poly) = p2:uv_poly
60.164 - | uv_mod_add_poly (p1,[]) = p1
60.165 - | uv_mod_add_poly (x::p1,y::p2) = (x+y)::(uv_mod_add_poly(p1,p2));
60.166 -
60.167 -(*. multiplies a uv polynomial with a skalar s .*)
60.168 -fun uv_mod_smul_poly ([]:uv_poly,s:int) = []:uv_poly
60.169 - | uv_mod_smul_poly (x::p,s) = (x*s)::(uv_mod_smul_poly(p,s));
60.170 -
60.171 -(*. calculates the remainder of a polynomial divided by a skalar s .*)
60.172 -fun uv_mod_rem_poly ([]:uv_poly,s) = []:uv_poly
60.173 - | uv_mod_rem_poly (x::p,s) = (x mod s)::(uv_mod_smul_poly(p,s));
60.174 -
60.175 -(*. calculates the degree of a uv polynomial .*)
60.176 -fun uv_mod_deg ([]:uv_poly) = 0
60.177 - | uv_mod_deg p = length(p)-1;
60.178 -
60.179 -(*. calculates the remainder of x/p and represents it as value between -p/2 and p/2 .*)
60.180 -fun uv_mod_mod2(x,p)=
60.181 - let
60.182 - val y=(x mod p);
60.183 - in
60.184 - if (y)>(p div 2) then (y)-p else
60.185 - (
60.186 - if (y)<(~p div 2) then p+(y) else (y)
60.187 - )
60.188 - end;
60.189 -
60.190 -(*.calculates the remainder for each element of a integer list divided by p.*)
60.191 -fun uv_mod_list_modp [] p = []
60.192 - | uv_mod_list_modp (x::xs) p = (uv_mod_mod2(x,p))::(uv_mod_list_modp xs p);
60.193 -
60.194 -(*. appends an integer at the end of a integer list .*)
60.195 -fun uv_mod_null (p1:int list,0) = p1
60.196 - | uv_mod_null (p1:int list,n1:int) = uv_mod_null(p1,n1-1) @ [0];
60.197 -
60.198 -(*. uv polynomial division, result is (quotient, remainder) .*)
60.199 -(*. only for uv_mod_divides .*)
60.200 -(* FIXME: Division von x^9+x^5+1 durch x-1000 funktioniert nicht integer zu klein *)
60.201 -fun uv_mod_pdiv (p1:uv_poly) ([]:uv_poly) = raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero")
60.202 - | uv_mod_pdiv p1 [x] =
60.203 - let
60.204 - val xs=ref [];
60.205 - in
60.206 - if x<>0 then
60.207 - (
60.208 - xs:=(uv_mod_rem_poly(p1,x));
60.209 - while length(!xs)>0 andalso hd(!xs)=0 do xs:=tl(!xs)
60.210 - )
60.211 - else raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero");
60.212 - ([]:uv_poly,!xs:uv_poly)
60.213 - end
60.214 - | uv_mod_pdiv p1 p2 =
60.215 - let
60.216 - val n= uv_mod_deg(p2);
60.217 - val m= ref (uv_mod_deg(p1));
60.218 - val p1'=ref (rev(p1));
60.219 - val p2'=(rev(p2));
60.220 - val lc2=hd(p2');
60.221 - val q=ref [];
60.222 - val c=ref 0;
60.223 - val output=ref ([],[]);
60.224 - in
60.225 - (
60.226 - if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: Division by zero")
60.227 - else
60.228 - (
60.229 - if (!m)<n then
60.230 - (
60.231 - output:=([0],p1)
60.232 - )
60.233 - else
60.234 - (
60.235 - while (!m)>=n do
60.236 - (
60.237 - c:=hd(!p1') div hd(p2');
60.238 - if !c<>0 then
60.239 - (
60.240 - p1':=uv_mod_add_poly(!p1',uv_mod_null(uv_mod_smul_poly(p2',~(!c)),!m-n));
60.241 - while length(!p1')>0 andalso hd(!p1')=0 do p1':= tl(!p1');
60.242 - m:=uv_mod_deg(!p1')
60.243 - )
60.244 - else m:=0
60.245 - );
60.246 - output:=(rev(!q),rev(!p1'))
60.247 - )
60.248 - );
60.249 - !output
60.250 - )
60.251 - end;
60.252 -
60.253 -(*. divides p1 by p2 in Zp .*)
60.254 -fun uv_mod_pdivp (p1:uv_poly) (p2:uv_poly) p =
60.255 - let
60.256 - val n=uv_mod_deg(p2);
60.257 - val m=ref (uv_mod_deg(uv_mod_list_modp p1 p));
60.258 - val p1'=ref (rev(p1));
60.259 - val p2'=(rev(uv_mod_list_modp p2 p));
60.260 - val lc2=hd(p2');
60.261 - val q=ref [];
60.262 - val c=ref 0;
60.263 - val output=ref ([],[]);
60.264 - in
60.265 - (
60.266 - if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIVP_EXCEPTION: Division by zero")
60.267 - else
60.268 - (
60.269 - if (!m)<n then
60.270 - (
60.271 - output:=([0],p1)
60.272 - )
60.273 - else
60.274 - (
60.275 - while (!m)>=n do
60.276 - (
60.277 - c:=uv_mod_mod2(hd(!p1')*(power lc2 1), p);
60.278 - q:=(!c)::(!q);
60.279 - p1':=uv_mod_list_modp(tl(uv_mod_add_poly(uv_mod_smul_poly(!p1',lc2),
60.280 - uv_mod_smul_poly(uv_mod_smul_poly(p2',hd(!p1')),~1)))) p;
60.281 - m:=(!m)-1
60.282 - );
60.283 -
60.284 - while !p1'<>[] andalso hd(!p1')=0 do
60.285 - (
60.286 - p1':=tl(!p1')
60.287 - );
60.288 -
60.289 - output:=(rev(uv_mod_list_modp (!q) (p)),rev(!p1'))
60.290 - )
60.291 - );
60.292 - !output:uv_poly * uv_poly
60.293 - )
60.294 - end;
60.295 -
60.296 -(*. calculates the remainder of p1/p2 .*)
60.297 -fun uv_mod_prest (p1:uv_poly) ([]:uv_poly) = raise error("UV_MOD_PREST_EXCEPTION: Division by zero")
60.298 - | uv_mod_prest [] p2 = []:uv_poly
60.299 - | uv_mod_prest p1 p2 = (#2(uv_mod_pdiv p1 p2));
60.300 -
60.301 -(*. calculates the remainder of p1/p2 in Zp .*)
60.302 -fun uv_mod_prestp (p1:uv_poly) ([]:uv_poly) p= raise error("UV_MOD_PRESTP_EXCEPTION: Division by zero")
60.303 - | uv_mod_prestp [] p2 p= []:uv_poly
60.304 - | uv_mod_prestp p1 p2 p = #2(uv_mod_pdivp p1 p2 p);
60.305 -
60.306 -(*. calculates the content of a uv polynomial .*)
60.307 -fun uv_mod_cont ([]:uv_poly) = 0
60.308 - | uv_mod_cont (x::p)= gcd_int x (uv_mod_cont(p));
60.309 -
60.310 -(*. divides each coefficient of a uv polynomial by y .*)
60.311 -fun uv_mod_div_list (p:uv_poly,0) = raise error("UV_MOD_DIV_LIST_EXCEPTION: Division by zero")
60.312 - | uv_mod_div_list ([],y) = []:uv_poly
60.313 - | uv_mod_div_list (x::p,y) = (x div y)::uv_mod_div_list(p,y);
60.314 -
60.315 -(*. calculates the primitiv part of a uv polynomial .*)
60.316 -fun uv_mod_pp ([]:uv_poly) = []:uv_poly
60.317 - | uv_mod_pp p =
60.318 - let
60.319 - val c=ref 0;
60.320 - in
60.321 - (
60.322 - c:=uv_mod_cont(p);
60.323 -
60.324 - if !c=0 then raise error ("RATIONALS_UV_MOD_PP_EXCEPTION: content is 0")
60.325 - else uv_mod_div_list(p,!c)
60.326 - )
60.327 - end;
60.328 -
60.329 -(*. gets the leading coefficient of a uv polynomial .*)
60.330 -fun uv_mod_lc ([]:uv_poly) = 0
60.331 - | uv_mod_lc p = hd(rev(p));
60.332 -
60.333 -(*. calculates the euklidean polynomial remainder sequence in Zp .*)
60.334 -fun uv_mod_prs_euklid_p(p1:uv_poly,p2:uv_poly,p)=
60.335 - let
60.336 - val f =ref [];
60.337 - val f'=ref p2;
60.338 - val fi=ref [];
60.339 - in
60.340 - (
60.341 - f:=p2::p1::[];
60.342 - while uv_mod_deg(!f')>0 do
60.343 - (
60.344 - f':=uv_mod_prestp (hd(tl(!f))) (hd(!f)) p;
60.345 - if (!f')<>[] then
60.346 - (
60.347 - fi:=(!f');
60.348 - f:=(!fi)::(!f)
60.349 - )
60.350 - else ()
60.351 - );
60.352 - (!f)
60.353 -
60.354 - )
60.355 - end;
60.356 -
60.357 -(*. calculates the gcd of p1 and p2 in Zp .*)
60.358 -fun uv_mod_gcd_modp ([]:uv_poly) (p2:uv_poly) p = p2:uv_poly
60.359 - | uv_mod_gcd_modp p1 [] p= p1
60.360 - | uv_mod_gcd_modp p1 p2 p=
60.361 - let
60.362 - val p1'=ref[];
60.363 - val p2'=ref[];
60.364 - val pc=ref[];
60.365 - val g=ref [];
60.366 - val d=ref 0;
60.367 - val prs=ref [];
60.368 - in
60.369 - (
60.370 - if uv_mod_deg(p1)>=uv_mod_deg(p2) then
60.371 - (
60.372 - p1':=uv_mod_list_modp (uv_mod_pp(p1)) p;
60.373 - p2':=uv_mod_list_modp (uv_mod_pp(p2)) p
60.374 - )
60.375 - else
60.376 - (
60.377 - p1':=uv_mod_list_modp (uv_mod_pp(p2)) p;
60.378 - p2':=uv_mod_list_modp (uv_mod_pp(p1)) p
60.379 - );
60.380 - d:=uv_mod_mod2((gcd_int (uv_mod_cont(p1))) (uv_mod_cont(p2)), p) ;
60.381 - if !d>(p div 2) then d:=(!d)-p else ();
60.382 -
60.383 - prs:=uv_mod_prs_euklid_p(!p1',!p2',p);
60.384 -
60.385 - if hd(!prs)=[] then pc:=hd(tl(!prs))
60.386 - else pc:=hd(!prs);
60.387 -
60.388 - g:=uv_mod_smul_poly(uv_mod_pp(!pc),!d);
60.389 - !g
60.390 - )
60.391 - end;
60.392 -
60.393 -(*. calculates the minimum of two real values x and y .*)
60.394 -fun uv_mod_r_min(x,y):BasisLibrary.Real.real = if x>y then y else x;
60.395 -
60.396 -(*. calculates the minimum of two integer values x and y .*)
60.397 -fun uv_mod_min(x,y) = if x>y then y else x;
60.398 -
60.399 -(*. adds the squared values of a integer list .*)
60.400 -fun uv_mod_add_qu [] = 0.0
60.401 - | uv_mod_add_qu (x::p) = BasisLibrary.Real.fromInt(x)*BasisLibrary.Real.fromInt(x) + uv_mod_add_qu p;
60.402 -
60.403 -(*. calculates the euklidean norm .*)
60.404 -fun uv_mod_norm ([]:uv_poly) = 0.0
60.405 - | uv_mod_norm p = Math.sqrt(uv_mod_add_qu(p));
60.406 -
60.407 -(*. multipies two values a and b .*)
60.408 -fun uv_mod_multi a b = a * b;
60.409 -
60.410 -(*. decides if x is a prim, the list contains all primes which are lower then x .*)
60.411 -fun uv_mod_prim(x,[])= false
60.412 - | uv_mod_prim(x,[y])=if ((x mod y) <> 0) then true
60.413 - else false
60.414 - | uv_mod_prim(x,y::ys) = if uv_mod_prim(x,[y])
60.415 - then
60.416 - if uv_mod_prim(x,ys) then true
60.417 - else false
60.418 - else false;
60.419 -
60.420 -(*. gets the first prime, which is greater than p and does not divide g .*)
60.421 -fun uv_mod_nextprime(g,p)=
60.422 - let
60.423 - val list=ref [2];
60.424 - val exit=ref 0;
60.425 - val i = ref 2
60.426 - in
60.427 - while (!i<p) do (* calculates the primes lower then p *)
60.428 - (
60.429 - if uv_mod_prim(!i,!list) then
60.430 - (
60.431 - if (p mod !i <> 0)
60.432 - then
60.433 - (
60.434 - list:= (!i)::(!list);
60.435 - i:= (!i)+1
60.436 - )
60.437 - else i:=(!i)+1
60.438 - )
60.439 - else i:= (!i)+1
60.440 - );
60.441 - i:=(p+1);
60.442 - while (!exit=0) do (* calculate next prime which does not divide g *)
60.443 - (
60.444 - if uv_mod_prim(!i,!list) then
60.445 - (
60.446 - if (g mod !i <> 0)
60.447 - then
60.448 - (
60.449 - list:= (!i)::(!list);
60.450 - exit:= (!i)
60.451 - )
60.452 - else i:=(!i)+1
60.453 - )
60.454 - else i:= (!i)+1
60.455 - );
60.456 - !exit
60.457 - end;
60.458 -
60.459 -(*. decides if p1 is a factor of p2 in Zp .*)
60.460 -fun uv_mod_dividesp ([]:uv_poly) (p2:uv_poly) p= raise error("UV_MOD_DIVIDESP: Division by zero")
60.461 - | uv_mod_dividesp p1 p2 p= if uv_mod_prestp p2 p1 p = [] then true else false;
60.462 -
60.463 -(*. decides if p1 is a factor of p2 .*)
60.464 -fun uv_mod_divides ([]:uv_poly) (p2:uv_poly) = raise error("UV_MOD_DIVIDES: Division by zero")
60.465 - | uv_mod_divides p1 p2 = if uv_mod_prest p2 p1 = [] then true else false;
60.466 -
60.467 -(*. chinese remainder algorithm .*)
60.468 -fun uv_mod_cra2(r1,r2,m1,m2)=
60.469 - let
60.470 - val c=ref 0;
60.471 - val r1'=ref 0;
60.472 - val d=ref 0;
60.473 - val a=ref 0;
60.474 - in
60.475 - (
60.476 - while (uv_mod_mod2((!c)*m1,m2))<>1 do
60.477 - (
60.478 - c:=(!c)+1
60.479 - );
60.480 - r1':= uv_mod_mod2(r1,m1);
60.481 - d:=uv_mod_mod2(((r2-(!r1'))*(!c)),m2);
60.482 - !r1'+(!d)*m1
60.483 - )
60.484 - end;
60.485 -
60.486 -(*. applies the chinese remainder algorithmen to the coefficients of x1 and x2 .*)
60.487 -fun uv_mod_cra_2 ([],[],m1,m2) = []
60.488 - | uv_mod_cra_2 ([],x2,m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x1")
60.489 - | uv_mod_cra_2 (x1,[],m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x2")
60.490 - | uv_mod_cra_2 (x1::x1s,x2::x2s,m1,m2) = (uv_mod_cra2(x1,x2,m1,m2))::(uv_mod_cra_2(x1s,x2s,m1,m2));
60.491 -
60.492 -(*. calculates the gcd of two uv polynomials p1' and p2' with the modular algorithm .*)
60.493 -fun uv_mod_gcd (p1':uv_poly) (p2':uv_poly) =
60.494 - let
60.495 - val p1=ref (uv_mod_pp(p1'));
60.496 - val p2=ref (uv_mod_pp(p2'));
60.497 - val c=gcd_int (uv_mod_cont(p1')) (uv_mod_cont(p2'));
60.498 - val temp=ref [];
60.499 - val cp=ref [];
60.500 - val qp=ref [];
60.501 - val q=ref[];
60.502 - val pn=ref 0;
60.503 - val d=ref 0;
60.504 - val g1=ref 0;
60.505 - val p=ref 0;
60.506 - val m=ref 0;
60.507 - val exit=ref 0;
60.508 - val i=ref 1;
60.509 - in
60.510 - if length(!p1)>length(!p2) then ()
60.511 - else
60.512 - (
60.513 - temp:= !p1;
60.514 - p1:= !p2;
60.515 - p2:= !temp
60.516 - );
60.517 -
60.518 -
60.519 - d:=gcd_int (uv_mod_lc(!p1)) (uv_mod_lc(!p2));
60.520 - g1:=uv_mod_lc(!p1)*uv_mod_lc(!p2);
60.521 - p:=4;
60.522 -
60.523 - m:=BasisLibrary.Real.ceil(2.0 *
60.524 - BasisLibrary.Real.fromInt(!d) *
60.525 - BasisLibrary.Real.fromInt(power 2 (uv_mod_min(uv_mod_deg(!p2),uv_mod_deg(!p1)))) *
60.526 - BasisLibrary.Real.fromInt(!d) *
60.527 - uv_mod_r_min(uv_mod_norm(!p1) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p1))),
60.528 - uv_mod_norm(!p2) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p2)))));
60.529 -
60.530 - while (!exit=0) do
60.531 - (
60.532 - p:=uv_mod_nextprime(!d,!p);
60.533 - cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)) ;
60.534 - if abs(uv_mod_lc(!cp))<>1 then (* leading coefficient = 1 ? *)
60.535 - (
60.536 - i:=1;
60.537 - while (!i)<(!p) andalso (abs(uv_mod_mod2((uv_mod_lc(!cp)*(!i)),(!p)))<>1) do
60.538 - (
60.539 - i:=(!i)+1
60.540 - );
60.541 - cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p)
60.542 - )
60.543 - else ();
60.544 -
60.545 - qp:= ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp));
60.546 -
60.547 - if uv_mod_deg(!qp)=0 then (q:=[1]; exit:=1) else ();
60.548 -
60.549 - pn:=(!p);
60.550 - q:=(!qp);
60.551 -
60.552 - while !pn<= !m andalso !m>(!p) andalso !exit=0 do
60.553 - (
60.554 - p:=uv_mod_nextprime(!d,!p);
60.555 - cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p));
60.556 - if uv_mod_lc(!cp)<>1 then (* leading coefficient = 1 ? *)
60.557 - (
60.558 - i:=1;
60.559 - while (!i)<(!p) andalso ((uv_mod_mod2((uv_mod_lc(!q)*(!i)),(!p)))<>1) do
60.560 - (
60.561 - i:=(!i)+1
60.562 - );
60.563 - cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p)
60.564 - )
60.565 - else ();
60.566 -
60.567 - qp:=uv_mod_list_modp ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp) ) (!p);
60.568 - if uv_mod_deg(!qp)>uv_mod_deg(!q) then
60.569 - (
60.570 - (*print("degree to high!!!\n")*)
60.571 - )
60.572 - else
60.573 - (
60.574 - if uv_mod_deg(!qp)=uv_mod_deg(!q) then
60.575 - (
60.576 - q:=uv_mod_cra_2(!q,!qp,!pn,!p);
60.577 - pn:=(!pn) * !p;
60.578 - q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn)); (* found already gcd ? *)
60.579 - if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then (exit:=1) else ()
60.580 - )
60.581 - else
60.582 - (
60.583 - if uv_mod_deg(!qp)<uv_mod_deg(!q) then
60.584 - (
60.585 - pn:= !p;
60.586 - q:= !qp
60.587 - )
60.588 - else ()
60.589 - )
60.590 - )
60.591 - );
60.592 - q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn));
60.593 - if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then exit:=1 else ()
60.594 - );
60.595 - uv_mod_smul_poly(!q,c):uv_poly
60.596 - end;
60.597 -
60.598 -(*. multivariate polynomials .*)
60.599 -(*. multivariate polynomials are represented as a list of the pairs,
60.600 - first is the coefficent and the second is a list of the exponents .*)
60.601 -(*. 5 * x^5 * y^3 + 4 * x^3 * z^2 + 2 * x^2 * y * z^3 - z - 19
60.602 - => [(5,[5,3,0]),(4,[3,0,2]),(2,[2,1,3]),(~1,[0,0,1]),(~19,[0,0,0])] .*)
60.603 -
60.604 -(*. global variables .*)
60.605 -(*. order indicators .*)
60.606 -val LEX_=0; (* lexicographical term order *)
60.607 -val GGO_=1; (* greatest degree order *)
60.608 -
60.609 -(*. datatypes for internal representation.*)
60.610 -type mv_monom = (int * (*.coefficient or the monom.*)
60.611 - int list); (*.list of exponents) .*)
60.612 -fun mv_monom2str (i, is) = "("^ int2str i^"," ^ ints2str' is ^ ")";
60.613 -
60.614 -type mv_poly = mv_monom list;
60.615 -fun mv_poly2str p = (strs2str' o (map mv_monom2str)) p;
60.616 -
60.617 -(*. help function for monom_greater and geq .*)
60.618 -fun mv_mg_hlp([]) = EQUAL
60.619 - | mv_mg_hlp(x::list)=if x<0 then LESS
60.620 - else if x>0 then GREATER
60.621 - else mv_mg_hlp(list);
60.622 -
60.623 -(*. adds a list of values .*)
60.624 -fun mv_addlist([]) = 0
60.625 - | mv_addlist(p1) = hd(p1)+mv_addlist(tl(p1));
60.626 -
60.627 -(*. tests if the monomial M1 is greater as the monomial M2 and returns a boolean value .*)
60.628 -(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*)
60.629 -fun mv_monom_greater((M1x,M1l):mv_monom,(M2x,M2l):mv_monom,order)=
60.630 - if order=LEX_ then
60.631 - (
60.632 - if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error")
60.633 - else if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true
60.634 - )
60.635 - else
60.636 - if order=GGO_ then
60.637 - (
60.638 - if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error")
60.639 - else
60.640 - if mv_addlist(M1l)=mv_addlist(M2l) then if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true
60.641 - else if mv_addlist(M1l)>mv_addlist(M2l) then true else false
60.642 - )
60.643 - else raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Wrong Order");
60.644 -
60.645 -(*. tests if the monomial X is greater as the monomial Y and returns a order value (GREATER,EQUAL,LESS) .*)
60.646 -(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*)
60.647 -fun mv_geq order ((x1,x):mv_monom,(x2,y):mv_monom) =
60.648 -let
60.649 - val temp=ref EQUAL;
60.650 -in
60.651 - if order=LEX_ then
60.652 - (
60.653 - if length(x)<>length(y) then
60.654 - raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error")
60.655 - else
60.656 - (
60.657 - temp:=mv_mg_hlp((map op- (x~~y)));
60.658 - if !temp=EQUAL then
60.659 - ( if x1=x2 then EQUAL
60.660 - else if x1>x2 then GREATER
60.661 - else LESS
60.662 - )
60.663 - else (!temp)
60.664 - )
60.665 - )
60.666 - else
60.667 - if order=GGO_ then
60.668 - (
60.669 - if length(x)<>length(y) then
60.670 - raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error")
60.671 - else
60.672 - if mv_addlist(x)=mv_addlist(y) then
60.673 - (mv_mg_hlp((map op- (x~~y))))
60.674 - else if mv_addlist(x)>mv_addlist(y) then GREATER else LESS
60.675 - )
60.676 - else raise error ("RATIONALS_MV_GEQ_EXCEPTION: Wrong Order")
60.677 -end;
60.678 -
60.679 -(*. cuts the first variable from a polynomial .*)
60.680 -fun mv_cut([]:mv_poly)=[]:mv_poly
60.681 - | mv_cut((x,[])::list) = raise error ("RATIONALS_MV_CUT_EXCEPTION: Invalid list ")
60.682 - | mv_cut((x,y::ys)::list)=(x,ys)::mv_cut(list);
60.683 -
60.684 -(*. leading power product .*)
60.685 -fun mv_lpp([]:mv_poly,order) = []
60.686 - | mv_lpp([(x,y)],order) = y
60.687 - | mv_lpp(p1,order) = #2(hd(rev(sort (mv_geq order) p1)));
60.688 -
60.689 -(*. leading monomial .*)
60.690 -fun mv_lm([]:mv_poly,order) = (0,[]):mv_monom
60.691 - | mv_lm([x],order) = x
60.692 - | mv_lm(p1,order) = hd(rev(sort (mv_geq order) p1));
60.693 -
60.694 -(*. leading coefficient in term order .*)
60.695 -fun mv_lc2([]:mv_poly,order) = 0
60.696 - | mv_lc2([(x,y)],order) = x
60.697 - | mv_lc2(p1,order) = #1(hd(rev(sort (mv_geq order) p1)));
60.698 -
60.699 -
60.700 -(*. reverse the coefficients in mv polynomial .*)
60.701 -fun mv_rev_to([]:mv_poly) = []:mv_poly
60.702 - | mv_rev_to((c,e)::xs) = (c,rev(e))::mv_rev_to(xs);
60.703 -
60.704 -(*. leading coefficient in reverse term order .*)
60.705 -fun mv_lc([]:mv_poly,order) = []:mv_poly
60.706 - | mv_lc([(x,y)],order) = mv_rev_to(mv_cut(mv_rev_to([(x,y)])))
60.707 - | mv_lc(p1,order) =
60.708 - let
60.709 - val p1o=ref (rev(sort (mv_geq order) (mv_rev_to(p1))));
60.710 - val lp=hd(#2(hd(!p1o)));
60.711 - val lc=ref [];
60.712 - in
60.713 - (
60.714 - while (length(!p1o)>0 andalso hd(#2(hd(!p1o)))=lp) do
60.715 - (
60.716 - lc:=hd(mv_cut([hd(!p1o)]))::(!lc);
60.717 - p1o:=tl(!p1o)
60.718 - );
60.719 - if !lc=[] then raise error ("RATIONALS_MV_LC_EXCEPTION: lc is empty") else ();
60.720 - mv_rev_to(!lc)
60.721 - )
60.722 - end;
60.723 -
60.724 -(*. compares two powerproducts .*)
60.725 -fun mv_monom_equal((_,xlist):mv_monom,(_,ylist):mv_monom) = (foldr and_) (((map op=) (xlist~~ylist)),true);
60.726 -
60.727 -(*. help function for mv_add .*)
60.728 -fun mv_madd([]:mv_poly,[]:mv_poly,order) = []:mv_poly
60.729 - | mv_madd([(0,_)],p2,order) = p2
60.730 - | mv_madd(p1,[(0,_)],order) = p1
60.731 - | mv_madd([],p2,order) = p2
60.732 - | mv_madd(p1,[],order) = p1
60.733 - | mv_madd(p1,p2,order) =
60.734 - (
60.735 - if mv_monom_greater(hd(p1),hd(p2),order)
60.736 - then hd(p1)::mv_madd(tl(p1),p2,order)
60.737 - else if mv_monom_equal(hd(p1),hd(p2))
60.738 - then if mv_lc2(p1,order)+mv_lc2(p2,order)<>0
60.739 - then (mv_lc2(p1,order)+mv_lc2(p2,order),mv_lpp(p1,order))::mv_madd(tl(p1),tl(p2),order)
60.740 - else mv_madd(tl(p1),tl(p2),order)
60.741 - else hd(p2)::mv_madd(p1,tl(p2),order)
60.742 - )
60.743 -
60.744 -(*. adds two multivariate polynomials .*)
60.745 -fun mv_add([]:mv_poly,p2:mv_poly,order) = p2
60.746 - | mv_add(p1,[],order) = p1
60.747 - | mv_add(p1,p2,order) = mv_madd(rev(sort (mv_geq order) p1),rev(sort (mv_geq order) p2), order);
60.748 -
60.749 -(*. monom multiplication .*)
60.750 -fun mv_mmul((x1,y1):mv_monom,(x2,y2):mv_monom)=(x1*x2,(map op+) (y1~~y2)):mv_monom;
60.751 -
60.752 -(*. deletes all monomials with coefficient 0 .*)
60.753 -fun mv_shorten([]:mv_poly,order) = []:mv_poly
60.754 - | mv_shorten(x::xs,order)=mv_madd([x],mv_shorten(xs,order),order);
60.755 -
60.756 -(*. zeros a list .*)
60.757 -fun mv_null2([])=[]
60.758 - | mv_null2(x::l)=0::mv_null2(l);
60.759 -
60.760 -(*. multiplies two multivariate polynomials .*)
60.761 -fun mv_mul([]:mv_poly,[]:mv_poly,_) = []:mv_poly
60.762 - | mv_mul([],y::p2,_) = [(0,mv_null2(#2(y)))]
60.763 - | mv_mul(x::p1,[],_) = [(0,mv_null2(#2(x)))]
60.764 - | mv_mul(x::p1,y::p2,order) = mv_shorten(rev(sort (mv_geq order) (mv_mmul(x,y) :: (mv_mul(p1,y::p2,order) @
60.765 - mv_mul([x],p2,order)))),order);
60.766 -
60.767 -(*. gets the maximum value of a list .*)
60.768 -fun mv_getmax([])=0
60.769 - | mv_getmax(x::p1)= let
60.770 - val m=mv_getmax(p1);
60.771 - in
60.772 - if m>x then m
60.773 - else x
60.774 - end;
60.775 -(*. calculates the maximum degree of an multivariate polynomial .*)
60.776 -fun mv_grad([]:mv_poly) = 0
60.777 - | mv_grad(p1:mv_poly)= mv_getmax((map mv_addlist) ((map #2) p1));
60.778 -
60.779 -(*. converts the sign of a value .*)
60.780 -fun mv_minus(x)=(~1) * x;
60.781 -
60.782 -(*. converts the sign of all coefficients of a polynomial .*)
60.783 -fun mv_minus2([]:mv_poly)=[]:mv_poly
60.784 - | mv_minus2(p1)=(mv_minus(#1(hd(p1))),#2(hd(p1)))::(mv_minus2(tl(p1)));
60.785 -
60.786 -(*. searches for a negativ value in a list .*)
60.787 -fun mv_is_negativ([])=false
60.788 - | mv_is_negativ(x::xs)=if x<0 then true else mv_is_negativ(xs);
60.789 -
60.790 -(*. division of monomials .*)
60.791 -fun mv_mdiv((0,[]):mv_monom,_:mv_monom)=(0,[]):mv_monom
60.792 - | mv_mdiv(_,(0,[]))= raise error ("RATIONALS_MV_MDIV_EXCEPTION Division by 0 ")
60.793 - | mv_mdiv(p1:mv_monom,p2:mv_monom)=
60.794 - let
60.795 - val c=ref (#1(p2));
60.796 - val pp=ref [];
60.797 - in
60.798 - (
60.799 - if !c=0 then raise error("MV_MDIV_EXCEPTION Dividing by zero")
60.800 - else c:=(#1(p1) div #1(p2));
60.801 - if #1(p2)<>0 then
60.802 - (
60.803 - pp:=(#2(mv_mmul((1,#2(p1)),(1,(map mv_minus) (#2(p2))))));
60.804 - if mv_is_negativ(!pp) then (0,!pp)
60.805 - else (!c,!pp)
60.806 - )
60.807 - else raise error("MV_MDIV_EXCEPTION Dividing by empty Polynom")
60.808 - )
60.809 - end;
60.810 -
60.811 -(*. prints a polynom for (internal use only) .*)
60.812 -fun mv_print_poly([]:mv_poly)=print("[]\n")
60.813 - | mv_print_poly((x,y)::[])= print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^")\n")
60.814 - | mv_print_poly((x,y)::p1) = (print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^"),");mv_print_poly(p1));
60.815 -
60.816 -
60.817 -(*. division of two multivariate polynomials .*)
60.818 -fun mv_division([]:mv_poly,g:mv_poly,order)=([]:mv_poly,[]:mv_poly)
60.819 - | mv_division(f,[],order)= raise error ("RATIONALS_MV_DIVISION_EXCEPTION Division by zero")
60.820 - | mv_division(f,g,order)=
60.821 - let
60.822 - val r=ref [];
60.823 - val q=ref [];
60.824 - val g'=ref [];
60.825 - val k=ref 0;
60.826 - val m=ref (0,[0]);
60.827 - val exit=ref 0;
60.828 - in
60.829 - r := rev(sort (mv_geq order) (mv_shorten(f,order)));
60.830 - g':= rev(sort (mv_geq order) (mv_shorten(g,order)));
60.831 - if #1(hd(!g'))=0 then raise error("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero") else ();
60.832 - if (mv_monom_greater (hd(!g'),hd(!r),order)) then ([(0,mv_null2(#2(hd(f))))],(!r))
60.833 - else
60.834 - (
60.835 - exit:=0;
60.836 - while (if (!exit)=0 then not(mv_monom_greater (hd(!g'),hd(!r),order)) else false) do
60.837 - (
60.838 - if (#1(mv_lm(!g',order)))<>0 then m:=mv_mdiv(mv_lm(!r,order),mv_lm(!g',order))
60.839 - else raise error ("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero");
60.840 - if #1(!m)<>0 then
60.841 - (
60.842 - q:=(!m)::(!q);
60.843 - r:=mv_add((!r),mv_minus2(mv_mul(!g',[!m],order)),order)
60.844 - )
60.845 - else exit:=1;
60.846 - if (if length(!r)<>0 then length(!g')<>0 else false) then ()
60.847 - else (exit:=1)
60.848 - );
60.849 - (rev(!q),!r)
60.850 - )
60.851 - end;
60.852 -
60.853 -(*. multiplies a polynomial with an integer .*)
60.854 -fun mv_skalar_mul([]:mv_poly,c) = []:mv_poly
60.855 - | mv_skalar_mul((x,y)::p1,c) = ((x * c),y)::mv_skalar_mul(p1,c);
60.856 -
60.857 -(*. inserts the a first variable into an polynomial with exponent v .*)
60.858 -fun mv_correct([]:mv_poly,v:int)=[]:mv_poly
60.859 - | mv_correct((x,y)::list,v:int)=(x,v::y)::mv_correct(list,v);
60.860 -
60.861 -(*. multivariate case .*)
60.862 -
60.863 -(*. decides if x is a factor of y .*)
60.864 -fun mv_divides([]:mv_poly,[]:mv_poly)= raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero")
60.865 - | mv_divides(x,[]) = raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero")
60.866 - | mv_divides(x:mv_poly,y:mv_poly) = #2(mv_division(y,x,LEX_))=[];
60.867 -
60.868 -(*. gets the maximum of a and b .*)
60.869 -fun mv_max(a,b) = if a>b then a else b;
60.870 -
60.871 -(*. gets the maximum exponent of a mv polynomial in the lexicographic term order .*)
60.872 -fun mv_deg([]:mv_poly) = 0
60.873 - | mv_deg(p1)=
60.874 - let
60.875 - val p1'=mv_shorten(p1,LEX_);
60.876 - in
60.877 - if length(p1')=0 then 0
60.878 - else mv_max(hd(#2(hd(p1'))),mv_deg(tl(p1')))
60.879 - end;
60.880 -
60.881 -(*. gets the maximum exponent of a mv polynomial in the reverse lexicographic term order .*)
60.882 -fun mv_deg2([]:mv_poly) = 0
60.883 - | mv_deg2(p1)=
60.884 - let
60.885 - val p1'=mv_shorten(p1,LEX_);
60.886 - in
60.887 - if length(p1')=0 then 0
60.888 - else mv_max(hd(rev(#2(hd(p1')))),mv_deg2(tl(p1')))
60.889 - end;
60.890 -
60.891 -(*. evaluates the mv polynomial at the value v of the main variable .*)
60.892 -fun mv_subs([]:mv_poly,v) = []:mv_poly
60.893 - | mv_subs((c,e)::p1:mv_poly,v) = mv_skalar_mul(mv_cut([(c,e)]),power v (hd(e))) @ mv_subs(p1,v);
60.894 -
60.895 -(*. calculates the content of a uv-polynomial in mv-representation .*)
60.896 -fun uv_content2([]:mv_poly) = 0
60.897 - | uv_content2((c,e)::p1) = (gcd_int c (uv_content2(p1)));
60.898 -
60.899 -(*. converts a uv-polynomial from mv-representation to uv-representation .*)
60.900 -fun uv_to_list ([]:mv_poly)=[]:uv_poly
60.901 - | uv_to_list ((c1,e1)::others) =
60.902 - let
60.903 - val count=ref 0;
60.904 - val max=mv_grad((c1,e1)::others);
60.905 - val help=ref ((c1,e1)::others);
60.906 - val list=ref [];
60.907 - in
60.908 - if length(e1)>1 then raise error ("RATIONALS_TO_LIST_EXCEPTION: not univariate")
60.909 - else if length(e1)=0 then [c1]
60.910 - else
60.911 - (
60.912 - count:=0;
60.913 - while (!count)<=max do
60.914 - (
60.915 - if length(!help)>0 andalso hd(#2(hd(!help)))=max-(!count) then
60.916 - (
60.917 - list:=(#1(hd(!help)))::(!list);
60.918 - help:=tl(!help)
60.919 - )
60.920 - else
60.921 - (
60.922 - list:= 0::(!list)
60.923 - );
60.924 - count := (!count) + 1
60.925 - );
60.926 - (!list)
60.927 - )
60.928 - end;
60.929 -
60.930 -(*. converts a uv-polynomial from uv-representation to mv-representation .*)
60.931 -fun uv_to_poly ([]:uv_poly) = []:mv_poly
60.932 - | uv_to_poly p1 =
60.933 - let
60.934 - val count=ref 0;
60.935 - val help=ref p1;
60.936 - val list=ref [];
60.937 - in
60.938 - while length(!help)>0 do
60.939 - (
60.940 - if hd(!help)=0 then ()
60.941 - else list:=(hd(!help),[!count])::(!list);
60.942 - count:=(!count)+1;
60.943 - help:=tl(!help)
60.944 - );
60.945 - (!list)
60.946 - end;
60.947 -
60.948 -(*. univariate gcd calculation from polynomials in multivariate representation .*)
60.949 -fun uv_gcd ([]:mv_poly) p2 = p2
60.950 - | uv_gcd p1 ([]:mv_poly) = p1
60.951 - | uv_gcd p1 [(c,[e])] =
60.952 - let
60.953 - val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_))));
60.954 - val min=uv_mod_min(e,(hd(#2(hd(rev(!list))))));
60.955 - in
60.956 - [(gcd_int (uv_content2(p1)) c,[min])]
60.957 - end
60.958 - | uv_gcd [(c,[e])] p2 =
60.959 - let
60.960 - val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p2,LEX_))));
60.961 - val min=uv_mod_min(e,(hd(#2(hd(rev(!list))))));
60.962 - in
60.963 - [(gcd_int (uv_content2(p2)) c,[min])]
60.964 - end
60.965 - | uv_gcd p11 p22 = uv_to_poly(uv_mod_gcd (uv_to_list(mv_shorten(p11,LEX_))) (uv_to_list(mv_shorten(p22,LEX_))));
60.966 -
60.967 -(*. help function for the newton interpolation .*)
60.968 -fun mv_newton_help ([]:mv_poly list,k:int) = []:mv_poly list
60.969 - | mv_newton_help (pl:mv_poly list,k) =
60.970 - let
60.971 - val x=ref (rev(pl));
60.972 - val t=ref [];
60.973 - val y=ref [];
60.974 - val n=ref 1;
60.975 - val n1=ref[];
60.976 - in
60.977 - (
60.978 - while length(!x)>1 do
60.979 - (
60.980 - if length(hd(!x))>0 then n1:=mv_null2(#2(hd(hd(!x))))
60.981 - else if length(hd(tl(!x)))>0 then n1:=mv_null2(#2(hd(hd(tl(!x)))))
60.982 - else n1:=[];
60.983 - t:= #1(mv_division(mv_add(hd(!x),mv_skalar_mul(hd(tl(!x)),~1),LEX_),[(k,!n1)],LEX_));
60.984 - y:=(!t)::(!y);
60.985 - x:=tl(!x)
60.986 - );
60.987 - (!y)
60.988 - )
60.989 - end;
60.990 -
60.991 -(*. help function for the newton interpolation .*)
60.992 -fun mv_newton_add ([]:mv_poly list) t = []:mv_poly
60.993 - | mv_newton_add [x:mv_poly] t = x
60.994 - | mv_newton_add (pl:mv_poly list) t =
60.995 - let
60.996 - val expos=ref [];
60.997 - val pll=ref pl;
60.998 - in
60.999 - (
60.1000 -
60.1001 - while length(!pll)>0 andalso hd(!pll)=[] do
60.1002 - (
60.1003 - pll:=tl(!pll)
60.1004 - );
60.1005 - if length(!pll)>0 then expos:= #2(hd(hd(!pll))) else expos:=[];
60.1006 - mv_add(hd(pl),
60.1007 - mv_mul(
60.1008 - mv_add(mv_correct(mv_cut([(1,mv_null2(!expos))]),1),[(~t,mv_null2(!expos))],LEX_),
60.1009 - mv_newton_add (tl(pl)) (t+1),
60.1010 - LEX_
60.1011 - ),
60.1012 - LEX_)
60.1013 - )
60.1014 - end;
60.1015 -
60.1016 -(*. calculates the newton interpolation with polynomial coefficients .*)
60.1017 -(*. step-depth is 1 and if the result is not an integerpolynomial .*)
60.1018 -(*. this function returns [] .*)
60.1019 -fun mv_newton ([]:(mv_poly) list) = []:mv_poly
60.1020 - | mv_newton ([mp]:(mv_poly) list) = mp:mv_poly
60.1021 - | mv_newton pl =
60.1022 - let
60.1023 - val c=ref pl;
60.1024 - val c1=ref [];
60.1025 - val n=length(pl);
60.1026 - val k=ref 1;
60.1027 - val i=ref n;
60.1028 - val ppl=ref [];
60.1029 - in
60.1030 - c1:=hd(pl)::[];
60.1031 - c:=mv_newton_help(!c,!k);
60.1032 - c1:=(hd(!c))::(!c1);
60.1033 - while(length(!c)>1 andalso !k<n) do
60.1034 - (
60.1035 - k:=(!k)+1;
60.1036 - while length(!c)>0 andalso hd(!c)=[] do c:=tl(!c);
60.1037 - if !c=[] then () else c:=mv_newton_help(!c,!k);
60.1038 - ppl:= !c;
60.1039 - if !c=[] then () else c1:=(hd(!c))::(!c1)
60.1040 - );
60.1041 - while hd(!c1)=[] do c1:=tl(!c1);
60.1042 - c1:=rev(!c1);
60.1043 - ppl:= !c1;
60.1044 - mv_newton_add (!c1) 1
60.1045 - end;
60.1046 -
60.1047 -(*. sets the exponents of the first variable to zero .*)
60.1048 -fun mv_null3([]:mv_poly) = []:mv_poly
60.1049 - | mv_null3((x,y)::xs) = (x,0::tl(y))::mv_null3(xs);
60.1050 -
60.1051 -(*. calculates the minimum exponents of a multivariate polynomial .*)
60.1052 -fun mv_min_pp([]:mv_poly)=[]
60.1053 - | mv_min_pp((c,e)::xs)=
60.1054 - let
60.1055 - val y=ref xs;
60.1056 - val x=ref [];
60.1057 - in
60.1058 - (
60.1059 - x:=e;
60.1060 - while length(!y)>0 do
60.1061 - (
60.1062 - x:=(map uv_mod_min) ((!x) ~~ (#2(hd(!y))));
60.1063 - y:=tl(!y)
60.1064 - );
60.1065 - !x
60.1066 - )
60.1067 - end;
60.1068 -
60.1069 -(*. checks if all elements of the list have value zero .*)
60.1070 -fun list_is_null [] = true
60.1071 - | list_is_null (x::xs) = (x=0 andalso list_is_null(xs));
60.1072 -
60.1073 -(* check if main variable is zero*)
60.1074 -fun main_zero (ms : mv_poly) = (list_is_null o (map (hd o #2))) ms;
60.1075 -
60.1076 -(*. calculates the content of an polynomial .*)
60.1077 -fun mv_content([]:mv_poly) = []:mv_poly
60.1078 - | mv_content(p1) =
60.1079 - let
60.1080 - val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_))));
60.1081 - val test=ref (hd(#2(hd(!list))));
60.1082 - val result=ref [];
60.1083 - val min=(hd(#2(hd(rev(!list)))));
60.1084 - in
60.1085 - (
60.1086 - if length(!list)>1 then
60.1087 - (
60.1088 - while (if length(!list)>0 then (hd(#2(hd(!list)))=(!test)) else false) do
60.1089 - (
60.1090 - result:=(#1(hd(!list)),tl(#2(hd(!list))))::(!result);
60.1091 -
60.1092 - if length(!list)<1 then list:=[]
60.1093 - else list:=tl(!list)
60.1094 -
60.1095 - );
60.1096 - if length(!list)>0 then
60.1097 - (
60.1098 - list:=mv_gcd (!result) (mv_cut(mv_content(!list)))
60.1099 - )
60.1100 - else list:=(!result);
60.1101 - list:=mv_correct(!list,0);
60.1102 - (!list)
60.1103 - )
60.1104 - else
60.1105 - (
60.1106 - mv_null3(!list)
60.1107 - )
60.1108 - )
60.1109 - end
60.1110 -
60.1111 -(*. calculates the primitiv part of a polynomial .*)
60.1112 -and mv_pp([]:mv_poly) = []:mv_poly
60.1113 - | mv_pp(p1) = let
60.1114 - val cont=ref [];
60.1115 - val pp=ref[];
60.1116 - in
60.1117 - cont:=mv_content(p1);
60.1118 - pp:=(#1(mv_division(p1,!cont,LEX_)));
60.1119 - if !pp=[]
60.1120 - then raise error("RATIONALS_MV_PP_EXCEPTION: Invalid Content ")
60.1121 - else (!pp)
60.1122 - end
60.1123 -
60.1124 -(*. calculates the gcd of two multivariate polynomials with a modular approach .*)
60.1125 -and mv_gcd ([]:mv_poly) ([]:mv_poly) :mv_poly= []:mv_poly
60.1126 - | mv_gcd ([]:mv_poly) (p2) :mv_poly= p2:mv_poly
60.1127 - | mv_gcd (p1:mv_poly) ([]) :mv_poly= p1:mv_poly
60.1128 - | mv_gcd ([(x,xs)]:mv_poly) ([(y,ys)]):mv_poly =
60.1129 - let
60.1130 - val xpoly:mv_poly = [(x,xs)];
60.1131 - val ypoly:mv_poly = [(y,ys)];
60.1132 - in
60.1133 - (
60.1134 - if xs=ys then [((gcd_int x y),xs)]
60.1135 - else [((gcd_int x y),(map uv_mod_min)(xs~~ys))]:mv_poly
60.1136 - )
60.1137 - end
60.1138 - | mv_gcd (p1:mv_poly) ([(y,ys)]) :mv_poly=
60.1139 - (
60.1140 - [(gcd_int (uv_content2(p1)) (y),(map uv_mod_min)(mv_min_pp(p1)~~ys))]:mv_poly
60.1141 - )
60.1142 - | mv_gcd ([(y,ys)]:mv_poly) (p2):mv_poly =
60.1143 - (
60.1144 - [(gcd_int (uv_content2(p2)) (y),(map uv_mod_min)(mv_min_pp(p2)~~ys))]:mv_poly
60.1145 - )
60.1146 - | mv_gcd (p1':mv_poly) (p2':mv_poly):mv_poly=
60.1147 - let
60.1148 - val vc=length(#2(hd(p1')));
60.1149 - val cont =
60.1150 - (
60.1151 - if main_zero(mv_content(p1')) andalso
60.1152 - (main_zero(mv_content(p2'))) then
60.1153 - mv_correct((mv_gcd (mv_cut(mv_content(p1'))) (mv_cut(mv_content(p2')))),0)
60.1154 - else
60.1155 - mv_gcd (mv_content(p1')) (mv_content(p2'))
60.1156 - );
60.1157 - val p1= #1(mv_division(p1',mv_content(p1'),LEX_));
60.1158 - val p2= #1(mv_division(p2',mv_content(p2'),LEX_));
60.1159 - val gcd=ref [];
60.1160 - val candidate=ref [];
60.1161 - val interpolation_list=ref [];
60.1162 - val delta=ref [];
60.1163 - val p1r = ref [];
60.1164 - val p2r = ref [];
60.1165 - val p1r' = ref [];
60.1166 - val p2r' = ref [];
60.1167 - val factor=ref [];
60.1168 - val r=ref 0;
60.1169 - val gcd_r=ref [];
60.1170 - val d=ref 0;
60.1171 - val exit=ref 0;
60.1172 - val current_degree=ref 99999; (*. FIXME: unlimited ! .*)
60.1173 - in
60.1174 - (
60.1175 - if vc<2 then (* areUnivariate(p1',p2') *)
60.1176 - (
60.1177 - gcd:=uv_gcd (mv_shorten(p1',LEX_)) (mv_shorten(p2',LEX_))
60.1178 - )
60.1179 - else
60.1180 - (
60.1181 - while !exit=0 do
60.1182 - (
60.1183 - r:=(!r)+1;
60.1184 - p1r := mv_lc(p1,LEX_);
60.1185 - p2r := mv_lc(p2,LEX_);
60.1186 - if main_zero(!p1r) andalso
60.1187 - main_zero(!p2r)
60.1188 - then
60.1189 - (
60.1190 - delta := mv_correct((mv_gcd (mv_cut (!p1r)) (mv_cut (!p2r))),0)
60.1191 - )
60.1192 - else
60.1193 - (
60.1194 - delta := mv_gcd (!p1r) (!p2r)
60.1195 - );
60.1196 - (*if mv_shorten(mv_subs(!p1r,!r),LEX_)=[] andalso
60.1197 - mv_shorten(mv_subs(!p2r,!r),LEX_)=[] *)
60.1198 - if mv_lc2(mv_shorten(mv_subs(!p1r,!r),LEX_),LEX_)=0 andalso
60.1199 - mv_lc2(mv_shorten(mv_subs(!p2r,!r),LEX_),LEX_)=0
60.1200 - then
60.1201 - (
60.1202 - )
60.1203 - else
60.1204 - (
60.1205 - gcd_r:=mv_shorten(mv_gcd (mv_shorten(mv_subs(p1,!r),LEX_))
60.1206 - (mv_shorten(mv_subs(p2,!r),LEX_)) ,LEX_);
60.1207 - gcd_r:= #1(mv_division(mv_mul(mv_correct(mv_subs(!delta,!r),0),!gcd_r,LEX_),
60.1208 - mv_correct(mv_lc(!gcd_r,LEX_),0),LEX_));
60.1209 - d:=mv_deg2(!gcd_r); (* deg(gcd_r,z) *)
60.1210 - if (!d < !current_degree) then
60.1211 - (
60.1212 - current_degree:= !d;
60.1213 - interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list)
60.1214 - )
60.1215 - else
60.1216 - (
60.1217 - if (!d = !current_degree) then
60.1218 - (
60.1219 - interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list)
60.1220 - )
60.1221 - else ()
60.1222 - )
60.1223 - );
60.1224 - if length(!interpolation_list)> uv_mod_min(mv_deg(p1),mv_deg(p2)) then
60.1225 - (
60.1226 - candidate := mv_newton(rev(!interpolation_list));
60.1227 - if !candidate=[] then ()
60.1228 - else
60.1229 - (
60.1230 - candidate:=mv_pp(!candidate);
60.1231 - if mv_divides(!candidate,p1) andalso mv_divides(!candidate,p2) then
60.1232 - (
60.1233 - gcd:= mv_mul(!candidate,cont,LEX_);
60.1234 - exit:=1
60.1235 - )
60.1236 - else ()
60.1237 - );
60.1238 - interpolation_list:=[mv_correct(!gcd_r,0)]
60.1239 - )
60.1240 - else ()
60.1241 - )
60.1242 - );
60.1243 - (!gcd):mv_poly
60.1244 - )
60.1245 - end;
60.1246 -
60.1247 -
60.1248 -(*. calculates the least common divisor of two polynomials .*)
60.1249 -fun mv_lcm (p1:mv_poly) (p2:mv_poly) :mv_poly =
60.1250 - (
60.1251 - #1(mv_division(mv_mul(p1,p2,LEX_),mv_gcd p1 p2,LEX_))
60.1252 - );
60.1253 -
60.1254 -(*. gets the variables (strings) of a term .*)
60.1255 -fun get_vars(term1) = (map free2str) (vars term1); (*["a","b","c"]; *)
60.1256 -
60.1257 -(*. counts the negative coefficents in a polynomial .*)
60.1258 -fun count_neg ([]:mv_poly) = 0
60.1259 - | count_neg ((c,e)::xs) = if c<0 then 1+count_neg xs
60.1260 - else count_neg xs;
60.1261 -
60.1262 -(*. help function for is_polynomial
60.1263 - checks the order of the operators .*)
60.1264 -fun test_polynomial (Const ("uminus",_) $ Free (str,_)) _ = true (*WN.13.3.03*)
60.1265 - | test_polynomial (t as Free(str,_)) v = true
60.1266 - | test_polynomial (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false
60.1267 - else (test_polynomial t1 "*") andalso (test_polynomial t2 "*")
60.1268 - | test_polynomial (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
60.1269 - else (test_polynomial t1 " ") andalso (test_polynomial t2 " ")
60.1270 - | test_polynomial (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_polynomial t1 "^") andalso (test_polynomial t2 "^")
60.1271 - | test_polynomial _ v = false;
60.1272 -
60.1273 -(*. tests if a term is a polynomial .*)
60.1274 -fun is_polynomial t = test_polynomial t " ";
60.1275 -
60.1276 -(*. help function for is_expanded
60.1277 - checks the order of the operators .*)
60.1278 -fun test_exp (t as Free(str,_)) v = true
60.1279 - | test_exp (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false
60.1280 - else (test_exp t1 "*") andalso (test_exp t2 "*")
60.1281 - | test_exp (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
60.1282 - else (test_exp t1 " ") andalso (test_exp t2 " ")
60.1283 - | test_exp (t as Const ("op -",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
60.1284 - else (test_exp t1 " ") andalso (test_exp t2 " ")
60.1285 - | test_exp (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_exp t1 "^") andalso (test_exp t2 "^")
60.1286 - | test_exp _ v = false;
60.1287 -
60.1288 -
60.1289 -(*. help function for check_coeff:
60.1290 - converts the term to a list of coefficients .*)
60.1291 -fun term2coef' (t as Free(str,_(*typ*))) v :mv_poly option =
60.1292 - let
60.1293 - val x=ref NONE;
60.1294 - val len=ref 0;
60.1295 - val vl=ref [];
60.1296 - val vh=ref [];
60.1297 - val i=ref 0;
60.1298 - in
60.1299 - if is_numeral str then
60.1300 - (
60.1301 - SOME [(((the o int_of_str) str),mv_null2(v))] handle _ => NONE
60.1302 - )
60.1303 - else (* variable *)
60.1304 - (
60.1305 - len:=length(v);
60.1306 - vh:=v;
60.1307 - while ((!len)>(!i)) do
60.1308 - (
60.1309 - if str=hd((!vh)) then
60.1310 - (
60.1311 - vl:=1::(!vl)
60.1312 - )
60.1313 - else
60.1314 - (
60.1315 - vl:=0::(!vl)
60.1316 - );
60.1317 - vh:=tl(!vh);
60.1318 - i:=(!i)+1
60.1319 - );
60.1320 - SOME [(1,rev(!vl))] handle _ => NONE
60.1321 - )
60.1322 - end
60.1323 - | term2coef' (Const ("op *",_) $ t1 $ t2) v :mv_poly option=
60.1324 - let
60.1325 - val t1pp=ref [];
60.1326 - val t2pp=ref [];
60.1327 - val t1c=ref 0;
60.1328 - val t2c=ref 0;
60.1329 - in
60.1330 - (
60.1331 - t1pp:=(#2(hd(the(term2coef' t1 v))));
60.1332 - t2pp:=(#2(hd(the(term2coef' t2 v))));
60.1333 - t1c:=(#1(hd(the(term2coef' t1 v))));
60.1334 - t2c:=(#1(hd(the(term2coef' t2 v))));
60.1335 -
60.1336 - SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] handle _ => NONE
60.1337 -
60.1338 - )
60.1339 - end
60.1340 - | term2coef' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ (t2 as Free (str2,_))) v :mv_poly option=
60.1341 - let
60.1342 - val x=ref NONE;
60.1343 - val len=ref 0;
60.1344 - val vl=ref [];
60.1345 - val vh=ref [];
60.1346 - val vtemp=ref [];
60.1347 - val i=ref 0;
60.1348 - in
60.1349 - (
60.1350 - if (not o is_numeral) str1 andalso is_numeral str2 then
60.1351 - (
60.1352 - len:=length(v);
60.1353 - vh:=v;
60.1354 -
60.1355 - while ((!len)>(!i)) do
60.1356 - (
60.1357 - if str1=hd((!vh)) then
60.1358 - (
60.1359 - vl:=((the o int_of_str) str2)::(!vl)
60.1360 - )
60.1361 - else
60.1362 - (
60.1363 - vl:=0::(!vl)
60.1364 - );
60.1365 - vh:=tl(!vh);
60.1366 - i:=(!i)+1
60.1367 - );
60.1368 - SOME [(1,rev(!vl))] handle _ => NONE
60.1369 - )
60.1370 - else raise error ("RATIONALS_TERM2COEF_EXCEPTION 1: Invalid term")
60.1371 - )
60.1372 - end
60.1373 - | term2coef' (Const ("op +",_) $ t1 $ t2) v :mv_poly option=
60.1374 - (
60.1375 - SOME ((the(term2coef' t1 v)) @ (the(term2coef' t2 v))) handle _ => NONE
60.1376 - )
60.1377 - | term2coef' (Const ("op -",_) $ t1 $ t2) v :mv_poly option=
60.1378 - (
60.1379 - SOME ((the(term2coef' t1 v)) @ mv_skalar_mul((the(term2coef' t2 v)),1)) handle _ => NONE
60.1380 - )
60.1381 - | term2coef' (term) v = raise error ("RATIONALS_TERM2COEF_EXCEPTION 2: Invalid term");
60.1382 -
60.1383 -(*. checks if all coefficients of a polynomial are positiv (except the first) .*)
60.1384 -fun check_coeff t = (* erste Koeffizient kann <0 sein !!! *)
60.1385 - if count_neg(tl(the(term2coef' t (get_vars(t)))))=0 then true
60.1386 - else false;
60.1387 -
60.1388 -(*. checks for expanded term [3] .*)
60.1389 -fun is_expanded t = test_exp t " " andalso check_coeff(t);
60.1390 -
60.1391 -(*WN.7.3.03 Hilfsfunktion f"ur term2poly'*)
60.1392 -fun mk_monom v' p vs =
60.1393 - let fun conv p (v: string) = if v'= v then p else 0
60.1394 - in map (conv p) vs end;
60.1395 -(* mk_monom "y" 5 ["a","b","x","y","z"];
60.1396 -val it = [0,0,0,5,0] : int list*)
60.1397 -
60.1398 -(*. this function converts the term representation into the internal representation mv_poly .*)
60.1399 -fun term2poly' (Const ("uminus",_) $ Free (str,_)) v = (*WN.7.3.03*)
60.1400 - if is_numeral str
60.1401 - then SOME [((the o int_of_str) ("-"^str), mk_monom "#" 0 v)]
60.1402 - else SOME [(~1, mk_monom str 1 v)]
60.1403 -
60.1404 - | term2poly' (Free(str,_)) v :mv_poly option =
60.1405 - let
60.1406 - val x=ref NONE;
60.1407 - val len=ref 0;
60.1408 - val vl=ref [];
60.1409 - val vh=ref [];
60.1410 - val i=ref 0;
60.1411 - in
60.1412 - if is_numeral str then
60.1413 - (
60.1414 - SOME [(((the o int_of_str) str),mv_null2 v)] handle _ => NONE
60.1415 - )
60.1416 - else (* variable *)
60.1417 - (
60.1418 - len:=length v;
60.1419 - vh:= v;
60.1420 - while ((!len)>(!i)) do
60.1421 - (
60.1422 - if str=hd((!vh)) then
60.1423 - (
60.1424 - vl:=1::(!vl)
60.1425 - )
60.1426 - else
60.1427 - (
60.1428 - vl:=0::(!vl)
60.1429 - );
60.1430 - vh:=tl(!vh);
60.1431 - i:=(!i)+1
60.1432 - );
60.1433 - SOME [(1,rev(!vl))] handle _ => NONE
60.1434 - )
60.1435 - end
60.1436 - | term2poly' (Const ("op *",_) $ t1 $ t2) v :mv_poly option=
60.1437 - let
60.1438 - val t1pp=ref [];
60.1439 - val t2pp=ref [];
60.1440 - val t1c=ref 0;
60.1441 - val t2c=ref 0;
60.1442 - in
60.1443 - (
60.1444 - t1pp:=(#2(hd(the(term2poly' t1 v))));
60.1445 - t2pp:=(#2(hd(the(term2poly' t2 v))));
60.1446 - t1c:=(#1(hd(the(term2poly' t1 v))));
60.1447 - t2c:=(#1(hd(the(term2poly' t2 v))));
60.1448 -
60.1449 - SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )]
60.1450 - handle _ => NONE
60.1451 -
60.1452 - )
60.1453 - end
60.1454 - | term2poly' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $
60.1455 - (t2 as Free (str2,_))) v :mv_poly option=
60.1456 - let
60.1457 - val x=ref NONE;
60.1458 - val len=ref 0;
60.1459 - val vl=ref [];
60.1460 - val vh=ref [];
60.1461 - val vtemp=ref [];
60.1462 - val i=ref 0;
60.1463 - in
60.1464 - (
60.1465 - if (not o is_numeral) str1 andalso is_numeral str2 then
60.1466 - (
60.1467 - len:=length(v);
60.1468 - vh:=v;
60.1469 -
60.1470 - while ((!len)>(!i)) do
60.1471 - (
60.1472 - if str1=hd((!vh)) then
60.1473 - (
60.1474 - vl:=((the o int_of_str) str2)::(!vl)
60.1475 - )
60.1476 - else
60.1477 - (
60.1478 - vl:=0::(!vl)
60.1479 - );
60.1480 - vh:=tl(!vh);
60.1481 - i:=(!i)+1
60.1482 - );
60.1483 - SOME [(1,rev(!vl))] handle _ => NONE
60.1484 - )
60.1485 - else raise error ("RATIONALS_TERM2POLY_EXCEPTION 1: Invalid term")
60.1486 - )
60.1487 - end
60.1488 - | term2poly' (Const ("op +",_) $ t1 $ t2) v :mv_poly option =
60.1489 - (
60.1490 - SOME ((the(term2poly' t1 v)) @ (the(term2poly' t2 v))) handle _ => NONE
60.1491 - )
60.1492 - | term2poly' (Const ("op -",_) $ t1 $ t2) v :mv_poly option =
60.1493 - (
60.1494 - SOME ((the(term2poly' t1 v)) @ mv_skalar_mul((the(term2poly' t2 v)),~1)) handle _ => NONE
60.1495 - )
60.1496 - | term2poly' (term) v = raise error ("RATIONALS_TERM2POLY_EXCEPTION 2: Invalid term");
60.1497 -
60.1498 -(*. translates an Isabelle term into internal representation.
60.1499 - term2poly
60.1500 - fn : term -> (*normalform [2] *)
60.1501 - string list -> (*for ...!!! BITTE DIE ERKLÄRUNG,
60.1502 - DIE DU MIR LETZTES MAL GEGEBEN HAST*)
60.1503 - mv_monom list (*internal representation *)
60.1504 - option (*the translation may fail with NONE*)
60.1505 -.*)
60.1506 -fun term2poly (t:term) v =
60.1507 - if is_polynomial t then term2poly' t v
60.1508 - else raise error ("term2poly: invalid = "^(term2str t));
60.1509 -
60.1510 -(*. same as term2poly with automatic detection of the variables .*)
60.1511 -fun term2polyx t = term2poly t (((map free2str) o vars) t);
60.1512 -
60.1513 -(*. checks if the term is in expanded polynomial form and converts it into the internal representation .*)
60.1514 -fun expanded2poly (t:term) v =
60.1515 - (*if is_expanded t then*) term2poly' t v
60.1516 - (*else raise error ("RATIONALS_EXPANDED2POLY_EXCEPTION: Invalid Polynomial")*);
60.1517 -
60.1518 -(*. same as expanded2poly with automatic detection of the variables .*)
60.1519 -fun expanded2polyx t = expanded2poly t (((map free2str) o vars) t);
60.1520 -
60.1521 -(*. converts a powerproduct into term representation .*)
60.1522 -fun powerproduct2term(xs,v) =
60.1523 - let
60.1524 - val xss=ref xs;
60.1525 - val vv=ref v;
60.1526 - in
60.1527 - (
60.1528 - while hd(!xss)=0 do
60.1529 - (
60.1530 - xss:=tl(!xss);
60.1531 - vv:=tl(!vv)
60.1532 - );
60.1533 -
60.1534 - if list_is_null(tl(!xss)) then
60.1535 - (
60.1536 - if hd(!xss)=1 then Free(hd(!vv), HOLogic.realT)
60.1537 - else
60.1538 - (
60.1539 - Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1540 - Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT)
60.1541 - )
60.1542 - )
60.1543 - else
60.1544 - (
60.1545 - if hd(!xss)=1 then
60.1546 - (
60.1547 - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1548 - Free(hd(!vv), HOLogic.realT) $
60.1549 - powerproduct2term(tl(!xss),tl(!vv))
60.1550 - )
60.1551 - else
60.1552 - (
60.1553 - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1554 - (
60.1555 - Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1556 - Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT)
60.1557 - ) $
60.1558 - powerproduct2term(tl(!xss),tl(!vv))
60.1559 - )
60.1560 - )
60.1561 - )
60.1562 - end;
60.1563 -
60.1564 -(*. converts a monom into term representation .*)
60.1565 -(*fun monom2term ((c,e):mv_monom, v:string list) =
60.1566 - if c=0 then Free(str_of_int 0,HOLogic.realT)
60.1567 - else
60.1568 - (
60.1569 - if list_is_null(e) then
60.1570 - (
60.1571 - Free(str_of_int c,HOLogic.realT)
60.1572 - )
60.1573 - else
60.1574 - (
60.1575 - if c=1 then
60.1576 - (
60.1577 - powerproduct2term(e,v)
60.1578 - )
60.1579 - else
60.1580 - (
60.1581 - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1582 - Free(str_of_int c,HOLogic.realT) $
60.1583 - powerproduct2term(e,v)
60.1584 - )
60.1585 - )
60.1586 - );*)
60.1587 -
60.1588 -
60.1589 -(*fun monom2term ((i, is):mv_monom, v) =
60.1590 - if list_is_null is
60.1591 - then
60.1592 - if i >= 0
60.1593 - then Free (str_of_int i, HOLogic.realT)
60.1594 - else Const ("uminus", HOLogic.realT --> HOLogic.realT) $
60.1595 - Free ((str_of_int o abs) i, HOLogic.realT)
60.1596 - else
60.1597 - if i > 0
60.1598 - then Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
60.1599 - (Free (str_of_int i, HOLogic.realT)) $
60.1600 - powerproduct2term(is, v)
60.1601 - else Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
60.1602 - (Const ("uminus", HOLogic.realT --> HOLogic.realT) $
60.1603 - Free ((str_of_int o abs) i, HOLogic.realT)) $
60.1604 - powerproduct2term(is, vs);---------------------------*)
60.1605 -fun monom2term ((i, is) : mv_monom, vs) =
60.1606 - if list_is_null is
60.1607 - then Free (str_of_int i, HOLogic.realT)
60.1608 - else if i = 1
60.1609 - then powerproduct2term (is, vs)
60.1610 - else Const ("op *", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $
60.1611 - (Free (str_of_int i, HOLogic.realT)) $
60.1612 - powerproduct2term (is, vs);
60.1613 -
60.1614 -(*. converts the internal polynomial representation into an Isabelle term.*)
60.1615 -fun poly2term' ([] : mv_poly, vs) = Free(str_of_int 0, HOLogic.realT)
60.1616 - | poly2term' ([(c, e) : mv_monom], vs) = monom2term ((c, e), vs)
60.1617 - | poly2term' ((c, e) :: ces, vs) =
60.1618 - Const("op +", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $
60.1619 - poly2term (ces, vs) $ monom2term ((c, e), vs)
60.1620 -and poly2term (xs, vs) = poly2term' (rev (sort (mv_geq LEX_) (xs)), vs);
60.1621 -
60.1622 -
60.1623 -(*. converts a monom into term representation .*)
60.1624 -(*. ignores the sign of the coefficients => use only for exp-poly functions .*)
60.1625 -fun monom2term2((c,e):mv_monom, v:string list) =
60.1626 - if c=0 then Free(str_of_int 0,HOLogic.realT)
60.1627 - else
60.1628 - (
60.1629 - if list_is_null(e) then
60.1630 - (
60.1631 - Free(str_of_int (abs(c)),HOLogic.realT)
60.1632 - )
60.1633 - else
60.1634 - (
60.1635 - if abs(c)=1 then
60.1636 - (
60.1637 - powerproduct2term(e,v)
60.1638 - )
60.1639 - else
60.1640 - (
60.1641 - Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1642 - Free(str_of_int (abs(c)),HOLogic.realT) $
60.1643 - powerproduct2term(e,v)
60.1644 - )
60.1645 - )
60.1646 - );
60.1647 -
60.1648 -(*. converts the expanded polynomial representation into the term representation .*)
60.1649 -fun exp2term' ([]:mv_poly,vars) = Free(str_of_int 0,HOLogic.realT)
60.1650 - | exp2term' ([(c,e)],vars) = monom2term((c,e),vars)
60.1651 - | exp2term' ((c1,e1)::others,vars) =
60.1652 - if c1<0 then
60.1653 - Const("op -",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1654 - exp2term'(others,vars) $
60.1655 - (
60.1656 - monom2term2((c1,e1),vars)
60.1657 - )
60.1658 - else
60.1659 - Const("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1660 - exp2term'(others,vars) $
60.1661 - (
60.1662 - monom2term2((c1,e1),vars)
60.1663 - );
60.1664 -
60.1665 -(*. sorts the powerproduct by lexicographic termorder and converts them into
60.1666 - a term in polynomial representation .*)
60.1667 -fun poly2expanded (xs,vars) = exp2term'(rev(sort (mv_geq LEX_) (xs)),vars);
60.1668 -
60.1669 -(*. converts a polynomial into expanded form .*)
60.1670 -fun polynomial2expanded t =
60.1671 - (let
60.1672 - val vars=(((map free2str) o vars) t);
60.1673 - in
60.1674 - SOME (poly2expanded (the (term2poly t vars), vars))
60.1675 - end) handle _ => NONE;
60.1676 -
60.1677 -(*. converts a polynomial into polynomial form .*)
60.1678 -fun expanded2polynomial t =
60.1679 - (let
60.1680 - val vars=(((map free2str) o vars) t);
60.1681 - in
60.1682 - SOME (poly2term (the (expanded2poly t vars), vars))
60.1683 - end) handle _ => NONE;
60.1684 -
60.1685 -
60.1686 -(*. calculates the greatest common divisor of numerator and denominator and seperates it from each .*)
60.1687 -fun step_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) =
60.1688 - let
60.1689 - val p1' = ref [];
60.1690 - val p2' = ref [];
60.1691 - val p3 = ref []
60.1692 - val vars = rev(get_vars(p1) union get_vars(p2));
60.1693 - in
60.1694 - (
60.1695 - p1':= sort (mv_geq LEX_) (the (term2poly p1 vars ));
60.1696 - p2':= sort (mv_geq LEX_) (the (term2poly p2 vars ));
60.1697 - p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
60.1698 - if (!p3)=[(1,mv_null2(vars))] then
60.1699 - (
60.1700 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2
60.1701 - )
60.1702 - else
60.1703 - (
60.1704 -
60.1705 - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
60.1706 - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
60.1707 -
60.1708 - if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
60.1709 - (
60.1710 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1711 - $
60.1712 - (
60.1713 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1714 - poly2term(!p1',vars) $
60.1715 - poly2term(!p3,vars)
60.1716 - )
60.1717 - $
60.1718 - (
60.1719 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1720 - poly2term(!p2',vars) $
60.1721 - poly2term(!p3,vars)
60.1722 - )
60.1723 - )
60.1724 - else
60.1725 - (
60.1726 - p1':=mv_skalar_mul(!p1',~1);
60.1727 - p2':=mv_skalar_mul(!p2',~1);
60.1728 - p3:=mv_skalar_mul(!p3,~1);
60.1729 - (
60.1730 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1731 - $
60.1732 - (
60.1733 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1734 - poly2term(!p1',vars) $
60.1735 - poly2term(!p3,vars)
60.1736 - )
60.1737 - $
60.1738 - (
60.1739 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1740 - poly2term(!p2',vars) $
60.1741 - poly2term(!p3,vars)
60.1742 - )
60.1743 - )
60.1744 - )
60.1745 - )
60.1746 - )
60.1747 - end
60.1748 -| step_cancel _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction");
60.1749 -
60.1750 -
60.1751 -(*. same as step_cancel, this time for expanded forms (input+output) .*)
60.1752 -fun step_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) =
60.1753 - let
60.1754 - val p1' = ref [];
60.1755 - val p2' = ref [];
60.1756 - val p3 = ref []
60.1757 - val vars = rev(get_vars(p1) union get_vars(p2));
60.1758 - in
60.1759 - (
60.1760 - p1':= sort (mv_geq LEX_) (the (expanded2poly p1 vars ));
60.1761 - p2':= sort (mv_geq LEX_) (the (expanded2poly p2 vars ));
60.1762 - p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
60.1763 - if (!p3)=[(1,mv_null2(vars))] then
60.1764 - (
60.1765 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2
60.1766 - )
60.1767 - else
60.1768 - (
60.1769 -
60.1770 - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
60.1771 - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
60.1772 -
60.1773 - if #1(hd(sort (mv_geq LEX_) (!p2')))(* mv_lc2(!p2',LEX_)*)>0 then
60.1774 - (
60.1775 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1776 - $
60.1777 - (
60.1778 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1779 - poly2expanded(!p1',vars) $
60.1780 - poly2expanded(!p3,vars)
60.1781 - )
60.1782 - $
60.1783 - (
60.1784 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1785 - poly2expanded(!p2',vars) $
60.1786 - poly2expanded(!p3,vars)
60.1787 - )
60.1788 - )
60.1789 - else
60.1790 - (
60.1791 - p1':=mv_skalar_mul(!p1',~1);
60.1792 - p2':=mv_skalar_mul(!p2',~1);
60.1793 - p3:=mv_skalar_mul(!p3,~1);
60.1794 - (
60.1795 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1796 - $
60.1797 - (
60.1798 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1799 - poly2expanded(!p1',vars) $
60.1800 - poly2expanded(!p3,vars)
60.1801 - )
60.1802 - $
60.1803 - (
60.1804 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.1805 - poly2expanded(!p2',vars) $
60.1806 - poly2expanded(!p3,vars)
60.1807 - )
60.1808 - )
60.1809 - )
60.1810 - )
60.1811 - )
60.1812 - end
60.1813 -| step_cancel_expanded _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction");
60.1814 -
60.1815 -(*. calculates the greatest common divisor of numerator and denominator and divides each through it .*)
60.1816 -fun direct_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) =
60.1817 - let
60.1818 - val p1' = ref [];
60.1819 - val p2' = ref [];
60.1820 - val p3 = ref []
60.1821 - val vars = rev(get_vars(p1) union get_vars(p2));
60.1822 - in
60.1823 - (
60.1824 - p1':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p1 vars )),LEX_));
60.1825 - p2':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p2 vars )),LEX_));
60.1826 - p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
60.1827 -
60.1828 - if (!p3)=[(1,mv_null2(vars))] then
60.1829 - (
60.1830 - (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[])
60.1831 - )
60.1832 - else
60.1833 - (
60.1834 - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
60.1835 - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
60.1836 - if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
60.1837 - (
60.1838 - (
60.1839 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1840 - $
60.1841 - (
60.1842 - poly2term((!p1'),vars)
60.1843 - )
60.1844 - $
60.1845 - (
60.1846 - poly2term((!p2'),vars)
60.1847 - )
60.1848 - )
60.1849 - ,
60.1850 - if mv_grad(!p3)>0 then
60.1851 - [
60.1852 - (
60.1853 - Const ("Not",[bool]--->bool) $
60.1854 - (
60.1855 - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
60.1856 - poly2term((!p3),vars) $
60.1857 - Free("0",HOLogic.realT)
60.1858 - )
60.1859 - )
60.1860 - ]
60.1861 - else
60.1862 - []
60.1863 - )
60.1864 - else
60.1865 - (
60.1866 - p1':=mv_skalar_mul(!p1',~1);
60.1867 - p2':=mv_skalar_mul(!p2',~1);
60.1868 - if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1);
60.1869 - (
60.1870 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1871 - $
60.1872 - (
60.1873 - poly2term((!p1'),vars)
60.1874 - )
60.1875 - $
60.1876 - (
60.1877 - poly2term((!p2'),vars)
60.1878 - )
60.1879 - ,
60.1880 - if mv_grad(!p3)>0 then
60.1881 - [
60.1882 - (
60.1883 - Const ("Not",[bool]--->bool) $
60.1884 - (
60.1885 - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
60.1886 - poly2term((!p3),vars) $
60.1887 - Free("0",HOLogic.realT)
60.1888 - )
60.1889 - )
60.1890 - ]
60.1891 - else
60.1892 - []
60.1893 - )
60.1894 - )
60.1895 - )
60.1896 - )
60.1897 - end
60.1898 - | direct_cancel _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction");
60.1899 -
60.1900 -(*. same es direct_cancel, this time for expanded forms (input+output).*)
60.1901 -fun direct_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) =
60.1902 - let
60.1903 - val p1' = ref [];
60.1904 - val p2' = ref [];
60.1905 - val p3 = ref []
60.1906 - val vars = rev(get_vars(p1) union get_vars(p2));
60.1907 - in
60.1908 - (
60.1909 - p1':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p1 vars )),LEX_));
60.1910 - p2':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p2 vars )),LEX_));
60.1911 - p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
60.1912 -
60.1913 - if (!p3)=[(1,mv_null2(vars))] then
60.1914 - (
60.1915 - (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[])
60.1916 - )
60.1917 - else
60.1918 - (
60.1919 - p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
60.1920 - p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
60.1921 - if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
60.1922 - (
60.1923 - (
60.1924 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1925 - $
60.1926 - (
60.1927 - poly2expanded((!p1'),vars)
60.1928 - )
60.1929 - $
60.1930 - (
60.1931 - poly2expanded((!p2'),vars)
60.1932 - )
60.1933 - )
60.1934 - ,
60.1935 - if mv_grad(!p3)>0 then
60.1936 - [
60.1937 - (
60.1938 - Const ("Not",[bool]--->bool) $
60.1939 - (
60.1940 - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
60.1941 - poly2expanded((!p3),vars) $
60.1942 - Free("0",HOLogic.realT)
60.1943 - )
60.1944 - )
60.1945 - ]
60.1946 - else
60.1947 - []
60.1948 - )
60.1949 - else
60.1950 - (
60.1951 - p1':=mv_skalar_mul(!p1',~1);
60.1952 - p2':=mv_skalar_mul(!p2',~1);
60.1953 - if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1);
60.1954 - (
60.1955 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.1956 - $
60.1957 - (
60.1958 - poly2expanded((!p1'),vars)
60.1959 - )
60.1960 - $
60.1961 - (
60.1962 - poly2expanded((!p2'),vars)
60.1963 - )
60.1964 - ,
60.1965 - if mv_grad(!p3)>0 then
60.1966 - [
60.1967 - (
60.1968 - Const ("Not",[bool]--->bool) $
60.1969 - (
60.1970 - Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
60.1971 - poly2expanded((!p3),vars) $
60.1972 - Free("0",HOLogic.realT)
60.1973 - )
60.1974 - )
60.1975 - ]
60.1976 - else
60.1977 - []
60.1978 - )
60.1979 - )
60.1980 - )
60.1981 - )
60.1982 - end
60.1983 - | direct_cancel_expanded _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction");
60.1984 -
60.1985 -
60.1986 -(*. adds two fractions .*)
60.1987 -fun add_fract ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) =
60.1988 - let
60.1989 - val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22);
60.1990 - val t11'=ref (the(term2poly t11 vars));
60.1991 -val _= writeln"### add_fract: done t11"
60.1992 - val t12'=ref (the(term2poly t12 vars));
60.1993 -val _= writeln"### add_fract: done t12"
60.1994 - val t21'=ref (the(term2poly t21 vars));
60.1995 -val _= writeln"### add_fract: done t21"
60.1996 - val t22'=ref (the(term2poly t22 vars));
60.1997 -val _= writeln"### add_fract: done t22"
60.1998 - val den=ref [];
60.1999 - val nom=ref [];
60.2000 - val m1=ref [];
60.2001 - val m2=ref [];
60.2002 - in
60.2003 -
60.2004 - (
60.2005 - den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22'));
60.2006 -writeln"### add_fract: done sort mv_lcm";
60.2007 - m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_)));
60.2008 -writeln"### add_fract: done sort mv_division t12";
60.2009 - m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_)));
60.2010 -writeln"### add_fract: done sort mv_division t22";
60.2011 - nom :=sort (mv_geq LEX_)
60.2012 - (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),
60.2013 - mv_mul(!t21',!m2,LEX_),
60.2014 - LEX_),
60.2015 - LEX_));
60.2016 -writeln"### add_fract: done sort mv_add";
60.2017 - (
60.2018 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2019 - $
60.2020 - (
60.2021 - poly2term((!nom),vars)
60.2022 - )
60.2023 - $
60.2024 - (
60.2025 - poly2term((!den),vars)
60.2026 - )
60.2027 - )
60.2028 - )
60.2029 - end
60.2030 - | add_fract (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: Invalid add_fraction call");
60.2031 -
60.2032 -(*. adds two expanded fractions .*)
60.2033 -fun add_fract_exp ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) =
60.2034 - let
60.2035 - val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22);
60.2036 - val t11'=ref (the(expanded2poly t11 vars));
60.2037 - val t12'=ref (the(expanded2poly t12 vars));
60.2038 - val t21'=ref (the(expanded2poly t21 vars));
60.2039 - val t22'=ref (the(expanded2poly t22 vars));
60.2040 - val den=ref [];
60.2041 - val nom=ref [];
60.2042 - val m1=ref [];
60.2043 - val m2=ref [];
60.2044 - in
60.2045 -
60.2046 - (
60.2047 - den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22'));
60.2048 - m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_)));
60.2049 - m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_)));
60.2050 - nom :=sort (mv_geq LEX_) (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),mv_mul(!t21',!m2,LEX_),LEX_),LEX_));
60.2051 - (
60.2052 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2053 - $
60.2054 - (
60.2055 - poly2expanded((!nom),vars)
60.2056 - )
60.2057 - $
60.2058 - (
60.2059 - poly2expanded((!den),vars)
60.2060 - )
60.2061 - )
60.2062 - )
60.2063 - end
60.2064 - | add_fract_exp (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXP_EXCEPTION: Invalid add_fraction call");
60.2065 -
60.2066 -(*. adds a list of terms .*)
60.2067 -fun add_list_of_fractions []= (Free("0",HOLogic.realT),[])
60.2068 - | add_list_of_fractions [x]= direct_cancel x
60.2069 - | add_list_of_fractions (x::y::xs) =
60.2070 - let
60.2071 - val (t1a,rest1)=direct_cancel(x);
60.2072 -val _= writeln"### add_list_of_fractions xs: has done direct_cancel(x)";
60.2073 - val (t2a,rest2)=direct_cancel(y);
60.2074 -val _= writeln"### add_list_of_fractions xs: has done direct_cancel(y)";
60.2075 - val (t3a,rest3)=(add_list_of_fractions (add_fract(t1a,t2a)::xs));
60.2076 -val _= writeln"### add_list_of_fractions xs: has done add_list_of_fraction xs";
60.2077 - val (t4a,rest4)=direct_cancel(t3a);
60.2078 -val _= writeln"### add_list_of_fractions xs: has done direct_cancel(t3a)";
60.2079 - val rest=rest1 union rest2 union rest3 union rest4;
60.2080 - in
60.2081 - (writeln"### add_list_of_fractions in";
60.2082 - (
60.2083 - (t4a,rest)
60.2084 - )
60.2085 - )
60.2086 - end;
60.2087 -
60.2088 -(*. adds a list of expanded terms .*)
60.2089 -fun add_list_of_fractions_exp []= (Free("0",HOLogic.realT),[])
60.2090 - | add_list_of_fractions_exp [x]= direct_cancel_expanded x
60.2091 - | add_list_of_fractions_exp (x::y::xs) =
60.2092 - let
60.2093 - val (t1a,rest1)=direct_cancel_expanded(x);
60.2094 - val (t2a,rest2)=direct_cancel_expanded(y);
60.2095 - val (t3a,rest3)=(add_list_of_fractions_exp (add_fract_exp(t1a,t2a)::xs));
60.2096 - val (t4a,rest4)=direct_cancel_expanded(t3a);
60.2097 - val rest=rest1 union rest2 union rest3 union rest4;
60.2098 - in
60.2099 - (
60.2100 - (t4a,rest)
60.2101 - )
60.2102 - end;
60.2103 -
60.2104 -(*. calculates the lcm of a list of mv_poly .*)
60.2105 -fun calc_lcm ([x],var)= (x,var)
60.2106 - | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var);
60.2107 -
60.2108 -(*. converts a list of terms to a list of mv_poly .*)
60.2109 -fun t2d([],_)=[]
60.2110 - | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars);
60.2111 -
60.2112 -(*. same as t2d, this time for expanded forms .*)
60.2113 -fun t2d_exp([],_)=[]
60.2114 - | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars);
60.2115 -
60.2116 -(*. converts a list of fract terms to a list of their denominators .*)
60.2117 -fun termlist2denominators [] = ([],[])
60.2118 - | termlist2denominators xs =
60.2119 - let
60.2120 - val xxs=ref xs;
60.2121 - val var=ref [];
60.2122 - in
60.2123 - var:=[];
60.2124 - while length(!xxs)>0 do
60.2125 - (
60.2126 - let
60.2127 - val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
60.2128 - in
60.2129 - (
60.2130 - xxs:=tl(!xxs);
60.2131 - var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
60.2132 - )
60.2133 - end
60.2134 - );
60.2135 - (t2d(xs,!var),!var)
60.2136 - end;
60.2137 -
60.2138 -(*. calculates the lcm of a list of mv_poly .*)
60.2139 -fun calc_lcm ([x],var)= (x,var)
60.2140 - | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var);
60.2141 -
60.2142 -(*. converts a list of terms to a list of mv_poly .*)
60.2143 -fun t2d([],_)=[]
60.2144 - | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars);
60.2145 -
60.2146 -(*. same as t2d, this time for expanded forms .*)
60.2147 -fun t2d_exp([],_)=[]
60.2148 - | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars);
60.2149 -
60.2150 -(*. converts a list of fract terms to a list of their denominators .*)
60.2151 -fun termlist2denominators [] = ([],[])
60.2152 - | termlist2denominators xs =
60.2153 - let
60.2154 - val xxs=ref xs;
60.2155 - val var=ref [];
60.2156 - in
60.2157 - var:=[];
60.2158 - while length(!xxs)>0 do
60.2159 - (
60.2160 - let
60.2161 - val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
60.2162 - in
60.2163 - (
60.2164 - xxs:=tl(!xxs);
60.2165 - var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
60.2166 - )
60.2167 - end
60.2168 - );
60.2169 - (t2d(xs,!var),!var)
60.2170 - end;
60.2171 -
60.2172 -(*. same as termlist2denminators, this time for expanded forms .*)
60.2173 -fun termlist2denominators_exp [] = ([],[])
60.2174 - | termlist2denominators_exp xs =
60.2175 - let
60.2176 - val xxs=ref xs;
60.2177 - val var=ref [];
60.2178 - in
60.2179 - var:=[];
60.2180 - while length(!xxs)>0 do
60.2181 - (
60.2182 - let
60.2183 - val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
60.2184 - in
60.2185 - (
60.2186 - xxs:=tl(!xxs);
60.2187 - var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
60.2188 - )
60.2189 - end
60.2190 - );
60.2191 - (t2d_exp(xs,!var),!var)
60.2192 - end;
60.2193 -
60.2194 -(*. reduces all fractions to the least common denominator .*)
60.2195 -fun com_den(x::xs,denom,den,var)=
60.2196 - let
60.2197 - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
60.2198 - val p2= sort (mv_geq LEX_) (the(term2poly p2' var));
60.2199 - val p3= #1(mv_division(denom,p2,LEX_));
60.2200 - val p1var=get_vars(p1');
60.2201 - in
60.2202 - if length(xs)>0 then
60.2203 - if p3=[(1,mv_null2(var))] then
60.2204 - (
60.2205 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2206 - $
60.2207 - (
60.2208 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2209 - $
60.2210 - poly2term(the (term2poly p1' p1var),p1var)
60.2211 - $
60.2212 - den
60.2213 - )
60.2214 - $
60.2215 - #1(com_den(xs,denom,den,var))
60.2216 - ,
60.2217 - []
60.2218 - )
60.2219 - else
60.2220 - (
60.2221 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2222 - $
60.2223 - (
60.2224 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2225 - $
60.2226 - (
60.2227 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2228 - poly2term(the (term2poly p1' p1var),p1var) $
60.2229 - poly2term(p3,var)
60.2230 - )
60.2231 - $
60.2232 - (
60.2233 - den
60.2234 - )
60.2235 - )
60.2236 - $
60.2237 - #1(com_den(xs,denom,den,var))
60.2238 - ,
60.2239 - []
60.2240 - )
60.2241 - else
60.2242 - if p3=[(1,mv_null2(var))] then
60.2243 - (
60.2244 - (
60.2245 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2246 - $
60.2247 - poly2term(the (term2poly p1' p1var),p1var)
60.2248 - $
60.2249 - den
60.2250 - )
60.2251 - ,
60.2252 - []
60.2253 - )
60.2254 - else
60.2255 - (
60.2256 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2257 - $
60.2258 - (
60.2259 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2260 - poly2term(the (term2poly p1' p1var),p1var) $
60.2261 - poly2term(p3,var)
60.2262 - )
60.2263 - $
60.2264 - den
60.2265 - ,
60.2266 - []
60.2267 - )
60.2268 - end;
60.2269 -
60.2270 -(*. same as com_den, this time for expanded forms .*)
60.2271 -fun com_den_exp(x::xs,denom,den,var)=
60.2272 - let
60.2273 - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
60.2274 - val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var));
60.2275 - val p3= #1(mv_division(denom,p2,LEX_));
60.2276 - val p1var=get_vars(p1');
60.2277 - in
60.2278 - if length(xs)>0 then
60.2279 - if p3=[(1,mv_null2(var))] then
60.2280 - (
60.2281 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2282 - $
60.2283 - (
60.2284 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2285 - $
60.2286 - poly2expanded(the(expanded2poly p1' p1var),p1var)
60.2287 - $
60.2288 - den
60.2289 - )
60.2290 - $
60.2291 - #1(com_den_exp(xs,denom,den,var))
60.2292 - ,
60.2293 - []
60.2294 - )
60.2295 - else
60.2296 - (
60.2297 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2298 - $
60.2299 - (
60.2300 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2301 - $
60.2302 - (
60.2303 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2304 - poly2expanded(the(expanded2poly p1' p1var),p1var) $
60.2305 - poly2expanded(p3,var)
60.2306 - )
60.2307 - $
60.2308 - (
60.2309 - den
60.2310 - )
60.2311 - )
60.2312 - $
60.2313 - #1(com_den_exp(xs,denom,den,var))
60.2314 - ,
60.2315 - []
60.2316 - )
60.2317 - else
60.2318 - if p3=[(1,mv_null2(var))] then
60.2319 - (
60.2320 - (
60.2321 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2322 - $
60.2323 - poly2expanded(the(expanded2poly p1' p1var),p1var)
60.2324 - $
60.2325 - den
60.2326 - )
60.2327 - ,
60.2328 - []
60.2329 - )
60.2330 - else
60.2331 - (
60.2332 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
60.2333 - $
60.2334 - (
60.2335 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2336 - poly2expanded(the(expanded2poly p1' p1var),p1var) $
60.2337 - poly2expanded(p3,var)
60.2338 - )
60.2339 - $
60.2340 - den
60.2341 - ,
60.2342 - []
60.2343 - )
60.2344 - end;
60.2345 -
60.2346 -(* wird aktuell nicht mehr gebraucht, bei rückänderung schon
60.2347 --------------------------------------------------------------
60.2348 -(* WN0210???SK brauch ma des überhaupt *)
60.2349 -fun com_den2(x::xs,denom,den,var)=
60.2350 - let
60.2351 - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
60.2352 - val p2= sort (mv_geq LEX_) (the(term2poly p2' var));
60.2353 - val p3= #1(mv_division(denom,p2,LEX_));
60.2354 - val p1var=get_vars(p1');
60.2355 - in
60.2356 - if length(xs)>0 then
60.2357 - if p3=[(1,mv_null2(var))] then
60.2358 - (
60.2359 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2360 - poly2term(the(term2poly p1' p1var),p1var) $
60.2361 - com_den2(xs,denom,den,var)
60.2362 - )
60.2363 - else
60.2364 - (
60.2365 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2366 - (
60.2367 - let
60.2368 - val p3'=poly2term(p3,var);
60.2369 - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
60.2370 - in
60.2371 - poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars)
60.2372 - end
60.2373 - ) $
60.2374 - com_den2(xs,denom,den,var)
60.2375 - )
60.2376 - else
60.2377 - if p3=[(1,mv_null2(var))] then
60.2378 - (
60.2379 - poly2term(the(term2poly p1' p1var),p1var)
60.2380 - )
60.2381 - else
60.2382 - (
60.2383 - let
60.2384 - val p3'=poly2term(p3,var);
60.2385 - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
60.2386 - in
60.2387 - poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars)
60.2388 - end
60.2389 - )
60.2390 - end;
60.2391 -
60.2392 -(* WN0210???SK brauch ma des überhaupt *)
60.2393 -fun com_den_exp2(x::xs,denom,den,var)=
60.2394 - let
60.2395 - val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
60.2396 - val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var));
60.2397 - val p3= #1(mv_division(denom,p2,LEX_));
60.2398 - val p1var=get_vars p1';
60.2399 - in
60.2400 - if length(xs)>0 then
60.2401 - if p3=[(1,mv_null2(var))] then
60.2402 - (
60.2403 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2404 - poly2expanded(the (expanded2poly p1' p1var),p1var) $
60.2405 - com_den_exp2(xs,denom,den,var)
60.2406 - )
60.2407 - else
60.2408 - (
60.2409 - Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2410 - (
60.2411 - let
60.2412 - val p3'=poly2expanded(p3,var);
60.2413 - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
60.2414 - in
60.2415 - poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars)
60.2416 - end
60.2417 - ) $
60.2418 - com_den_exp2(xs,denom,den,var)
60.2419 - )
60.2420 - else
60.2421 - if p3=[(1,mv_null2(var))] then
60.2422 - (
60.2423 - poly2expanded(the (expanded2poly p1' p1var),p1var)
60.2424 - )
60.2425 - else
60.2426 - (
60.2427 - let
60.2428 - val p3'=poly2expanded(p3,var);
60.2429 - val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
60.2430 - in
60.2431 - poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars)
60.2432 - end
60.2433 - )
60.2434 - end;
60.2435 ----------------------------------------------------------*)
60.2436 -
60.2437 -
60.2438 -(*. searches for an element y of a list ys, which has an gcd not 1 with x .*)
60.2439 -fun exists_gcd (x,[]) = false
60.2440 - | exists_gcd (x,y::ys) = if mv_gcd x y = [(1,mv_null2(#2(hd(x))))] then exists_gcd (x,ys)
60.2441 - else true;
60.2442 -
60.2443 -(*. divides each element of the list xs with y .*)
60.2444 -fun list_div ([],y) = []
60.2445 - | list_div (x::xs,y) =
60.2446 - let
60.2447 - val (d,r)=mv_division(x,y,LEX_);
60.2448 - in
60.2449 - if r=[] then
60.2450 - d::list_div(xs,y)
60.2451 - else x::list_div(xs,y)
60.2452 - end;
60.2453 -
60.2454 -(*. checks if x is in the list ys .*)
60.2455 -fun in_list (x,[]) = false
60.2456 - | in_list (x,y::ys) = if x=y then true
60.2457 - else in_list(x,ys);
60.2458 -
60.2459 -(*. deletes all equal elements of the list xs .*)
60.2460 -fun kill_equal [] = []
60.2461 - | kill_equal (x::xs) = if in_list(x,xs) orelse x=[(1,mv_null2(#2(hd(x))))] then kill_equal(xs)
60.2462 - else x::kill_equal(xs);
60.2463 -
60.2464 -(*. searches for new factors .*)
60.2465 -fun new_factors [] = []
60.2466 - | new_factors (list:mv_poly list):mv_poly list =
60.2467 - let
60.2468 - val l = kill_equal list;
60.2469 - val len = length(l);
60.2470 - in
60.2471 - if len>=2 then
60.2472 - (
60.2473 - let
60.2474 - val x::y::xs=l;
60.2475 - val gcd=mv_gcd x y;
60.2476 - in
60.2477 - if gcd=[(1,mv_null2(#2(hd(x))))] then
60.2478 - (
60.2479 - if exists_gcd(x,xs) then new_factors (y::xs @ [x])
60.2480 - else x::new_factors(y::xs)
60.2481 - )
60.2482 - else gcd::new_factors(kill_equal(list_div(x::y::xs,gcd)))
60.2483 - end
60.2484 - )
60.2485 - else
60.2486 - if len=1 then [hd(l)]
60.2487 - else []
60.2488 - end;
60.2489 -
60.2490 -(*. gets the factors of a list .*)
60.2491 -fun get_factors x = new_factors x;
60.2492 -
60.2493 -(*. multiplies the elements of the list .*)
60.2494 -fun multi_list [] = []
60.2495 - | multi_list (x::xs) = if xs=[] then x
60.2496 - else mv_mul(x,multi_list xs,LEX_);
60.2497 -
60.2498 -(*. makes a term out of the elements of the list (polynomial representation) .*)
60.2499 -fun make_term ([],vars) = Free(str_of_int 0,HOLogic.realT)
60.2500 - | make_term ((x::xs),vars) = if length(xs)=0 then poly2term(sort (mv_geq LEX_) (x),vars)
60.2501 - else
60.2502 - (
60.2503 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2504 - poly2term(sort (mv_geq LEX_) (x),vars) $
60.2505 - make_term(xs,vars)
60.2506 - );
60.2507 -
60.2508 -(*. factorizes the denominator (polynomial representation) .*)
60.2509 -fun factorize_den (l,den,vars) =
60.2510 - let
60.2511 - val factor_list=kill_equal( (get_factors l));
60.2512 - val mlist=multi_list(factor_list);
60.2513 - val (last,rest)=mv_division(den,multi_list(factor_list),LEX_);
60.2514 - in
60.2515 - if rest=[] then
60.2516 - (
60.2517 - if last=[(1,mv_null2(vars))] then make_term(factor_list,vars)
60.2518 - else make_term(last::factor_list,vars)
60.2519 - )
60.2520 - else raise error ("RATIONALS_FACTORIZE_DEN_EXCEPTION: Invalid factor by division")
60.2521 - end;
60.2522 -
60.2523 -(*. makes a term out of the elements of the list (expanded polynomial representation) .*)
60.2524 -fun make_exp ([],vars) = Free(str_of_int 0,HOLogic.realT)
60.2525 - | make_exp ((x::xs),vars) = if length(xs)=0 then poly2expanded(sort (mv_geq LEX_) (x),vars)
60.2526 - else
60.2527 - (
60.2528 - Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2529 - poly2expanded(sort (mv_geq LEX_) (x),vars) $
60.2530 - make_exp(xs,vars)
60.2531 - );
60.2532 -
60.2533 -(*. factorizes the denominator (expanded polynomial representation) .*)
60.2534 -fun factorize_den_exp (l,den,vars) =
60.2535 - let
60.2536 - val factor_list=kill_equal( (get_factors l));
60.2537 - val mlist=multi_list(factor_list);
60.2538 - val (last,rest)=mv_division(den,multi_list(factor_list),LEX_);
60.2539 - in
60.2540 - if rest=[] then
60.2541 - (
60.2542 - if last=[(1,mv_null2(vars))] then make_exp(factor_list,vars)
60.2543 - else make_exp(last::factor_list,vars)
60.2544 - )
60.2545 - else raise error ("RATIONALS_FACTORIZE_DEN_EXP_EXCEPTION: Invalid factor by division")
60.2546 - end;
60.2547 -
60.2548 -(*. calculates the common denominator of all elements of the list and multiplies .*)
60.2549 -(*. the nominators and denominators with the correct factor .*)
60.2550 -(*. (polynomial representation) .*)
60.2551 -fun step_add_list_of_fractions []=(Free("0",HOLogic.realT),[]:term list)
60.2552 - | step_add_list_of_fractions [x]= raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXCEPTION: Nothing to add")
60.2553 - | step_add_list_of_fractions (xs) =
60.2554 - let
60.2555 - val den_list=termlist2denominators (xs); (* list of denominators *)
60.2556 - val (denom,var)=calc_lcm(den_list); (* common denominator *)
60.2557 - val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
60.2558 - in
60.2559 - com_den(xs,denom,den,var)
60.2560 - end;
60.2561 -
60.2562 -(*. calculates the common denominator of all elements of the list and multiplies .*)
60.2563 -(*. the nominators and denominators with the correct factor .*)
60.2564 -(*. (expanded polynomial representation) .*)
60.2565 -fun step_add_list_of_fractions_exp [] = (Free("0",HOLogic.realT),[]:term list)
60.2566 - | step_add_list_of_fractions_exp [x] = raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXP_EXCEPTION: Nothing to add")
60.2567 - | step_add_list_of_fractions_exp (xs)=
60.2568 - let
60.2569 - val den_list=termlist2denominators_exp (xs); (* list of denominators *)
60.2570 - val (denom,var)=calc_lcm(den_list); (* common denominator *)
60.2571 - val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
60.2572 - in
60.2573 - com_den_exp(xs,denom,den,var)
60.2574 - end;
60.2575 -
60.2576 -(* wird aktuell nicht mehr gebraucht, bei rückänderung schon
60.2577 --------------------------------------------------------------
60.2578 -(* WN0210???SK brauch ma des überhaupt *)
60.2579 -fun step_add_list_of_fractions2 []=(Free("0",HOLogic.realT),[]:term list)
60.2580 - | step_add_list_of_fractions2 [x]=(x,[])
60.2581 - | step_add_list_of_fractions2 (xs) =
60.2582 - let
60.2583 - val den_list=termlist2denominators (xs); (* list of denominators *)
60.2584 - val (denom,var)=calc_lcm(den_list); (* common denominator *)
60.2585 - val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
60.2586 - in
60.2587 - (
60.2588 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2589 - com_den2(xs,denom, poly2term(denom,var)(*den*),var) $
60.2590 - poly2term(denom,var)
60.2591 - ,
60.2592 - []
60.2593 - )
60.2594 - end;
60.2595 -
60.2596 -(* WN0210???SK brauch ma des überhaupt *)
60.2597 -fun step_add_list_of_fractions2_exp []=(Free("0",HOLogic.realT),[]:term list)
60.2598 - | step_add_list_of_fractions2_exp [x]=(x,[])
60.2599 - | step_add_list_of_fractions2_exp (xs) =
60.2600 - let
60.2601 - val den_list=termlist2denominators_exp (xs); (* list of denominators *)
60.2602 - val (denom,var)=calc_lcm(den_list); (* common denominator *)
60.2603 - val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
60.2604 - in
60.2605 - (
60.2606 - Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2607 - com_den_exp2(xs,denom, poly2term(denom,var)(*den*),var) $
60.2608 - poly2expanded(denom,var)
60.2609 - ,
60.2610 - []
60.2611 - )
60.2612 - end;
60.2613 ----------------------------------------------- *)
60.2614 -
60.2615 -
60.2616 -(*. converts a term, which contains severel terms seperated by +, into a list of these terms .*)
60.2617 -fun term2list (t as (Const("HOL.divide",_) $ _ $ _)) = [t]
60.2618 - | term2list (t as (Const("Atools.pow",_) $ _ $ _)) =
60.2619 - [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2620 - t $ Free("1",HOLogic.realT)
60.2621 - ]
60.2622 - | term2list (t as (Free(_,_))) =
60.2623 - [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2624 - t $ Free("1",HOLogic.realT)
60.2625 - ]
60.2626 - | term2list (t as (Const("op *",_) $ _ $ _)) =
60.2627 - [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
60.2628 - t $ Free("1",HOLogic.realT)
60.2629 - ]
60.2630 - | term2list (Const("op +",_) $ t1 $ t2) = term2list(t1) @ term2list(t2)
60.2631 - | term2list (Const("op -",_) $ t1 $ t2) =
60.2632 - raise error ("RATIONALS_TERM2LIST_EXCEPTION: - not implemented yet")
60.2633 - | term2list _ = raise error ("RATIONALS_TERM2LIST_EXCEPTION: invalid term");
60.2634 -
60.2635 -(*.factors out the gcd of nominator and denominator:
60.2636 - a/b = (a' * gcd)/(b' * gcd), a,b,gcd are poly[2].*)
60.2637 -fun factout_p_ (thy:theory) t = SOME (step_cancel t,[]:term list);
60.2638 -fun factout_ (thy:theory) t = SOME (step_cancel_expanded t,[]:term list);
60.2639 -
60.2640 -(*.cancels a single fraction with normalform [2]
60.2641 - resulting in a canceled fraction [2], see factout_ .*)
60.2642 -fun cancel_p_ (thy:theory) t = (*WN.2.6.03 no rewrite -> NONE !*)
60.2643 - (let val (t',asm) = direct_cancel(*_expanded ... corrected MG.21.8.03*) t
60.2644 - in if t = t' then NONE else SOME (t',asm)
60.2645 - end) handle _ => NONE;
60.2646 -(*.the same as above with normalform [3]
60.2647 - val cancel_ :
60.2648 - theory -> (*10.02 unused *)
60.2649 - term -> (*fraction in normalform [3] *)
60.2650 - (term * (*fraction in normalform [3] *)
60.2651 - term list) (*casual asumptions in normalform [3] *)
60.2652 - option (*NONE: the function is not applicable *).*)
60.2653 -fun cancel_ (thy:theory) t = SOME (direct_cancel_expanded t) handle _ => NONE;
60.2654 -
60.2655 -(*.transforms sums of at least 2 fractions [3] to
60.2656 - sums with the least common multiple as nominator.*)
60.2657 -fun common_nominator_p_ (thy:theory) t =
60.2658 -((*writeln("### common_nominator_p_ called");*)
60.2659 - SOME (step_add_list_of_fractions(term2list(t))) handle _ => NONE
60.2660 -);
60.2661 -fun common_nominator_ (thy:theory) t =
60.2662 - SOME (step_add_list_of_fractions_exp(term2list(t))) handle _ => NONE;
60.2663 -
60.2664 -(*.add 2 or more fractions
60.2665 -val add_fraction_p_ :
60.2666 - theory -> (*10.02 unused *)
60.2667 - term -> (*2 or more fractions with normalform [2] *)
60.2668 - (term * (*one fraction with normalform [2] *)
60.2669 - term list) (*casual assumptions in normalform [2] WN0210???SK *)
60.2670 - option (*NONE: the function is not applicable *).*)
60.2671 -fun add_fraction_p_ (thy:theory) t =
60.2672 -(writeln("### add_fraction_p_ called");
60.2673 - (let val ts = term2list t
60.2674 - in if 1 < length ts
60.2675 - then SOME (add_list_of_fractions ts)
60.2676 - else NONE (*raise error ("RATIONALS_ADD_EXCEPTION: nothing to add")*)
60.2677 - end) handle _ => NONE
60.2678 -);
60.2679 -(*.same as add_fraction_p_ but with normalform [3].*)
60.2680 -(*SOME (step_add_list_of_fractions2(term2list(t))); *)
60.2681 -fun add_fraction_ (thy:theory) t =
60.2682 - if length(term2list(t))>1
60.2683 - then SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE
60.2684 - else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*)
60.2685 - NONE;
60.2686 -fun add_fraction_ (thy:theory) t =
60.2687 - (if 1 < length (term2list t)
60.2688 - then SOME (add_list_of_fractions_exp (term2list t))
60.2689 - else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*)
60.2690 - NONE) handle _ => NONE;
60.2691 -
60.2692 -(*SOME (step_add_list_of_fractions2_exp(term2list(t))); *)
60.2693 -
60.2694 -(*. brings the term into a normal form .*)
60.2695 -fun norm_rational_ (thy:theory) t =
60.2696 - SOME (add_list_of_fractions(term2list(t))) handle _ => NONE;
60.2697 -fun norm_expanded_rat_ (thy:theory) t =
60.2698 - SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE;
60.2699 -
60.2700 -
60.2701 -(*.evaluates conditions in calculate_Rational.*)
60.2702 -(*make local with FIXX@ME result:term *term list*)
60.2703 -val calc_rat_erls = prep_rls(
60.2704 - Rls {id = "calc_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.2705 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [], *)
60.2706 - rules =
60.2707 - [Calc ("op =",eval_equal "#equal_"),
60.2708 - Calc ("Atools.is'_const",eval_const "#is_const_"),
60.2709 - Thm ("not_true",num_str not_true),
60.2710 - Thm ("not_false",num_str not_false)
60.2711 - ],
60.2712 - scr = EmptyScr});
60.2713 -
60.2714 -
60.2715 -(*.simplifies expressions with numerals;
60.2716 - does NOT rearrange the term by AC-rewriting; thus terms with variables
60.2717 - need to have constants to be commuted together respectively.*)
60.2718 -val calculate_Rational = prep_rls(
60.2719 - merge_rls "calculate_Rational"
60.2720 - (Rls {id = "divide", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.2721 - erls = calc_rat_erls, srls = Erls, (*asm_thm = [],*)
60.2722 - calc = [],
60.2723 - rules =
60.2724 - [Calc ("HOL.divide" ,eval_cancel "#divide_"),
60.2725 -
60.2726 - Thm ("sym_real_minus_divide_eq",
60.2727 - num_str (real_minus_divide_eq RS sym)),
60.2728 - (*SYM - ?x / ?y = - (?x / ?y) may come from subst*)
60.2729 -
60.2730 - Thm ("rat_add",num_str rat_add),
60.2731 - (*"[| a is_const; b is_const; c is_const; d is_const |] ==> \
60.2732 - \"a / c + b / d = (a * d) / (c * d) + (b * c ) / (d * c)"*)
60.2733 - Thm ("rat_add1",num_str rat_add1),
60.2734 - (*"[| a is_const; b is_const; c is_const |] ==> \
60.2735 - \"a / c + b / c = (a + b) / c"*)
60.2736 - Thm ("rat_add2",num_str rat_add2),
60.2737 - (*"[| ?a is_const; ?b is_const; ?c is_const |] ==> \
60.2738 - \?a / ?c + ?b = (?a + ?b * ?c) / ?c"*)
60.2739 - Thm ("rat_add3",num_str rat_add3),
60.2740 - (*"[| a is_const; b is_const; c is_const |] ==> \
60.2741 - \"a + b / c = (a * c) / c + b / c"\
60.2742 - \.... is_const to be omitted here FIXME*)
60.2743 -
60.2744 - Thm ("rat_mult",num_str rat_mult),
60.2745 - (*a / b * (c / d) = a * c / (b * d)*)
60.2746 - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
60.2747 - (*?x * (?y / ?z) = ?x * ?y / ?z*)
60.2748 - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
60.2749 - (*?y / ?z * ?x = ?y * ?x / ?z*)
60.2750 -
60.2751 - Thm ("real_divide_divide1",num_str real_divide_divide1),
60.2752 - (*"?y ~= 0 ==> ?u / ?v / (?y / ?z) = ?u / ?v * (?z / ?y)"*)
60.2753 - Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq),
60.2754 - (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
60.2755 -
60.2756 - Thm ("rat_power", num_str rat_power),
60.2757 - (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
60.2758 -
60.2759 - Thm ("mult_cross",num_str mult_cross),
60.2760 - (*"[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)*)
60.2761 - Thm ("mult_cross1",num_str mult_cross1),
60.2762 - (*" b ~= 0 ==> (a / b = c ) = (a = b * c)*)
60.2763 - Thm ("mult_cross2",num_str mult_cross2)
60.2764 - (*" d ~= 0 ==> (a = c / d) = (a * d = c)*)
60.2765 - ], scr = EmptyScr})
60.2766 - calculate_Poly);
60.2767 -
60.2768 -
60.2769 -(*("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))*)
60.2770 -fun eval_is_expanded (thmid:string) _
60.2771 - (t as (Const("Rational.is'_expanded", _) $ arg)) thy =
60.2772 - if is_expanded arg
60.2773 - then SOME (mk_thmid thmid ""
60.2774 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
60.2775 - Trueprop $ (mk_equality (t, HOLogic.true_const)))
60.2776 - else SOME (mk_thmid thmid ""
60.2777 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
60.2778 - Trueprop $ (mk_equality (t, HOLogic.false_const)))
60.2779 - | eval_is_expanded _ _ _ _ = NONE;
60.2780 -
60.2781 -val rational_erls =
60.2782 - merge_rls "rational_erls" calculate_Rational
60.2783 - (append_rls "is_expanded" Atools_erls
60.2784 - [Calc ("Rational.is'_expanded", eval_is_expanded "")
60.2785 - ]);
60.2786 -
60.2787 -
60.2788 -
60.2789 -(*.3 'reverse-rewrite-sets' for symbolic computation on rationals:
60.2790 - =================================================================
60.2791 - A[2] 'cancel_p': .
60.2792 - A[3] 'cancel': .
60.2793 - B[2] 'common_nominator_p': transforms summands in a term [2]
60.2794 - to fractions with the (least) common multiple as nominator.
60.2795 - B[3] 'norm_rational': normalizes arbitrary algebraic terms (without
60.2796 - radicals and transzendental functions) to one canceled fraction,
60.2797 - nominator and denominator in polynomial form.
60.2798 -
60.2799 -In order to meet isac's requirements for interactive and stepwise calculation,
60.2800 -each 'reverse-rewerite-set' consists of an initialization for the interpreter
60.2801 -state and of 4 functions, each of which employs rewriting as much as possible.
60.2802 -The signature of these functions are the same in each 'reverse-rewrite-set'
60.2803 -respectively.*)
60.2804 -
60.2805 -(* ************************************************************************* *)
60.2806 -
60.2807 -
60.2808 -local(*. cancel_p
60.2809 -------------------------
60.2810 -cancels a single fraction consisting of two (uni- or multivariate)
60.2811 -polynomials WN0609???SK[2] into another such a fraction; examples:
60.2812 -
60.2813 - a^2 + -1*b^2 a + b
60.2814 - -------------------- = ---------
60.2815 - a^2 + -2*a*b + b^2 a + -1*b
60.2816 -
60.2817 - a^2 a
60.2818 - --- = ---
60.2819 - a 1
60.2820 -
60.2821 -Remark: the reverse ruleset does _NOT_ work properly with other input !.*)
60.2822 -(*WN020824 wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*)
60.2823 -
60.2824 -val {rules, rew_ord=(_,ro),...} =
60.2825 - rep_rls (assoc_rls "make_polynomial");
60.2826 -(*WN060829 ... make_deriv does not terminate with 1st expl above,
60.2827 - see rational.sml --- investigate rulesets for cancel_p ---*)
60.2828 -val {rules, rew_ord=(_,ro),...} =
60.2829 - rep_rls (assoc_rls "rev_rew_p");
60.2830 -
60.2831 -val thy = Rational.thy;
60.2832 -
60.2833 -(*.init_state = fn : term -> istate
60.2834 -initialzies the state of the script interpreter. The state is:
60.2835 -
60.2836 -type rrlsstate = (*state for reverse rewriting*)
60.2837 - (term * (*the current formula*)
60.2838 - term * (*the final term*)
60.2839 - rule list (*'reverse rule list' (#)*)
60.2840 - list * (*may be serveral, eg. in norm_rational*)
60.2841 - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
60.2842 - (term * (*... rewrite with ...*)
60.2843 - term list)) (*... assumptions*)
60.2844 - list); (*derivation from given term to normalform
60.2845 - in reverse order with sym_thm;
60.2846 - (#) could be extracted from here by (map #1)*).*)
60.2847 -(* val {rules, rew_ord=(_,ro),...} =
60.2848 - rep_rls (assoc_rls "rev_rew_p") (*USE ALWAYS, SEE val cancel_p*);
60.2849 - val (thy, eval_rls, ro) =(Rational.thy, Atools_erls, ro) (*..val cancel_p*);
60.2850 - val t = t;
60.2851 - *)
60.2852 -fun init_state thy eval_rls ro t =
60.2853 - let val SOME (t',_) = factout_p_ thy t
60.2854 - val SOME (t'',asm) = cancel_p_ thy t
60.2855 - val der = reverse_deriv thy eval_rls rules ro NONE t'
60.2856 - val der = der @ [(Thm ("real_mult_div_cancel2",
60.2857 - num_str real_mult_div_cancel2),
60.2858 - (t'',asm))]
60.2859 - val rs = (distinct_Thm o (map #1)) der
60.2860 - val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
60.2861 - "sym_real_mult_0",
60.2862 - "sym_real_mult_1"
60.2863 - (*..insufficient,eg.make_Polynomial*)])rs
60.2864 - in (t,t'',[rs(*here only _ONE_ to ease locate_rule*)],der) end;
60.2865 -
60.2866 -(*.locate_rule = fn : rule list -> term -> rule
60.2867 - -> (rule * (term * term list) option) list.
60.2868 - checks a rule R for being a cancel-rule, and if it is,
60.2869 - then return the list of rules (+ the terms they are rewriting to)
60.2870 - which need to be applied before R should be applied.
60.2871 - precondition: the rule is applicable to the argument-term.
60.2872 -arguments:
60.2873 - rule list: the reverse rule list
60.2874 - -> term : ... to which the rule shall be applied
60.2875 - -> rule : ... to be applied to term
60.2876 -value:
60.2877 - -> (rule : a rule rewriting to ...
60.2878 - * (term : ... the resulting term ...
60.2879 - * term list): ... with the assumptions ( //#0).
60.2880 - ) list : there may be several such rules;
60.2881 - the list is empty, if the rule has nothing to do
60.2882 - with cancelation.*)
60.2883 -(* val () = ();
60.2884 - *)
60.2885 -fun locate_rule thy eval_rls ro [rs] t r =
60.2886 - if (id_of_thm r) mem (map (id_of_thm)) rs
60.2887 - then let val ropt =
60.2888 - rewrite_ thy ro eval_rls true (thm_of_thm r) t;
60.2889 - in case ropt of
60.2890 - SOME ta => [(r, ta)]
60.2891 - | NONE => (writeln("### locate_rule: rewrite "^
60.2892 - (id_of_thm r)^" "^(term2str t)^" = NONE");
60.2893 - []) end
60.2894 - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
60.2895 - | locate_rule _ _ _ _ _ _ =
60.2896 - raise error ("locate_rule: doesnt match rev-sets in istate");
60.2897 -
60.2898 -(*.next_rule = fn : rule list -> term -> rule option
60.2899 - for a given term return the next rules to be done for cancelling.
60.2900 -arguments:
60.2901 - rule list : the reverse rule list
60.2902 - term : the term for which ...
60.2903 -value:
60.2904 - -> rule option: ... this rule is appropriate for cancellation;
60.2905 - there may be no such rule (if the term is canceled already.*)
60.2906 -(* val thy = Rational.thy;
60.2907 - val Rrls {rew_ord=(_,ro),...} = cancel;
60.2908 - val ([rs],t) = (rss,f);
60.2909 - next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
60.2910 -
60.2911 - val (thy, [rs]) = (Rational.thy, revsets);
60.2912 - val Rrls {rew_ord=(_,ro),...} = cancel;
60.2913 - nex [rs] t;
60.2914 - *)
60.2915 -fun next_rule thy eval_rls ro [rs] t =
60.2916 - let val der = make_deriv thy eval_rls rs ro NONE t;
60.2917 - in case der of
60.2918 -(* val (_,r,_)::_ = der;
60.2919 - *)
60.2920 - (_,r,_)::_ => SOME r
60.2921 - | _ => NONE
60.2922 - end
60.2923 - | next_rule _ _ _ _ _ =
60.2924 - raise error ("next_rule: doesnt match rev-sets in istate");
60.2925 -
60.2926 -(*.val attach_form = f : rule list -> term -> term
60.2927 - -> (rule * (term * term list)) list
60.2928 - checks an input term TI, if it may belong to a current cancellation, by
60.2929 - trying to derive it from the given term TG.
60.2930 -arguments:
60.2931 - term : TG, the last one in the cancellation agreed upon by user + math-eng
60.2932 - -> term: TI, the next one input by the user
60.2933 -value:
60.2934 - -> (rule : the rule to be applied in order to reach TI
60.2935 - * (term : ... obtained by applying the rule ...
60.2936 - * term list): ... and the respective assumptions.
60.2937 - ) list : there may be several such rules;
60.2938 - the list is empty, if the users term does not belong
60.2939 - to a cancellation of the term last agreed upon.*)
60.2940 -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
60.2941 - []:(rule * (term * term list)) list;
60.2942 -
60.2943 -in
60.2944 -
60.2945 -val cancel_p =
60.2946 - Rrls {id = "cancel_p", prepat=[],
60.2947 - rew_ord=("ord_make_polynomial",
60.2948 - ord_make_polynomial false Rational.thy),
60.2949 - erls = rational_erls,
60.2950 - calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
60.2951 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
60.2952 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
60.2953 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
60.2954 - (*asm_thm=[("real_mult_div_cancel2","")],*)
60.2955 - scr=Rfuns {init_state = init_state thy Atools_erls ro,
60.2956 - normal_form = cancel_p_ thy,
60.2957 - locate_rule = locate_rule thy Atools_erls ro,
60.2958 - next_rule = next_rule thy Atools_erls ro,
60.2959 - attach_form = attach_form}}
60.2960 -end;(*local*)
60.2961 -
60.2962 -
60.2963 -local(*.ad (1) 'cancel'
60.2964 -------------------------------
60.2965 -cancels a single fraction consisting of two (uni- or multivariate)
60.2966 -polynomials WN0609???SK[3] into another such a fraction; examples:
60.2967 -
60.2968 - a^2 - b^2 a + b
60.2969 - -------------------- = ---------
60.2970 - a^2 - 2*a*b + b^2 a - *b
60.2971 -
60.2972 -Remark: the reverse ruleset does _NOT_ work properly with other input !.*)
60.2973 -(*WN 24.8.02: wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*)
60.2974 -
60.2975 -(*
60.2976 -val SOME (Rls {rules=rules,rew_ord=(_,ro),...}) =
60.2977 - assoc'(!ruleset',"expand_binoms");
60.2978 -*)
60.2979 -val {rules=rules,rew_ord=(_,ro),...} =
60.2980 - rep_rls (assoc_rls "expand_binoms");
60.2981 -val thy = Rational.thy;
60.2982 -
60.2983 -fun init_state thy eval_rls ro t =
60.2984 - let val SOME (t',_) = factout_ thy t;
60.2985 - val SOME (t'',asm) = cancel_ thy t;
60.2986 - val der = reverse_deriv thy eval_rls rules ro NONE t';
60.2987 - val der = der @ [(Thm ("real_mult_div_cancel2",
60.2988 - num_str real_mult_div_cancel2),
60.2989 - (t'',asm))]
60.2990 - val rs = map #1 der;
60.2991 - in (t,t'',[rs],der) end;
60.2992 -
60.2993 -fun locate_rule thy eval_rls ro [rs] t r =
60.2994 - if (id_of_thm r) mem (map (id_of_thm)) rs
60.2995 - then let val ropt =
60.2996 - rewrite_ thy ro eval_rls true (thm_of_thm r) t;
60.2997 - in case ropt of
60.2998 - SOME ta => [(r, ta)]
60.2999 - | NONE => (writeln("### locate_rule: rewrite "^
60.3000 - (id_of_thm r)^" "^(term2str t)^" = NONE");
60.3001 - []) end
60.3002 - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
60.3003 - | locate_rule _ _ _ _ _ _ =
60.3004 - raise error ("locate_rule: doesnt match rev-sets in istate");
60.3005 -
60.3006 -fun next_rule thy eval_rls ro [rs] t =
60.3007 - let val der = make_deriv thy eval_rls rs ro NONE t;
60.3008 - in case der of
60.3009 -(* val (_,r,_)::_ = der;
60.3010 - *)
60.3011 - (_,r,_)::_ => SOME r
60.3012 - | _ => NONE
60.3013 - end
60.3014 - | next_rule _ _ _ _ _ =
60.3015 - raise error ("next_rule: doesnt match rev-sets in istate");
60.3016 -
60.3017 -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
60.3018 - []:(rule * (term * term list)) list;
60.3019 -
60.3020 -val pat = (term_of o the o (parse thy)) "?r/?s";
60.3021 -val pre1 = (term_of o the o (parse thy)) "?r is_expanded";
60.3022 -val pre2 = (term_of o the o (parse thy)) "?s is_expanded";
60.3023 -val prepat = [([pre1, pre2], pat)];
60.3024 -
60.3025 -in
60.3026 -
60.3027 -
60.3028 -val cancel =
60.3029 - Rrls {id = "cancel", prepat=prepat,
60.3030 - rew_ord=("ord_make_polynomial",
60.3031 - ord_make_polynomial false Rational.thy),
60.3032 - erls = rational_erls,
60.3033 - calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
60.3034 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
60.3035 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
60.3036 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
60.3037 - scr=Rfuns {init_state = init_state thy Atools_erls ro,
60.3038 - normal_form = cancel_ thy,
60.3039 - locate_rule = locate_rule thy Atools_erls ro,
60.3040 - next_rule = next_rule thy Atools_erls ro,
60.3041 - attach_form = attach_form}}
60.3042 -end;(*local*)
60.3043 -
60.3044 -
60.3045 -
60.3046 -local(*.ad [2] 'common_nominator_p'
60.3047 ----------------------------------
60.3048 -FIXME Beschreibung .*)
60.3049 -
60.3050 -
60.3051 -val {rules=rules,rew_ord=(_,ro),...} =
60.3052 - rep_rls (assoc_rls "make_polynomial");
60.3053 -(*WN060829 ... make_deriv does not terminate with 1st expl above,
60.3054 - see rational.sml --- investigate rulesets for cancel_p ---*)
60.3055 -val {rules, rew_ord=(_,ro),...} =
60.3056 - rep_rls (assoc_rls "rev_rew_p");
60.3057 -val thy = Rational.thy;
60.3058 -
60.3059 -
60.3060 -(*.common_nominator_p_ = fn : theory -> term -> (term * term list) option
60.3061 - as defined above*)
60.3062 -
60.3063 -(*.init_state = fn : term -> istate
60.3064 -initialzies the state of the interactive interpreter. The state is:
60.3065 -
60.3066 -type rrlsstate = (*state for reverse rewriting*)
60.3067 - (term * (*the current formula*)
60.3068 - term * (*the final term*)
60.3069 - rule list (*'reverse rule list' (#)*)
60.3070 - list * (*may be serveral, eg. in norm_rational*)
60.3071 - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
60.3072 - (term * (*... rewrite with ...*)
60.3073 - term list)) (*... assumptions*)
60.3074 - list); (*derivation from given term to normalform
60.3075 - in reverse order with sym_thm;
60.3076 - (#) could be extracted from here by (map #1)*).*)
60.3077 -fun init_state thy eval_rls ro t =
60.3078 - let val SOME (t',_) = common_nominator_p_ thy t;
60.3079 - val SOME (t'',asm) = add_fraction_p_ thy t;
60.3080 - val der = reverse_deriv thy eval_rls rules ro NONE t';
60.3081 - val der = der @ [(Thm ("real_mult_div_cancel2",
60.3082 - num_str real_mult_div_cancel2),
60.3083 - (t'',asm))]
60.3084 - val rs = (distinct_Thm o (map #1)) der;
60.3085 - val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
60.3086 - "sym_real_mult_0",
60.3087 - "sym_real_mult_1"]) rs;
60.3088 - in (t,t'',[rs(*here only _ONE_*)],der) end;
60.3089 -
60.3090 -(* use"knowledge/Rational.ML";
60.3091 - *)
60.3092 -
60.3093 -(*.locate_rule = fn : rule list -> term -> rule
60.3094 - -> (rule * (term * term list) option) list.
60.3095 - checks a rule R for being a cancel-rule, and if it is,
60.3096 - then return the list of rules (+ the terms they are rewriting to)
60.3097 - which need to be applied before R should be applied.
60.3098 - precondition: the rule is applicable to the argument-term.
60.3099 -arguments:
60.3100 - rule list: the reverse rule list
60.3101 - -> term : ... to which the rule shall be applied
60.3102 - -> rule : ... to be applied to term
60.3103 -value:
60.3104 - -> (rule : a rule rewriting to ...
60.3105 - * (term : ... the resulting term ...
60.3106 - * term list): ... with the assumptions ( //#0).
60.3107 - ) list : there may be several such rules;
60.3108 - the list is empty, if the rule has nothing to do
60.3109 - with cancelation.*)
60.3110 -(* val () = ();
60.3111 - *)
60.3112 -fun locate_rule thy eval_rls ro [rs] t r =
60.3113 - if (id_of_thm r) mem (map (id_of_thm)) rs
60.3114 - then let val ropt =
60.3115 - rewrite_ thy ro eval_rls true (thm_of_thm r) t;
60.3116 - in case ropt of
60.3117 - SOME ta => [(r, ta)]
60.3118 - | NONE => (writeln("### locate_rule: rewrite "^
60.3119 - (id_of_thm r)^" "^(term2str t)^" = NONE");
60.3120 - []) end
60.3121 - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
60.3122 - | locate_rule _ _ _ _ _ _ =
60.3123 - raise error ("locate_rule: doesnt match rev-sets in istate");
60.3124 -
60.3125 -(*.next_rule = fn : rule list -> term -> rule option
60.3126 - for a given term return the next rules to be done for cancelling.
60.3127 -arguments:
60.3128 - rule list : the reverse rule list
60.3129 - term : the term for which ...
60.3130 -value:
60.3131 - -> rule option: ... this rule is appropriate for cancellation;
60.3132 - there may be no such rule (if the term is canceled already.*)
60.3133 -(* val thy = Rational.thy;
60.3134 - val Rrls {rew_ord=(_,ro),...} = cancel;
60.3135 - val ([rs],t) = (rss,f);
60.3136 - next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
60.3137 -
60.3138 - val (thy, [rs]) = (Rational.thy, revsets);
60.3139 - val Rrls {rew_ord=(_,ro),...} = cancel;
60.3140 - nex [rs] t;
60.3141 - *)
60.3142 -fun next_rule thy eval_rls ro [rs] t =
60.3143 - let val der = make_deriv thy eval_rls rs ro NONE t;
60.3144 - in case der of
60.3145 -(* val (_,r,_)::_ = der;
60.3146 - *)
60.3147 - (_,r,_)::_ => SOME r
60.3148 - | _ => NONE
60.3149 - end
60.3150 - | next_rule _ _ _ _ _ =
60.3151 - raise error ("next_rule: doesnt match rev-sets in istate");
60.3152 -
60.3153 -(*.val attach_form = f : rule list -> term -> term
60.3154 - -> (rule * (term * term list)) list
60.3155 - checks an input term TI, if it may belong to a current cancellation, by
60.3156 - trying to derive it from the given term TG.
60.3157 -arguments:
60.3158 - term : TG, the last one in the cancellation agreed upon by user + math-eng
60.3159 - -> term: TI, the next one input by the user
60.3160 -value:
60.3161 - -> (rule : the rule to be applied in order to reach TI
60.3162 - * (term : ... obtained by applying the rule ...
60.3163 - * term list): ... and the respective assumptions.
60.3164 - ) list : there may be several such rules;
60.3165 - the list is empty, if the users term does not belong
60.3166 - to a cancellation of the term last agreed upon.*)
60.3167 -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
60.3168 - []:(rule * (term * term list)) list;
60.3169 -
60.3170 -val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v";
60.3171 -val pat1 = (term_of o the o (parse thy)) "?r/?s+?u ";
60.3172 -val pat2 = (term_of o the o (parse thy)) "?r +?u/?v";
60.3173 -val prepat = [([HOLogic.true_const], pat0),
60.3174 - ([HOLogic.true_const], pat1),
60.3175 - ([HOLogic.true_const], pat2)];
60.3176 -
60.3177 -in
60.3178 -
60.3179 -(*11.02 schnelle L"osung f"ur RL: Bruch auch gek"urzt;
60.3180 - besser w"are: auf 1 gemeinsamen Bruchstrich, Nenner und Z"ahler unvereinfacht
60.3181 - dh. wie common_nominator_p_, aber auf 1 Bruchstrich*)
60.3182 -val common_nominator_p =
60.3183 - Rrls {id = "common_nominator_p", prepat=prepat,
60.3184 - rew_ord=("ord_make_polynomial",
60.3185 - ord_make_polynomial false Rational.thy),
60.3186 - erls = rational_erls,
60.3187 - calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
60.3188 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
60.3189 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
60.3190 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
60.3191 - scr=Rfuns {init_state = init_state thy Atools_erls ro,
60.3192 - normal_form = add_fraction_p_ thy,(*FIXME.WN0211*)
60.3193 - locate_rule = locate_rule thy Atools_erls ro,
60.3194 - next_rule = next_rule thy Atools_erls ro,
60.3195 - attach_form = attach_form}}
60.3196 -end;(*local*)
60.3197 -
60.3198 -
60.3199 -local(*.ad [2] 'common_nominator'
60.3200 ----------------------------------
60.3201 -FIXME Beschreibung .*)
60.3202 -
60.3203 -
60.3204 -val {rules=rules,rew_ord=(_,ro),...} =
60.3205 - rep_rls (assoc_rls "make_polynomial");
60.3206 -val thy = Rational.thy;
60.3207 -
60.3208 -
60.3209 -(*.common_nominator_ = fn : theory -> term -> (term * term list) option
60.3210 - as defined above*)
60.3211 -
60.3212 -(*.init_state = fn : term -> istate
60.3213 -initialzies the state of the interactive interpreter. The state is:
60.3214 -
60.3215 -type rrlsstate = (*state for reverse rewriting*)
60.3216 - (term * (*the current formula*)
60.3217 - term * (*the final term*)
60.3218 - rule list (*'reverse rule list' (#)*)
60.3219 - list * (*may be serveral, eg. in norm_rational*)
60.3220 - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
60.3221 - (term * (*... rewrite with ...*)
60.3222 - term list)) (*... assumptions*)
60.3223 - list); (*derivation from given term to normalform
60.3224 - in reverse order with sym_thm;
60.3225 - (#) could be extracted from here by (map #1)*).*)
60.3226 -fun init_state thy eval_rls ro t =
60.3227 - let val SOME (t',_) = common_nominator_ thy t;
60.3228 - val SOME (t'',asm) = add_fraction_ thy t;
60.3229 - val der = reverse_deriv thy eval_rls rules ro NONE t';
60.3230 - val der = der @ [(Thm ("real_mult_div_cancel2",
60.3231 - num_str real_mult_div_cancel2),
60.3232 - (t'',asm))]
60.3233 - val rs = (distinct_Thm o (map #1)) der;
60.3234 - val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
60.3235 - "sym_real_mult_0",
60.3236 - "sym_real_mult_1"]) rs;
60.3237 - in (t,t'',[rs(*here only _ONE_*)],der) end;
60.3238 -
60.3239 -(* use"knowledge/Rational.ML";
60.3240 - *)
60.3241 -
60.3242 -(*.locate_rule = fn : rule list -> term -> rule
60.3243 - -> (rule * (term * term list) option) list.
60.3244 - checks a rule R for being a cancel-rule, and if it is,
60.3245 - then return the list of rules (+ the terms they are rewriting to)
60.3246 - which need to be applied before R should be applied.
60.3247 - precondition: the rule is applicable to the argument-term.
60.3248 -arguments:
60.3249 - rule list: the reverse rule list
60.3250 - -> term : ... to which the rule shall be applied
60.3251 - -> rule : ... to be applied to term
60.3252 -value:
60.3253 - -> (rule : a rule rewriting to ...
60.3254 - * (term : ... the resulting term ...
60.3255 - * term list): ... with the assumptions ( //#0).
60.3256 - ) list : there may be several such rules;
60.3257 - the list is empty, if the rule has nothing to do
60.3258 - with cancelation.*)
60.3259 -(* val () = ();
60.3260 - *)
60.3261 -fun locate_rule thy eval_rls ro [rs] t r =
60.3262 - if (id_of_thm r) mem (map (id_of_thm)) rs
60.3263 - then let val ropt =
60.3264 - rewrite_ thy ro eval_rls true (thm_of_thm r) t;
60.3265 - in case ropt of
60.3266 - SOME ta => [(r, ta)]
60.3267 - | NONE => (writeln("### locate_rule: rewrite "^
60.3268 - (id_of_thm r)^" "^(term2str t)^" = NONE");
60.3269 - []) end
60.3270 - else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
60.3271 - | locate_rule _ _ _ _ _ _ =
60.3272 - raise error ("locate_rule: doesnt match rev-sets in istate");
60.3273 -
60.3274 -(*.next_rule = fn : rule list -> term -> rule option
60.3275 - for a given term return the next rules to be done for cancelling.
60.3276 -arguments:
60.3277 - rule list : the reverse rule list
60.3278 - term : the term for which ...
60.3279 -value:
60.3280 - -> rule option: ... this rule is appropriate for cancellation;
60.3281 - there may be no such rule (if the term is canceled already.*)
60.3282 -(* val thy = Rational.thy;
60.3283 - val Rrls {rew_ord=(_,ro),...} = cancel;
60.3284 - val ([rs],t) = (rss,f);
60.3285 - next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
60.3286 -
60.3287 - val (thy, [rs]) = (Rational.thy, revsets);
60.3288 - val Rrls {rew_ord=(_,ro),...} = cancel_p;
60.3289 - nex [rs] t;
60.3290 - *)
60.3291 -fun next_rule thy eval_rls ro [rs] t =
60.3292 - let val der = make_deriv thy eval_rls rs ro NONE t;
60.3293 - in case der of
60.3294 -(* val (_,r,_)::_ = der;
60.3295 - *)
60.3296 - (_,r,_)::_ => SOME r
60.3297 - | _ => NONE
60.3298 - end
60.3299 - | next_rule _ _ _ _ _ =
60.3300 - raise error ("next_rule: doesnt match rev-sets in istate");
60.3301 -
60.3302 -(*.val attach_form = f : rule list -> term -> term
60.3303 - -> (rule * (term * term list)) list
60.3304 - checks an input term TI, if it may belong to a current cancellation, by
60.3305 - trying to derive it from the given term TG.
60.3306 -arguments:
60.3307 - term : TG, the last one in the cancellation agreed upon by user + math-eng
60.3308 - -> term: TI, the next one input by the user
60.3309 -value:
60.3310 - -> (rule : the rule to be applied in order to reach TI
60.3311 - * (term : ... obtained by applying the rule ...
60.3312 - * term list): ... and the respective assumptions.
60.3313 - ) list : there may be several such rules;
60.3314 - the list is empty, if the users term does not belong
60.3315 - to a cancellation of the term last agreed upon.*)
60.3316 -fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
60.3317 - []:(rule * (term * term list)) list;
60.3318 -
60.3319 -val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v";
60.3320 -val pat01 = (term_of o the o (parse thy)) "?r/?s-?u/?v";
60.3321 -val pat1 = (term_of o the o (parse thy)) "?r/?s+?u ";
60.3322 -val pat11 = (term_of o the o (parse thy)) "?r/?s-?u ";
60.3323 -val pat2 = (term_of o the o (parse thy)) "?r +?u/?v";
60.3324 -val pat21 = (term_of o the o (parse thy)) "?r -?u/?v";
60.3325 -val prepat = [([HOLogic.true_const], pat0),
60.3326 - ([HOLogic.true_const], pat01),
60.3327 - ([HOLogic.true_const], pat1),
60.3328 - ([HOLogic.true_const], pat11),
60.3329 - ([HOLogic.true_const], pat2),
60.3330 - ([HOLogic.true_const], pat21)];
60.3331 -
60.3332 -
60.3333 -in
60.3334 -
60.3335 -val common_nominator =
60.3336 - Rrls {id = "common_nominator", prepat=prepat,
60.3337 - rew_ord=("ord_make_polynomial",
60.3338 - ord_make_polynomial false Rational.thy),
60.3339 - erls = rational_erls,
60.3340 - calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
60.3341 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
60.3342 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
60.3343 - ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
60.3344 - (*asm_thm=[("real_mult_div_cancel2","")],*)
60.3345 - scr=Rfuns {init_state = init_state thy Atools_erls ro,
60.3346 - normal_form = add_fraction_ (*NOT common_nominator_*) thy,
60.3347 - locate_rule = locate_rule thy Atools_erls ro,
60.3348 - next_rule = next_rule thy Atools_erls ro,
60.3349 - attach_form = attach_form}}
60.3350 -
60.3351 -end;(*local*)
60.3352 -
60.3353 -
60.3354 -(*##*)
60.3355 -end;(*struct*)
60.3356 -
60.3357 -open RationalI;
60.3358 -(*##*)
60.3359 -
60.3360 -(*.the expression contains + - * ^ / only ?.*)
60.3361 -fun is_ratpolyexp (Free _) = true
60.3362 - | is_ratpolyexp (Const ("op +",_) $ Free _ $ Free _) = true
60.3363 - | is_ratpolyexp (Const ("op -",_) $ Free _ $ Free _) = true
60.3364 - | is_ratpolyexp (Const ("op *",_) $ Free _ $ Free _) = true
60.3365 - | is_ratpolyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true
60.3366 - | is_ratpolyexp (Const ("HOL.divide",_) $ Free _ $ Free _) = true
60.3367 - | is_ratpolyexp (Const ("op +",_) $ t1 $ t2) =
60.3368 - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
60.3369 - | is_ratpolyexp (Const ("op -",_) $ t1 $ t2) =
60.3370 - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
60.3371 - | is_ratpolyexp (Const ("op *",_) $ t1 $ t2) =
60.3372 - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
60.3373 - | is_ratpolyexp (Const ("Atools.pow",_) $ t1 $ t2) =
60.3374 - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
60.3375 - | is_ratpolyexp (Const ("HOL.divide",_) $ t1 $ t2) =
60.3376 - ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
60.3377 - | is_ratpolyexp _ = false;
60.3378 -
60.3379 -(*("is_ratpolyexp", ("Rational.is'_ratpolyexp", eval_is_ratpolyexp ""))*)
60.3380 -fun eval_is_ratpolyexp (thmid:string) _
60.3381 - (t as (Const("Rational.is'_ratpolyexp", _) $ arg)) thy =
60.3382 - if is_ratpolyexp arg
60.3383 - then SOME (mk_thmid thmid ""
60.3384 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
60.3385 - Trueprop $ (mk_equality (t, HOLogic.true_const)))
60.3386 - else SOME (mk_thmid thmid ""
60.3387 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
60.3388 - Trueprop $ (mk_equality (t, HOLogic.false_const)))
60.3389 - | eval_is_ratpolyexp _ _ _ _ = NONE;
60.3390 -
60.3391 -
60.3392 -
60.3393 -(*-------------------18.3.03 --> struct <-----------vvv--*)
60.3394 -val add_fractions_p = common_nominator_p; (*FIXXXME:eilig f"ur norm_Rational*)
60.3395 -
60.3396 -(*.discard binary minus, shift unary minus into -1*;
60.3397 - unary minus before numerals are put into the numeral by parsing;
60.3398 - contains absolute minimum of thms for context in norm_Rational .*)
60.3399 -val discard_minus = prep_rls(
60.3400 - Rls {id = "discard_minus", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.3401 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
60.3402 - rules = [Thm ("real_diff_minus", num_str real_diff_minus),
60.3403 - (*"a - b = a + -1 * b"*)
60.3404 - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
60.3405 - (*- ?z = "-1 * ?z"*)
60.3406 - ],
60.3407 - scr = Script ((term_of o the o (parse thy))
60.3408 - "empty_script")
60.3409 - }):rls;
60.3410 -(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*)
60.3411 -val powers_erls = prep_rls(
60.3412 - Rls {id = "powers_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.3413 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
60.3414 - rules = [Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"),
60.3415 - Calc ("Atools.is'_even",eval_is_even "#is_even_"),
60.3416 - Calc ("op <",eval_equ "#less_"),
60.3417 - Thm ("not_false", not_false),
60.3418 - Thm ("not_true", not_true),
60.3419 - Calc ("op +",eval_binop "#add_")
60.3420 - ],
60.3421 - scr = Script ((term_of o the o (parse thy))
60.3422 - "empty_script")
60.3423 - }:rls);
60.3424 -(*.all powers over + distributed; atoms over * collected, other distributed
60.3425 - contains absolute minimum of thms for context in norm_Rational .*)
60.3426 -val powers = prep_rls(
60.3427 - Rls {id = "powers", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.3428 - erls = powers_erls, srls = Erls, calc = [], (*asm_thm = [],*)
60.3429 - rules = [Thm ("realpow_multI", num_str realpow_multI),
60.3430 - (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
60.3431 - Thm ("realpow_pow",num_str realpow_pow),
60.3432 - (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
60.3433 - Thm ("realpow_oneI",num_str realpow_oneI),
60.3434 - (*"r ^^^ 1 = r"*)
60.3435 - Thm ("realpow_minus_even",num_str realpow_minus_even),
60.3436 - (*"n is_even ==> (- r) ^^^ n = r ^^^ n" ?-->discard_minus?*)
60.3437 - Thm ("realpow_minus_odd",num_str realpow_minus_odd),
60.3438 - (*"Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"*)
60.3439 -
60.3440 - (*----- collect atoms over * -----*)
60.3441 - Thm ("realpow_two_atom",num_str realpow_two_atom),
60.3442 - (*"r is_atom ==> r * r = r ^^^ 2"*)
60.3443 - Thm ("realpow_plus_1",num_str realpow_plus_1),
60.3444 - (*"r is_atom ==> r * r ^^^ n = r ^^^ (n + 1)"*)
60.3445 - Thm ("realpow_addI_atom",num_str realpow_addI_atom),
60.3446 - (*"r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
60.3447 -
60.3448 - (*----- distribute none-atoms -----*)
60.3449 - Thm ("realpow_def_atom",num_str realpow_def_atom),
60.3450 - (*"[| 1 < n; not(r is_atom) |]==>r ^^^ n = r * r ^^^ (n + -1)"*)
60.3451 - Thm ("realpow_eq_oneI",num_str realpow_eq_oneI),
60.3452 - (*"1 ^^^ n = 1"*)
60.3453 - Calc ("op +",eval_binop "#add_")
60.3454 - ],
60.3455 - scr = Script ((term_of o the o (parse thy))
60.3456 - "empty_script")
60.3457 - }:rls);
60.3458 -(*.contains absolute minimum of thms for context in norm_Rational.*)
60.3459 -val rat_mult_divide = prep_rls(
60.3460 - Rls {id = "rat_mult_divide", preconds = [],
60.3461 - rew_ord = ("dummy_ord",dummy_ord),
60.3462 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
60.3463 - rules = [Thm ("rat_mult",num_str rat_mult),
60.3464 - (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
60.3465 - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
60.3466 - (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2],
60.3467 - otherwise inv.to a / b / c = ...*)
60.3468 - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
60.3469 - (*"?a / ?b * ?c = ?a * ?c / ?b" order weights x^^^n too much
60.3470 - and does not commute a / b * c ^^^ 2 !*)
60.3471 -
60.3472 - Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
60.3473 - (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
60.3474 - Thm ("real_divide_divide2_eq", real_divide_divide2_eq),
60.3475 - (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
60.3476 - Calc ("HOL.divide" ,eval_cancel "#divide_")
60.3477 - ],
60.3478 - scr = Script ((term_of o the o (parse thy)) "empty_script")
60.3479 - }:rls);
60.3480 -(*.contains absolute minimum of thms for context in norm_Rational.*)
60.3481 -val reduce_0_1_2 = prep_rls(
60.3482 - Rls{id = "reduce_0_1_2", preconds = [], rew_ord = ("dummy_ord", dummy_ord),
60.3483 - erls = e_rls,srls = Erls,calc = [],(*asm_thm = [],*)
60.3484 - rules = [(*Thm ("real_divide_1",num_str real_divide_1),
60.3485 - "?x / 1 = ?x" unnecess.for normalform*)
60.3486 - Thm ("real_mult_1",num_str real_mult_1),
60.3487 - (*"1 * z = z"*)
60.3488 - (*Thm ("real_mult_minus1",num_str real_mult_minus1),
60.3489 - "-1 * z = - z"*)
60.3490 - (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel),
60.3491 - "- ?x * - ?y = ?x * ?y"*)
60.3492 -
60.3493 - Thm ("real_mult_0",num_str real_mult_0),
60.3494 - (*"0 * z = 0"*)
60.3495 - Thm ("real_add_zero_left",num_str real_add_zero_left),
60.3496 - (*"0 + z = z"*)
60.3497 - (*Thm ("real_add_minus",num_str real_add_minus),
60.3498 - "?z + - ?z = 0"*)
60.3499 -
60.3500 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
60.3501 - (*"z1 + z1 = 2 * z1"*)
60.3502 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
60.3503 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
60.3504 -
60.3505 - Thm ("real_0_divide",num_str real_0_divide)
60.3506 - (*"0 / ?x = 0"*)
60.3507 - ], scr = EmptyScr}:rls);
60.3508 -
60.3509 -(*erls for calculate_Rational;
60.3510 - make local with FIXX@ME result:term *term list WN0609???SKMG*)
60.3511 -val norm_rat_erls = prep_rls(
60.3512 - Rls {id = "norm_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.3513 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
60.3514 - rules = [Calc ("Atools.is'_const",eval_const "#is_const_")
60.3515 - ],
60.3516 - scr = Script ((term_of o the o (parse thy))
60.3517 - "empty_script")
60.3518 - }:rls);
60.3519 -(*.consists of rls containing the absolute minimum of thms.*)
60.3520 -(*040209: this version has been used by RL for his equations,
60.3521 -which is now replaced by MGs version below
60.3522 -vvv OLD VERSION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)
60.3523 -val norm_Rational = prep_rls(
60.3524 - Rls {id = "norm_Rational", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
60.3525 - erls = norm_rat_erls, srls = Erls, calc = [], (*asm_thm = [],*)
60.3526 - rules = [(*sequence given by operator precedence*)
60.3527 - Rls_ discard_minus,
60.3528 - Rls_ powers,
60.3529 - Rls_ rat_mult_divide,
60.3530 - Rls_ expand,
60.3531 - Rls_ reduce_0_1_2,
60.3532 - (*^^^^^^^^^ from RL -- not the latest one vvvvvvvvv*)
60.3533 - Rls_ order_add_mult,
60.3534 - Rls_ collect_numerals,
60.3535 - Rls_ add_fractions_p,
60.3536 - Rls_ cancel_p
60.3537 - ],
60.3538 - scr = Script ((term_of o the o (parse thy))
60.3539 - "empty_script")
60.3540 - }:rls);
60.3541 -val norm_Rational_parenthesized = prep_rls(
60.3542 - Seq {id = "norm_Rational_parenthesized", preconds = []:term list,
60.3543 - rew_ord = ("dummy_ord", dummy_ord),
60.3544 - erls = Atools_erls, srls = Erls,
60.3545 - calc = [], (*asm_thm = [],*)
60.3546 - rules = [Rls_ norm_Rational, (*from RL -- not the latest one*)
60.3547 - Rls_ discard_parentheses
60.3548 - ],
60.3549 - scr = EmptyScr
60.3550 - }:rls);
60.3551 -
60.3552 -
60.3553 -(*-------------------18.3.03 --> struct <-----------^^^--*)
60.3554 -
60.3555 -
60.3556 -
60.3557 -theory' := overwritel (!theory', [("Rational.thy",Rational.thy)]);
60.3558 -
60.3559 -
60.3560 -(*WN030318???SK: simplifies all but cancel and common_nominator*)
60.3561 -val simplify_rational =
60.3562 - merge_rls "simplify_rational" expand_binoms
60.3563 - (append_rls "divide" calculate_Rational
60.3564 - [Thm ("real_divide_1",num_str real_divide_1),
60.3565 - (*"?x / 1 = ?x"*)
60.3566 - Thm ("rat_mult",num_str rat_mult),
60.3567 - (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
60.3568 - Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
60.3569 - (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2],
60.3570 - otherwise inv.to a / b / c = ...*)
60.3571 - Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
60.3572 - (*"?a / ?b * ?c = ?a * ?c / ?b"*)
60.3573 - Thm ("add_minus",num_str add_minus),
60.3574 - (*"?a + ?b - ?b = ?a"*)
60.3575 - Thm ("add_minus1",num_str add_minus1),
60.3576 - (*"?a - ?b + ?b = ?a"*)
60.3577 - Thm ("real_divide_minus1",num_str real_divide_minus1)
60.3578 - (*"?x / -1 = - ?x"*)
60.3579 -(*
60.3580 -,
60.3581 - Thm ("",num_str )
60.3582 -*)
60.3583 - ]);
60.3584 -
60.3585 -(*---------vvv-------------MG ab 1.07.2003--------------vvv-----------*)
60.3586 -
60.3587 -(* ------------------------------------------------------------------ *)
60.3588 -(* Simplifier für beliebige Buchterme *)
60.3589 -(* ------------------------------------------------------------------ *)
60.3590 -(*----------------------- norm_Rational_mg ---------------------------*)
60.3591 -(*. description of the simplifier see MG-DA.p.56ff .*)
60.3592 -(* ------------------------------------------------------------------- *)
60.3593 -val common_nominator_p_rls = prep_rls(
60.3594 - Rls {id = "common_nominator_p_rls", preconds = [],
60.3595 - rew_ord = ("dummy_ord",dummy_ord),
60.3596 - erls = e_rls, srls = Erls, calc = [],
60.3597 - rules =
60.3598 - [Rls_ common_nominator_p
60.3599 - (*FIXME.WN0401 ? redesign Rrls - use exhaustively on a term ?
60.3600 - FIXME.WN0510 unnecessary nesting: introduce RRls_ : rls -> rule*)
60.3601 - ],
60.3602 - scr = EmptyScr});
60.3603 -(* ------------------------------------------------------------------- *)
60.3604 -val cancel_p_rls = prep_rls(
60.3605 - Rls {id = "cancel_p_rls", preconds = [],
60.3606 - rew_ord = ("dummy_ord",dummy_ord),
60.3607 - erls = e_rls, srls = Erls, calc = [],
60.3608 - rules =
60.3609 - [Rls_ cancel_p
60.3610 - (*FIXME.WN.0401 ? redesign Rrls - use exhaustively on a term ?*)
60.3611 - ],
60.3612 - scr = EmptyScr});
60.3613 -(* -------------------------------------------------------------------- *)
60.3614 -(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions;
60.3615 - used in initial part norm_Rational_mg, see example DA-M02-main.p.60.*)
60.3616 -val rat_mult_poly = prep_rls(
60.3617 - Rls {id = "rat_mult_poly", preconds = [],
60.3618 - rew_ord = ("dummy_ord",dummy_ord),
60.3619 - erls = append_rls "e_rls-is_polyexp" e_rls
60.3620 - [Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
60.3621 - srls = Erls, calc = [],
60.3622 - rules =
60.3623 - [Thm ("rat_mult_poly_l",num_str rat_mult_poly_l),
60.3624 - (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*)
60.3625 - Thm ("rat_mult_poly_r",num_str rat_mult_poly_r)
60.3626 - (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*)
60.3627 - ],
60.3628 - scr = EmptyScr});
60.3629 -(* ------------------------------------------------------------------ *)
60.3630 -(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions;
60.3631 - used in looping part norm_Rational_rls, see example DA-M02-main.p.60
60.3632 - .. WHERE THE LATTER DOES ALWAYS WORK, BECAUSE erls = e_rls,
60.3633 - I.E. THE RESPECTIVE ASSUMPTION IS STORED AND Thm APPLIED; WN051028
60.3634 - ... WN0609???MG.*)
60.3635 -val rat_mult_div_pow = prep_rls(
60.3636 - Rls {id = "rat_mult_div_pow", preconds = [],
60.3637 - rew_ord = ("dummy_ord",dummy_ord),
60.3638 - erls = e_rls,
60.3639 - (*FIXME.WN051028 append_rls "e_rls-is_polyexp" e_rls
60.3640 - [Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
60.3641 - with this correction ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ we get
60.3642 - error "rational.sml.sml: diff.behav. in norm_Rational_mg 29" etc.
60.3643 - thus we decided to go on with this flaw*)
60.3644 - srls = Erls, calc = [],
60.3645 - rules = [Thm ("rat_mult",num_str rat_mult),
60.3646 - (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
60.3647 - Thm ("rat_mult_poly_l",num_str rat_mult_poly_l),
60.3648 - (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*)
60.3649 - Thm ("rat_mult_poly_r",num_str rat_mult_poly_r),
60.3650 - (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*)
60.3651 -
60.3652 - Thm ("real_divide_divide1_mg", real_divide_divide1_mg),
60.3653 - (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*)
60.3654 - Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
60.3655 - (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
60.3656 - Thm ("real_divide_divide2_eq", real_divide_divide2_eq),
60.3657 - (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
60.3658 - Calc ("HOL.divide" ,eval_cancel "#divide_"),
60.3659 -
60.3660 - Thm ("rat_power", num_str rat_power)
60.3661 - (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
60.3662 - ],
60.3663 - scr = Script ((term_of o the o (parse thy)) "empty_script")
60.3664 - }:rls);
60.3665 -(* ------------------------------------------------------------------ *)
60.3666 -val rat_reduce_1 = prep_rls(
60.3667 - Rls {id = "rat_reduce_1", preconds = [],
60.3668 - rew_ord = ("dummy_ord",dummy_ord),
60.3669 - erls = e_rls, srls = Erls, calc = [],
60.3670 - rules = [Thm ("real_divide_1",num_str real_divide_1),
60.3671 - (*"?x / 1 = ?x"*)
60.3672 - Thm ("real_mult_1",num_str real_mult_1)
60.3673 - (*"1 * z = z"*)
60.3674 - ],
60.3675 - scr = Script ((term_of o the o (parse thy)) "empty_script")
60.3676 - }:rls);
60.3677 -(* ------------------------------------------------------------------ *)
60.3678 -(*. looping part of norm_Rational(*_mg*) .*)
60.3679 -val norm_Rational_rls = prep_rls(
60.3680 - Rls {id = "norm_Rational_rls", preconds = [],
60.3681 - rew_ord = ("dummy_ord",dummy_ord),
60.3682 - erls = norm_rat_erls, srls = Erls, calc = [],
60.3683 - rules = [Rls_ common_nominator_p_rls,
60.3684 - Rls_ rat_mult_div_pow,
60.3685 - Rls_ make_rat_poly_with_parentheses,
60.3686 - Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*)
60.3687 - Rls_ rat_reduce_1
60.3688 - ],
60.3689 - scr = Script ((term_of o the o (parse thy)) "empty_script")
60.3690 - }:rls);
60.3691 -(* ------------------------------------------------------------------ *)
60.3692 -(*040109 'norm_Rational'(by RL) replaced by 'norm_Rational_mg'(MG)
60.3693 - just be renaming:*)
60.3694 -val norm_Rational(*_mg*) = prep_rls(
60.3695 - Seq {id = "norm_Rational"(*_mg*), preconds = [],
60.3696 - rew_ord = ("dummy_ord",dummy_ord),
60.3697 - erls = norm_rat_erls, srls = Erls, calc = [],
60.3698 - rules = [Rls_ discard_minus_,
60.3699 - Rls_ rat_mult_poly,(* removes double fractions like a/b/c *)
60.3700 - Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*)
60.3701 - Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*)
60.3702 - Rls_ norm_Rational_rls, (* the main rls, looping (#) *)
60.3703 - Rls_ discard_parentheses_ (* mult only *)
60.3704 - ],
60.3705 - scr = Script ((term_of o the o (parse thy)) "empty_script")
60.3706 - }:rls);
60.3707 -(* ------------------------------------------------------------------ *)
60.3708 -
60.3709 -
60.3710 -ruleset' := overwritelthy thy (!ruleset',
60.3711 - [("calculate_Rational", calculate_Rational),
60.3712 - ("calc_rat_erls",calc_rat_erls),
60.3713 - ("rational_erls", rational_erls),
60.3714 - ("cancel_p", cancel_p),
60.3715 - ("cancel", cancel),
60.3716 - ("common_nominator_p", common_nominator_p),
60.3717 - ("common_nominator_p_rls", common_nominator_p_rls),
60.3718 - ("common_nominator" , common_nominator),
60.3719 - ("discard_minus", discard_minus),
60.3720 - ("powers_erls", powers_erls),
60.3721 - ("powers", powers),
60.3722 - ("rat_mult_divide", rat_mult_divide),
60.3723 - ("reduce_0_1_2", reduce_0_1_2),
60.3724 - ("rat_reduce_1", rat_reduce_1),
60.3725 - ("norm_rat_erls", norm_rat_erls),
60.3726 - ("norm_Rational", norm_Rational),
60.3727 - ("norm_Rational_rls", norm_Rational_rls),
60.3728 - ("norm_Rational_parenthesized", norm_Rational_parenthesized),
60.3729 - ("rat_mult_poly", rat_mult_poly),
60.3730 - ("rat_mult_div_pow", rat_mult_div_pow),
60.3731 - ("cancel_p_rls", cancel_p_rls)
60.3732 - ]);
60.3733 -
60.3734 -calclist':= overwritel (!calclist',
60.3735 - [("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))
60.3736 - ]);
60.3737 -
60.3738 -(** problems **)
60.3739 -
60.3740 -store_pbt
60.3741 - (prep_pbt Rational.thy "pbl_simp_rat" [] e_pblID
60.3742 - (["rational","simplification"],
60.3743 - [("#Given" ,["term t_"]),
60.3744 - ("#Where" ,["t_ is_ratpolyexp"]),
60.3745 - ("#Find" ,["normalform n_"])
60.3746 - ],
60.3747 - append_rls "e_rls" e_rls [(*for preds in where_*)],
60.3748 - SOME "Simplify t_",
60.3749 - [["simplification","of_rationals"]]));
60.3750 -
60.3751 -(** methods **)
60.3752 -
60.3753 -(*WN061025 this methods script is copied from (auto-generated) script
60.3754 - of norm_Rational in order to ease repair on inform*)
60.3755 -store_met
60.3756 - (prep_met Rational.thy "met_simp_rat" [] e_metID
60.3757 - (["simplification","of_rationals"],
60.3758 - [("#Given" ,["term t_"]),
60.3759 - ("#Where" ,["t_ is_ratpolyexp"]),
60.3760 - ("#Find" ,["normalform n_"])
60.3761 - ],
60.3762 - {rew_ord'="tless_true",
60.3763 - rls' = e_rls,
60.3764 - calc = [], srls = e_rls,
60.3765 - prls = append_rls "simplification_of_rationals_prls" e_rls
60.3766 - [(*for preds in where_*)
60.3767 - Calc ("Rational.is'_ratpolyexp",
60.3768 - eval_is_ratpolyexp "")],
60.3769 - crls = e_rls, nrls = norm_Rational_rls},
60.3770 -"Script SimplifyScript (t_::real) = \
60.3771 -\ ((Try (Rewrite_Set discard_minus_ False) @@ \
60.3772 -\ Try (Rewrite_Set rat_mult_poly False) @@ \
60.3773 -\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@ \
60.3774 -\ Try (Rewrite_Set cancel_p_rls False) @@ \
60.3775 -\ (Repeat \
60.3776 -\ ((Try (Rewrite_Set common_nominator_p_rls False) @@ \
60.3777 -\ Try (Rewrite_Set rat_mult_div_pow False) @@ \
60.3778 -\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@\
60.3779 -\ Try (Rewrite_Set cancel_p_rls False) @@ \
60.3780 -\ Try (Rewrite_Set rat_reduce_1 False)))) @@ \
60.3781 -\ Try (Rewrite_Set discard_parentheses_ False)) \
60.3782 -\ t_)"
60.3783 - ));
60.3784 -
60.3785 -(* use"../IsacKnowledge/Rational.ML";
60.3786 - use"IsacKnowledge/Rational.ML";
60.3787 - use"Rational.ML";
60.3788 - *)
60.3789 -
61.1 --- a/src/Tools/isac/IsacKnowledge/Rational.thy Wed Aug 25 15:15:01 2010 +0200
61.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
61.3 @@ -1,76 +0,0 @@
61.4 -(* rationals, i.e. fractions of multivariate polynomials over the real field
61.5 - author: isac team
61.6 - Copyright (c) isac team 2002
61.7 - Use is subject to license terms.
61.8 -
61.9 - depends on Poly (and not on Atools), because
61.10 - fractions with _normalized_ polynomials are canceled, added, etc.
61.11 -
61.12 - use_thy_only"IsacKnowledge/Rational";
61.13 - use_thy"../IsacKnowledge/Rational";
61.14 - use_thy"IsacKnowledge/Rational";
61.15 -
61.16 - remove_thy"Rational";
61.17 - use_thy"IsacKnowledge/Isac";
61.18 - use_thy_only"IsacKnowledge/Rational";
61.19 -
61.20 -*)
61.21 -
61.22 -Rational = Poly +
61.23 -
61.24 -consts
61.25 -
61.26 - is'_expanded :: "real => bool" ("_ is'_expanded") (*RL->Poly.thy*)
61.27 - is'_ratpolyexp :: "real => bool" ("_ is'_ratpolyexp")
61.28 -
61.29 -rules (*.not contained in Isabelle2002,
61.30 - stated as axioms, TODO: prove as theorems*)
61.31 -
61.32 - mult_cross "[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)"
61.33 - mult_cross1 " b ~= 0 ==> (a / b = c ) = (a = b * c)"
61.34 - mult_cross2 " d ~= 0 ==> (a = c / d) = (a * d = c)"
61.35 -
61.36 - add_minus "a + b - b = a"(*RL->Poly.thy*)
61.37 - add_minus1 "a - b + b = a"(*RL->Poly.thy*)
61.38 -
61.39 - rat_mult "a / b * (c / d) = a * c / (b * d)"(*?Isa02*)
61.40 - rat_mult2 "a / b * c = a * c / b "(*?Isa02*)
61.41 -
61.42 - rat_mult_poly_l "c is_polyexp ==> c * (a / b) = c * a / b"
61.43 - rat_mult_poly_r "c is_polyexp ==> (a / b) * c = a * c / b"
61.44 -
61.45 -(*real_times_divide1_eq .. Isa02*)
61.46 - real_times_divide_1_eq "-1 * (c / d) =-1 * c / d "
61.47 - real_times_divide_num "a is_const ==> \
61.48 - \a * (c / d) = a * c / d "
61.49 -
61.50 - real_mult_div_cancel2 "k ~= 0 ==> m * k / (n * k) = m / n"
61.51 -(*real_mult_div_cancel1 "k ~= 0 ==> k * m / (k * n) = m / n"..Isa02*)
61.52 -
61.53 - real_divide_divide1 "y ~= 0 ==> (u / v) / (y / z) = (u / v) * (z / y)"
61.54 - real_divide_divide1_mg "y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"
61.55 -(*real_divide_divide2_eq "x / y / z = x / (y * z)"..Isa02*)
61.56 -
61.57 - rat_power "(a / b)^^^n = (a^^^n) / (b^^^n)"
61.58 -
61.59 -
61.60 - rat_add "[| a is_const; b is_const; c is_const; d is_const |] ==> \
61.61 - \a / c + b / d = (a * d + b * c) / (c * d)"
61.62 - rat_add_assoc "[| a is_const; b is_const; c is_const; d is_const |] ==> \
61.63 - \a / c +(b / d + e) = (a * d + b * c)/(d * c) + e"
61.64 - rat_add1 "[| a is_const; b is_const; c is_const |] ==> \
61.65 - \a / c + b / c = (a + b) / c"
61.66 - rat_add1_assoc "[| a is_const; b is_const; c is_const |] ==> \
61.67 - \a / c + (b / c + e) = (a + b) / c + e"
61.68 - rat_add2 "[| a is_const; b is_const; c is_const |] ==> \
61.69 - \a / c + b = (a + b * c) / c"
61.70 - rat_add2_assoc "[| a is_const; b is_const; c is_const |] ==> \
61.71 - \a / c + (b + e) = (a + b * c) / c + e"
61.72 - rat_add3 "[| a is_const; b is_const; c is_const |] ==> \
61.73 - \a + b / c = (a * c + b) / c"
61.74 - rat_add3_assoc "[| a is_const; b is_const; c is_const |] ==> \
61.75 - \a + (b / c + e) = (a * c + b) / c + e"
61.76 -
61.77 -
61.78 -
61.79 -end
62.1 --- a/src/Tools/isac/IsacKnowledge/Root.ML Wed Aug 25 15:15:01 2010 +0200
62.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
62.3 @@ -1,299 +0,0 @@
62.4 -(* collecting all knowledge for Root
62.5 - created by:
62.6 - date:
62.7 - changed by: rlang
62.8 - last change by: rlang
62.9 - date: 02.10.24
62.10 -*)
62.11 -
62.12 -(* use"../knowledge/Root.ML";
62.13 - use"IsacKnowledge/Root.ML";
62.14 - use"Root.ML";
62.15 -
62.16 - remove_thy"Root";
62.17 - use_thy"IsacKnowledge/Isac";
62.18 -
62.19 - use"ROOT.ML";
62.20 - cd"knowledge";
62.21 - *)
62.22 -"******* Root.ML begin *******";
62.23 -theory' := overwritel (!theory', [("Root.thy",Root.thy)]);
62.24 -(*-------------------------functions---------------------*)
62.25 -(*evaluation square-root over the integers*)
62.26 -fun eval_sqrt (thmid:string) (op_:string) (t as
62.27 - (Const(op0,t0) $ arg)) thy =
62.28 - (case arg of
62.29 - Free (n1,t1) =>
62.30 - (case int_of_str n1 of
62.31 - SOME ni =>
62.32 - if ni < 0 then NONE
62.33 - else
62.34 - let val fact = squfact ni;
62.35 - in if fact*fact = ni
62.36 - then SOME ("#sqrt #"^(string_of_int ni)^" = #"
62.37 - ^(string_of_int (if ni = 0 then 0
62.38 - else ni div fact)),
62.39 - Trueprop $ mk_equality (t, term_of_num t1 fact))
62.40 - else if fact = 1 then NONE
62.41 - else SOME ("#sqrt #"^(string_of_int ni)^" = sqrt (#"
62.42 - ^(string_of_int fact)^" * #"
62.43 - ^(string_of_int fact)^" * #"
62.44 - ^(string_of_int (ni div (fact*fact))^")"),
62.45 - Trueprop $
62.46 - (mk_equality
62.47 - (t,
62.48 - (mk_factroot op0 t1 fact
62.49 - (ni div (fact*fact))))))
62.50 - end
62.51 - | NONE => NONE)
62.52 - | _ => NONE)
62.53 -
62.54 - | eval_sqrt _ _ _ _ = NONE;
62.55 -(*val (thmid, op_, t as Const(op0,t0) $ arg) = ("","", str2term "sqrt 0");
62.56 -> eval_sqrt thmid op_ t thy;
62.57 -> val Free (n1,t1) = arg;
62.58 -> val SOME ni = int_of_str n1;
62.59 -*)
62.60 -
62.61 -calclist':= overwritel (!calclist',
62.62 - [("SQRT" ,("Root.sqrt" ,eval_sqrt "#sqrt_"))
62.63 - (*different types for 'sqrt 4' --- 'Calculate sqrt_'*)
62.64 - ]);
62.65 -
62.66 -
62.67 -local (* Vers. 7.10.99.A *)
62.68 -
62.69 -open Term; (* for type order = EQUAL | LESS | GREATER *)
62.70 -
62.71 -fun pr_ord EQUAL = "EQUAL"
62.72 - | pr_ord LESS = "LESS"
62.73 - | pr_ord GREATER = "GREATER";
62.74 -
62.75 -fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
62.76 - (case a of "Root.sqrt" => ((("|||", 0), T), 0) (*WN greatest *)
62.77 - | _ => (((a, 0), T), 0))
62.78 - | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
62.79 - | dest_hd' (Var v) = (v, 2)
62.80 - | dest_hd' (Bound i) = ((("", i), dummyT), 3)
62.81 - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
62.82 -fun size_of_term' (Const(str,_) $ t) =
62.83 - (case str of "Root.sqrt" => (1000 + size_of_term' t)
62.84 - | _ => 1 + size_of_term' t)
62.85 - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
62.86 - | size_of_term' (f $ t) = size_of_term' f + size_of_term' t
62.87 - | size_of_term' _ = 1;
62.88 -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
62.89 - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
62.90 - | term_ord' pr thy (t, u) =
62.91 - (if pr then
62.92 - let
62.93 - val (f, ts) = strip_comb t and (g, us) = strip_comb u;
62.94 - val _=writeln("t= f@ts= \""^
62.95 - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
62.96 - (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\"");
62.97 - val _=writeln("u= g@us= \""^
62.98 - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
62.99 - (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\"");
62.100 - val _=writeln("size_of_term(t,u)= ("^
62.101 - (string_of_int(size_of_term' t))^", "^
62.102 - (string_of_int(size_of_term' u))^")");
62.103 - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
62.104 - val _=writeln("terms_ord(ts,us) = "^
62.105 - ((pr_ord o terms_ord str false)(ts,us)));
62.106 - val _=writeln("-------");
62.107 - in () end
62.108 - else ();
62.109 - case int_ord (size_of_term' t, size_of_term' u) of
62.110 - EQUAL =>
62.111 - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
62.112 - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
62.113 - | ord => ord)
62.114 - end
62.115 - | ord => ord)
62.116 -and hd_ord (f, g) = (* ~ term.ML *)
62.117 - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
62.118 -and terms_ord str pr (ts, us) =
62.119 - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
62.120 -
62.121 -in
62.122 -(* associates a+(b+c) => (a+b)+c = a+b+c ... avoiding parentheses
62.123 - by (1) size_of_term: less(!) to right, size_of 'sqrt (...)' = 1
62.124 - (2) hd_ord: greater to right, 'sqrt' < numerals < variables
62.125 - (3) terms_ord: recurs. on args, greater to right
62.126 -*)
62.127 -
62.128 -(*args
62.129 - pr: print trace, WN0509 'sqrt_right true' not used anymore
62.130 - thy:
62.131 - subst: no bound variables, only Root.sqrt
62.132 - tu: the terms to compare (t1, t2) ... *)
62.133 -fun sqrt_right (pr:bool) thy (_:subst) tu =
62.134 - (term_ord' pr thy(***) tu = LESS );
62.135 -end;
62.136 -
62.137 -rew_ord' := overwritel (!rew_ord',
62.138 -[("termlessI", termlessI),
62.139 - ("sqrt_right", sqrt_right false (theory "Pure"))
62.140 - ]);
62.141 -
62.142 -(*-------------------------rulse-------------------------*)
62.143 -val Root_crls =
62.144 - append_rls "Root_crls" Atools_erls
62.145 - [Thm ("real_unari_minus",num_str real_unari_minus),
62.146 - Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"),
62.147 - Calc ("HOL.divide",eval_cancel "#divide_"),
62.148 - Calc ("Atools.pow" ,eval_binop "#power_"),
62.149 - Calc ("op +", eval_binop "#add_"),
62.150 - Calc ("op -", eval_binop "#sub_"),
62.151 - Calc ("op *", eval_binop "#mult_"),
62.152 - Calc ("op =",eval_equal "#equal_")
62.153 - ];
62.154 -
62.155 -val Root_erls =
62.156 - append_rls "Root_erls" Atools_erls
62.157 - [Thm ("real_unari_minus",num_str real_unari_minus),
62.158 - Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"),
62.159 - Calc ("HOL.divide",eval_cancel "#divide_"),
62.160 - Calc ("Atools.pow" ,eval_binop "#power_"),
62.161 - Calc ("op +", eval_binop "#add_"),
62.162 - Calc ("op -", eval_binop "#sub_"),
62.163 - Calc ("op *", eval_binop "#mult_"),
62.164 - Calc ("op =",eval_equal "#equal_")
62.165 - ];
62.166 -
62.167 -ruleset' := overwritelthy thy (!ruleset',
62.168 - [("Root_erls",Root_erls) (*FIXXXME:del with rls.rls'*)
62.169 - ]);
62.170 -
62.171 -val make_rooteq = prep_rls(
62.172 - Rls{id = "make_rooteq", preconds = []:term list,
62.173 - rew_ord = ("sqrt_right", sqrt_right false Root.thy),
62.174 - erls = Atools_erls, srls = Erls,
62.175 - calc = [],
62.176 - (*asm_thm = [],*)
62.177 - rules = [Thm ("real_diff_minus",num_str real_diff_minus),
62.178 - (*"a - b = a + (-1) * b"*)
62.179 -
62.180 - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
62.181 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
62.182 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
62.183 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
62.184 - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
62.185 - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
62.186 - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
62.187 - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
62.188 -
62.189 - Thm ("real_mult_1",num_str real_mult_1),
62.190 - (*"1 * z = z"*)
62.191 - Thm ("real_mult_0",num_str real_mult_0),
62.192 - (*"0 * z = 0"*)
62.193 - Thm ("real_add_zero_left",num_str real_add_zero_left),
62.194 - (*"0 + z = z"*)
62.195 -
62.196 - Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
62.197 - Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
62.198 - Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
62.199 - Thm ("real_add_commute",num_str real_add_commute), (**)
62.200 - Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
62.201 - Thm ("real_add_assoc",num_str real_add_assoc), (**)
62.202 -
62.203 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
62.204 - (*"r1 * r1 = r1 ^^^ 2"*)
62.205 - Thm ("realpow_plus_1",num_str realpow_plus_1),
62.206 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
62.207 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
62.208 - (*"z1 + z1 = 2 * z1"*)
62.209 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
62.210 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
62.211 -
62.212 - Thm ("real_num_collect",num_str real_num_collect),
62.213 - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
62.214 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
62.215 - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
62.216 - Thm ("real_one_collect",num_str real_one_collect),
62.217 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
62.218 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
62.219 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
62.220 -
62.221 - Calc ("op +", eval_binop "#add_"),
62.222 - Calc ("op *", eval_binop "#mult_"),
62.223 - Calc ("Atools.pow", eval_binop "#power_")
62.224 - ],
62.225 - scr = Script ((term_of o the o (parse thy)) "empty_script")
62.226 - }:rls);
62.227 -ruleset' := overwritelthy thy (!ruleset',
62.228 - [("make_rooteq", make_rooteq)
62.229 - ]);
62.230 -
62.231 -val expand_rootbinoms = prep_rls(
62.232 - Rls{id = "expand_rootbinoms", preconds = [],
62.233 - rew_ord = ("termlessI",termlessI),
62.234 - erls = Atools_erls, srls = Erls,
62.235 - calc = [],
62.236 - (*asm_thm = [],*)
62.237 - rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
62.238 - (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
62.239 - Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
62.240 - (*"(a + b)*(a + b) = ...*)
62.241 - Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
62.242 - (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
62.243 - Thm ("real_minus_binom_times",num_str real_minus_binom_times),
62.244 - (*"(a - b)*(a - b) = ...*)
62.245 - Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
62.246 - (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
62.247 - Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
62.248 - (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
62.249 - (*RL 020915*)
62.250 - Thm ("real_pp_binom_times",num_str real_pp_binom_times),
62.251 - (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
62.252 - Thm ("real_pm_binom_times",num_str real_pm_binom_times),
62.253 - (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
62.254 - Thm ("real_mp_binom_times",num_str real_mp_binom_times),
62.255 - (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
62.256 - Thm ("real_mm_binom_times",num_str real_mm_binom_times),
62.257 - (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
62.258 - Thm ("realpow_mul",num_str realpow_mul),
62.259 - (*(a*b)^^^n = a^^^n * b^^^n*)
62.260 -
62.261 - Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
62.262 - Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
62.263 - Thm ("real_add_zero_left",num_str real_add_zero_left), (*"0 + z = z"*)
62.264 -
62.265 - Calc ("op +", eval_binop "#add_"),
62.266 - Calc ("op -", eval_binop "#sub_"),
62.267 - Calc ("op *", eval_binop "#mult_"),
62.268 - Calc ("HOL.divide" ,eval_cancel "#divide_"),
62.269 - Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
62.270 - Calc ("Atools.pow", eval_binop "#power_"),
62.271 -
62.272 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
62.273 - (*"r1 * r1 = r1 ^^^ 2"*)
62.274 - Thm ("realpow_plus_1",num_str realpow_plus_1),
62.275 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
62.276 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
62.277 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
62.278 -
62.279 - Thm ("real_num_collect",num_str real_num_collect),
62.280 - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
62.281 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
62.282 - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
62.283 - Thm ("real_one_collect",num_str real_one_collect),
62.284 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
62.285 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
62.286 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
62.287 -
62.288 - Calc ("op +", eval_binop "#add_"),
62.289 - Calc ("op -", eval_binop "#sub_"),
62.290 - Calc ("op *", eval_binop "#mult_"),
62.291 - Calc ("HOL.divide" ,eval_cancel "#divide_"),
62.292 - Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
62.293 - Calc ("Atools.pow", eval_binop "#power_")
62.294 - ],
62.295 - scr = Script ((term_of o the o (parse thy)) "empty_script")
62.296 - }:rls);
62.297 -
62.298 -
62.299 -ruleset' := overwritelthy thy (!ruleset',
62.300 - [("expand_rootbinoms", expand_rootbinoms)
62.301 - ]);
62.302 -"******* Root.ML end *******";
63.1 --- a/src/Tools/isac/IsacKnowledge/Root.thy Wed Aug 25 15:15:01 2010 +0200
63.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
63.3 @@ -1,53 +0,0 @@
63.4 -(* theory collecting all knowledge for Root
63.5 - created by:
63.6 - date:
63.7 - changed by: rlang
63.8 - last change by: rlang
63.9 - date: 02.10.21
63.10 -*)
63.11 -
63.12 -(* use_thy_only"IsacKnowledge/Root";
63.13 - remove_thy"Root";
63.14 - use_thy"IsacKnowledge/Isac";
63.15 -*)
63.16 -Root = Simplify +
63.17 -
63.18 -(*-------------------- consts------------------------------------------------*)
63.19 -consts
63.20 -
63.21 - sqrt :: "real => real" (*"(sqrt _ )" [80] 80*)
63.22 - nroot :: "[real, real] => real"
63.23 -
63.24 -(*----------------------scripts-----------------------*)
63.25 -
63.26 -(*-------------------- rules------------------------------------------------*)
63.27 -rules (*.not contained in Isabelle2002,
63.28 - stated as axioms, TODO: prove as theorems;
63.29 - theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*)
63.30 -
63.31 - root_plus_minus "0 <= b ==> \
63.32 - \(a^^^2 = b) = ((a = sqrt b) | (a = (-1)*sqrt b))"
63.33 - root_false "b < 0 ==> (a^^^2 = b) = False"
63.34 -
63.35 - (* for expand_rootbinom *)
63.36 - real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d"
63.37 - real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d"
63.38 - real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d"
63.39 - real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d"
63.40 - real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
63.41 - real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3"
63.42 - realpow_mul "(a*b)^^^n = a^^^n * b^^^n"
63.43 -
63.44 - real_diff_minus "a - b = a + (-1) * b"
63.45 - real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2"
63.46 - real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2"
63.47 - real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"
63.48 - real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2"
63.49 - real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2"
63.50 - real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2"
63.51 -
63.52 - real_root_positive "0 <= a ==> (x ^^^ 2 = a) = (x = sqrt a)"
63.53 - real_root_negative "a < 0 ==> (x ^^^ 2 = a) = False"
63.54 -
63.55 -
63.56 -end
64.1 --- a/src/Tools/isac/IsacKnowledge/RootEq.ML Wed Aug 25 15:15:01 2010 +0200
64.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
64.3 @@ -1,505 +0,0 @@
64.4 -(*.(c) by Richard Lang, 2003 .*)
64.5 -(* theory collecting all knowledge for RootEquations
64.6 - created by: rlang
64.7 - date: 02.09
64.8 - changed by: rlang
64.9 - last change by: rlang
64.10 - date: 02.11.14
64.11 -*)
64.12 -
64.13 -(* use"IsacKnowledge/RootEq.ML";
64.14 - use"RootEq.ML";
64.15 -
64.16 - use"ROOT.ML";
64.17 - cd"knowledge";
64.18 -
64.19 - remove_thy"RootEq";
64.20 - use_thy"IsacKnowledge/Isac";
64.21 - *)
64.22 -"******* RootEq.ML begin *******";
64.23 -
64.24 -theory' := overwritel (!theory', [("RootEq.thy",RootEq.thy)]);
64.25 -(*-------------------------functions---------------------*)
64.26 -(* true if bdv is under sqrt of a Equation*)
64.27 -fun is_rootTerm_in t v =
64.28 - let
64.29 - fun coeff_in c v = member op = (vars c) v;
64.30 - fun findroot (_ $ _ $ _ $ _) v = raise error("is_rootTerm_in:")
64.31 - (* at the moment there is no term like this, but ....*)
64.32 - | findroot (t as (Const ("Root.nroot",_) $ _ $ t3)) v = coeff_in t3 v
64.33 - | findroot (_ $ t2 $ t3) v = (findroot t2 v) orelse (findroot t3 v)
64.34 - | findroot (t as (Const ("Root.sqrt",_) $ t2)) v = coeff_in t2 v
64.35 - | findroot (_ $ t2) v = (findroot t2 v)
64.36 - | findroot _ _ = false;
64.37 - in
64.38 - findroot t v
64.39 - end;
64.40 -
64.41 - fun is_sqrtTerm_in t v =
64.42 - let
64.43 - fun coeff_in c v = member op = (vars c) v;
64.44 - fun findsqrt (_ $ _ $ _ $ _) v = raise error("is_sqrteqation_in:")
64.45 - (* at the moment there is no term like this, but ....*)
64.46 - | findsqrt (_ $ t1 $ t2) v = (findsqrt t1 v) orelse (findsqrt t2 v)
64.47 - | findsqrt (t as (Const ("Root.sqrt",_) $ a)) v = coeff_in a v
64.48 - | findsqrt (_ $ t1) v = (findsqrt t1 v)
64.49 - | findsqrt _ _ = false;
64.50 - in
64.51 - findsqrt t v
64.52 - end;
64.53 -
64.54 -(* RL: 030518: Is in the rightest subterm of a term a sqrt with bdv,
64.55 -and the subterm ist connected with + or * --> is normalized*)
64.56 - fun is_normSqrtTerm_in t v =
64.57 - let
64.58 - fun coeff_in c v = member op = (vars c) v;
64.59 - fun isnorm (_ $ _ $ _ $ _) v = raise error("is_normSqrtTerm_in:")
64.60 - (* at the moment there is no term like this, but ....*)
64.61 - | isnorm (Const ("op +",_) $ _ $ t2) v = is_sqrtTerm_in t2 v
64.62 - | isnorm (Const ("op *",_) $ _ $ t2) v = is_sqrtTerm_in t2 v
64.63 - | isnorm (Const ("op -",_) $ _ $ _) v = false
64.64 - | isnorm (Const ("HOL.divide",_) $ t1 $ t2) v = (is_sqrtTerm_in t1 v) orelse
64.65 - (is_sqrtTerm_in t2 v)
64.66 - | isnorm (Const ("Root.sqrt",_) $ t1) v = coeff_in t1 v
64.67 - | isnorm (_ $ t1) v = is_sqrtTerm_in t1 v
64.68 - | isnorm _ _ = false;
64.69 - in
64.70 - isnorm t v
64.71 - end;
64.72 -
64.73 -fun eval_is_rootTerm_in _ _ (p as (Const ("RootEq.is'_rootTerm'_in",_) $ t $ v)) _ =
64.74 - if is_rootTerm_in t v then
64.75 - SOME ((term2str p) ^ " = True",
64.76 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
64.77 - else SOME ((term2str p) ^ " = True",
64.78 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
64.79 - | eval_is_rootTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
64.80 -
64.81 -fun eval_is_sqrtTerm_in _ _ (p as (Const ("RootEq.is'_sqrtTerm'_in",_) $ t $ v)) _ =
64.82 - if is_sqrtTerm_in t v then
64.83 - SOME ((term2str p) ^ " = True",
64.84 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
64.85 - else SOME ((term2str p) ^ " = True",
64.86 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
64.87 - | eval_is_sqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
64.88 -
64.89 -fun eval_is_normSqrtTerm_in _ _ (p as (Const ("RootEq.is'_normSqrtTerm'_in",_) $ t $ v)) _ =
64.90 - if is_normSqrtTerm_in t v then
64.91 - SOME ((term2str p) ^ " = True",
64.92 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
64.93 - else SOME ((term2str p) ^ " = True",
64.94 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
64.95 - | eval_is_normSqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
64.96 -
64.97 -(*-------------------------rulse-------------------------*)
64.98 -val RootEq_prls = (*15.10.02:just the following order due to subterm evaluation*)
64.99 - append_rls "RootEq_prls" e_rls
64.100 - [Calc ("Atools.ident",eval_ident "#ident_"),
64.101 - Calc ("Tools.matches",eval_matches ""),
64.102 - Calc ("Tools.lhs" ,eval_lhs ""),
64.103 - Calc ("Tools.rhs" ,eval_rhs ""),
64.104 - Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""),
64.105 - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""),
64.106 - Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""),
64.107 - Calc ("op =",eval_equal "#equal_"),
64.108 - Thm ("not_true",num_str not_true),
64.109 - Thm ("not_false",num_str not_false),
64.110 - Thm ("and_true",num_str and_true),
64.111 - Thm ("and_false",num_str and_false),
64.112 - Thm ("or_true",num_str or_true),
64.113 - Thm ("or_false",num_str or_false)
64.114 - ];
64.115 -
64.116 -val RootEq_erls =
64.117 - append_rls "RootEq_erls" Root_erls
64.118 - [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq)
64.119 - ];
64.120 -
64.121 -val RootEq_crls =
64.122 - append_rls "RootEq_crls" Root_crls
64.123 - [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq)
64.124 - ];
64.125 -
64.126 -val rooteq_srls =
64.127 - append_rls "rooteq_srls" e_rls
64.128 - [Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""),
64.129 - Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""),
64.130 - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in "")
64.131 - ];
64.132 -
64.133 -ruleset' := overwritelthy thy (!ruleset',
64.134 - [("RootEq_erls",RootEq_erls), (*FIXXXME:del with rls.rls'*)
64.135 - ("rooteq_srls",rooteq_srls)
64.136 - ]);
64.137 -
64.138 -(*isolate the bound variable in an sqrt equation; 'bdv' is a meta-constant*)
64.139 - val sqrt_isolate = prep_rls(
64.140 - Rls {id = "sqrt_isolate", preconds = [], rew_ord = ("termlessI",termlessI),
64.141 - erls = RootEq_erls, srls = Erls, calc = [],
64.142 - (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
64.143 - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
64.144 - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
64.145 - ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""),
64.146 - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
64.147 - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
64.148 - ("sqrt_square_equation_right_6","")],*)
64.149 - rules = [
64.150 - Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
64.151 - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
64.152 - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
64.153 - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
64.154 - Thm("sqrt_square_equation_both_1",num_str sqrt_square_equation_both_1),
64.155 - (* (sqrt a + sqrt b = sqrt c + sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *)
64.156 - Thm("sqrt_square_equation_both_2",num_str sqrt_square_equation_both_2),
64.157 - (* (sqrt a - sqrt b = sqrt c + sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *)
64.158 - Thm("sqrt_square_equation_both_3",num_str sqrt_square_equation_both_3),
64.159 - (* (sqrt a + sqrt b = sqrt c - sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *)
64.160 - Thm("sqrt_square_equation_both_4",num_str sqrt_square_equation_both_4),
64.161 - (* (sqrt a - sqrt b = sqrt c - sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *)
64.162 - Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *)
64.163 - Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *)
64.164 - Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *)
64.165 - Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *)
64.166 - Thm("sqrt_isolate_l_add5",num_str sqrt_isolate_l_add5), (* a+b*c/f*sqrt(x)=d->b*c/f*sqrt(x)=d-a *)
64.167 - Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *)
64.168 - (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *)
64.169 - Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *)
64.170 - Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *)
64.171 - Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*)
64.172 - Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *)
64.173 - Thm("sqrt_isolate_r_add5",num_str sqrt_isolate_r_add5), (* a=d+e*g/h*sqrt(x)->a-d=e*g/h*sqrt(x)*)
64.174 - Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *)
64.175 - (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *)
64.176 - Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1),
64.177 - (* sqrt(x)=b -> x=b^2 *)
64.178 - Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2),
64.179 - (* c*sqrt(x)=b -> c^2*x=b^2 *)
64.180 - Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3),
64.181 - (* c/sqrt(x)=b -> c^2/x=b^2 *)
64.182 - Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4),
64.183 - (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *)
64.184 - Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5),
64.185 - (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *)
64.186 - Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6),
64.187 - (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *)
64.188 - Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1),
64.189 - (* a=sqrt(x) ->a^2=x *)
64.190 - Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2),
64.191 - (* a=c*sqrt(x) ->a^2=c^2*x *)
64.192 - Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3),
64.193 - (* a=c/sqrt(x) ->a^2=c^2/x *)
64.194 - Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4),
64.195 - (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *)
64.196 - Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5),
64.197 - (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *)
64.198 - Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6)
64.199 - (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *)
64.200 - ],
64.201 - scr = Script ((term_of o the o (parse thy)) "empty_script")
64.202 - }:rls);
64.203 -ruleset' := overwritelthy thy (!ruleset',
64.204 - [("sqrt_isolate",sqrt_isolate)
64.205 - ]);
64.206 -(* -- left 28.08.02--*)
64.207 -(*isolate the bound variable in an sqrt left equation; 'bdv' is a meta-constant*)
64.208 - val l_sqrt_isolate = prep_rls(
64.209 - Rls {id = "l_sqrt_isolate", preconds = [],
64.210 - rew_ord = ("termlessI",termlessI),
64.211 - erls = RootEq_erls, srls = Erls, calc = [],
64.212 - (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
64.213 - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
64.214 - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
64.215 - ("sqrt_square_equation_left_6","")],*)
64.216 - rules = [
64.217 - Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
64.218 - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
64.219 - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
64.220 - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
64.221 - Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *)
64.222 - Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *)
64.223 - Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *)
64.224 - Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *)
64.225 - Thm("sqrt_isolate_l_add5",num_str sqrt_isolate_l_add5), (* a+b*c/f*sqrt(x)=d->b*c/f*sqrt(x)=d-a *)
64.226 - Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *)
64.227 - (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *)
64.228 - Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1),
64.229 - (* sqrt(x)=b -> x=b^2 *)
64.230 - Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2),
64.231 - (* a*sqrt(x)=b -> a^2*x=b^2*)
64.232 - Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3),
64.233 - (* c/sqrt(x)=b -> c^2/x=b^2 *)
64.234 - Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4),
64.235 - (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *)
64.236 - Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5),
64.237 - (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *)
64.238 - Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6)
64.239 - (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *)
64.240 - ],
64.241 - scr = Script ((term_of o the o (parse thy)) "empty_script")
64.242 - }:rls);
64.243 -ruleset' := overwritelthy thy (!ruleset',
64.244 - [("l_sqrt_isolate",l_sqrt_isolate)
64.245 - ]);
64.246 -
64.247 -(* -- right 28.8.02--*)
64.248 -(*isolate the bound variable in an sqrt right equation; 'bdv' is a meta-constant*)
64.249 - val r_sqrt_isolate = prep_rls(
64.250 - Rls {id = "r_sqrt_isolate", preconds = [],
64.251 - rew_ord = ("termlessI",termlessI),
64.252 - erls = RootEq_erls, srls = Erls, calc = [],
64.253 - (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_right_1",""),
64.254 - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
64.255 - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
64.256 - ("sqrt_square_equation_right_6","")],*)
64.257 - rules = [
64.258 - Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
64.259 - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
64.260 - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
64.261 - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
64.262 - Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *)
64.263 - Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *)
64.264 - Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*)
64.265 - Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *)
64.266 - Thm("sqrt_isolate_r_add5",num_str sqrt_isolate_r_add5), (* a=d+e*g/h*sqrt(x)->a-d=e*g/h*sqrt(x)*)
64.267 - Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *)
64.268 - (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *)
64.269 - Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1),
64.270 - (* a=sqrt(x) ->a^2=x *)
64.271 - Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2),
64.272 - (* a=c*sqrt(x) ->a^2=c^2*x *)
64.273 - Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3),
64.274 - (* a=c/sqrt(x) ->a^2=c^2/x *)
64.275 - Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4),
64.276 - (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *)
64.277 - Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5),
64.278 - (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *)
64.279 - Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6)
64.280 - (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *)
64.281 - ],
64.282 - scr = Script ((term_of o the o (parse thy)) "empty_script")
64.283 - }:rls);
64.284 -ruleset' := overwritelthy thy (!ruleset',
64.285 - [("r_sqrt_isolate",r_sqrt_isolate)
64.286 - ]);
64.287 -
64.288 -val rooteq_simplify = prep_rls(
64.289 - Rls {id = "rooteq_simplify",
64.290 - preconds = [], rew_ord = ("termlessI",termlessI),
64.291 - erls = RootEq_erls, srls = Erls, calc = [],
64.292 - (*asm_thm = [("sqrt_square_1","")],*)
64.293 - rules = [Thm ("real_assoc_1",num_str real_assoc_1), (* a+(b+c) = a+b+c *)
64.294 - Thm ("real_assoc_2",num_str real_assoc_2), (* a*(b*c) = a*b*c *)
64.295 - Calc ("op +",eval_binop "#add_"),
64.296 - Calc ("op -",eval_binop "#sub_"),
64.297 - Calc ("op *",eval_binop "#mult_"),
64.298 - Calc ("HOL.divide", eval_cancel "#divide_"),
64.299 - Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
64.300 - Calc ("Atools.pow" ,eval_binop "#power_"),
64.301 - Thm("real_plus_binom_pow2",num_str real_plus_binom_pow2),
64.302 - Thm("real_minus_binom_pow2",num_str real_minus_binom_pow2),
64.303 - Thm("realpow_mul",num_str realpow_mul), (* (a * b)^n = a^n * b^n*)
64.304 - Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt b * sqrt c = sqrt(b*c) *)
64.305 - Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a * sqrt a * sqrt b = a * sqrt(a*b) *)
64.306 - Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) = a *)
64.307 - Thm("sqrt_square_1",num_str sqrt_square_1) (* sqrt a ^^^ 2 = a *)
64.308 - ],
64.309 - scr = Script ((term_of o the o (parse thy)) "empty_script")
64.310 - }:rls);
64.311 - ruleset' := overwritelthy thy (!ruleset',
64.312 - [("rooteq_simplify",rooteq_simplify)
64.313 - ]);
64.314 -
64.315 -(*-------------------------Problem-----------------------*)
64.316 -(*
64.317 -(get_pbt ["root","univariate","equation"]);
64.318 -show_ptyps();
64.319 -*)
64.320 -(* ---------root----------- *)
64.321 -store_pbt
64.322 - (prep_pbt RootEq.thy "pbl_equ_univ_root" [] e_pblID
64.323 - (["root","univariate","equation"],
64.324 - [("#Given" ,["equality e_","solveFor v_"]),
64.325 - ("#Where" ,["(lhs e_) is_rootTerm_in (v_::real) | \
64.326 - \(rhs e_) is_rootTerm_in (v_::real)"]),
64.327 - ("#Find" ,["solutions v_i_"])
64.328 - ],
64.329 - RootEq_prls, SOME "solve (e_::bool, v_)",
64.330 - []));
64.331 -(* ---------sqrt----------- *)
64.332 -store_pbt
64.333 - (prep_pbt RootEq.thy "pbl_equ_univ_root_sq" [] e_pblID
64.334 - (["sq","root","univariate","equation"],
64.335 - [("#Given" ,["equality e_","solveFor v_"]),
64.336 - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
64.337 - \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\
64.338 - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
64.339 - \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]),
64.340 - ("#Find" ,["solutions v_i_"])
64.341 - ],
64.342 - RootEq_prls, SOME "solve (e_::bool, v_)",
64.343 - [["RootEq","solve_sq_root_equation"]]));
64.344 -(* ---------normalize----------- *)
64.345 -store_pbt
64.346 - (prep_pbt RootEq.thy "pbl_equ_univ_root_norm" [] e_pblID
64.347 - (["normalize","root","univariate","equation"],
64.348 - [("#Given" ,["equality e_","solveFor v_"]),
64.349 - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
64.350 - \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \
64.351 - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
64.352 - \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]),
64.353 - ("#Find" ,["solutions v_i_"])
64.354 - ],
64.355 - RootEq_prls, SOME "solve (e_::bool, v_)",
64.356 - [["RootEq","norm_sq_root_equation"]]));
64.357 -
64.358 -(*-------------------------methods-----------------------*)
64.359 -(* ---- root 20.8.02 ---*)
64.360 -store_met
64.361 - (prep_met RootEq.thy "met_rooteq" [] e_metID
64.362 - (["RootEq"],
64.363 - [],
64.364 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
64.365 - crls=RootEq_crls, nrls=norm_Poly(*,
64.366 - asm_rls=[],asm_thm=[]*)}, "empty_script"));
64.367 -(*-- normalize 20.10.02 --*)
64.368 -store_met
64.369 - (prep_met RootEq.thy "met_rooteq_norm" [] e_metID
64.370 - (["RootEq","norm_sq_root_equation"],
64.371 - [("#Given" ,["equality e_","solveFor v_"]),
64.372 - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
64.373 - \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \
64.374 - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
64.375 - \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]),
64.376 - ("#Find" ,["solutions v_i_"])
64.377 - ],
64.378 - {rew_ord'="termlessI",
64.379 - rls'=RootEq_erls,
64.380 - srls=e_rls,
64.381 - prls=RootEq_prls,
64.382 - calc=[],
64.383 - crls=RootEq_crls, nrls=norm_Poly(*,
64.384 - asm_rls=[],
64.385 - asm_thm=[("sqrt_square_1","")]*)},
64.386 - "Script Norm_sq_root_equation (e_::bool) (v_::real) = \
64.387 - \(let e_ = ((Repeat(Try (Rewrite makex1_x False))) @@ \
64.388 - \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
64.389 - \ (Try (Rewrite_Set rooteq_simplify True)) @@ \
64.390 - \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
64.391 - \ (Try (Rewrite_Set rooteq_simplify True))) e_ \
64.392 - \ in ((SubProblem (RootEq_,[univariate,equation], \
64.393 - \ [no_met]) [bool_ e_, real_ v_])))"
64.394 - ));
64.395 -
64.396 -store_met
64.397 - (prep_met RootEq.thy "met_rooteq_sq" [] e_metID
64.398 - (["RootEq","solve_sq_root_equation"],
64.399 - [("#Given" ,["equality e_","solveFor v_"]),
64.400 - ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
64.401 - \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\
64.402 - \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
64.403 - \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]),
64.404 - ("#Find" ,["solutions v_i_"])
64.405 - ],
64.406 - {rew_ord'="termlessI",
64.407 - rls'=RootEq_erls,
64.408 - srls = rooteq_srls,
64.409 - prls = RootEq_prls,
64.410 - calc = [],
64.411 - crls=RootEq_crls, nrls=norm_Poly(*,
64.412 - asm_rls = [],
64.413 - asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
64.414 - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
64.415 - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
64.416 - ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""),
64.417 - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
64.418 - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
64.419 - ("sqrt_square_equation_right_6","")]*)},
64.420 -"Script Solve_sq_root_equation (e_::bool) (v_::real) = \
64.421 -\(let e_ = \
64.422 -\ ((Try (Rewrite_Set_Inst [(bdv,v_::real)] sqrt_isolate True)) @@ \
64.423 -\ (Try (Rewrite_Set rooteq_simplify True)) @@ \
64.424 -\ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
64.425 -\ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
64.426 -\ (Try (Rewrite_Set rooteq_simplify True))) e_;\
64.427 -\ (L_::bool list) = \
64.428 -\ (if (((lhs e_) is_sqrtTerm_in v_) | ((rhs e_) is_sqrtTerm_in v_))\
64.429 -\ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
64.430 -\ [no_met]) [bool_ e_, real_ v_]) \
64.431 -\ else (SubProblem (RootEq_,[univariate,equation], \
64.432 -\ [no_met]) [bool_ e_, real_ v_])) \
64.433 -\ in Check_elementwise L_ {(v_::real). Assumptions})"
64.434 - ));
64.435 -
64.436 -(*-- right 28.08.02 --*)
64.437 -store_met
64.438 - (prep_met RootEq.thy "met_rooteq_sq_right" [] e_metID
64.439 - (["RootEq","solve_right_sq_root_equation"],
64.440 - [("#Given" ,["equality e_","solveFor v_"]),
64.441 - ("#Where" ,["(rhs e_) is_sqrtTerm_in v_"]),
64.442 - ("#Find" ,["solutions v_i_"])
64.443 - ],
64.444 - {rew_ord'="termlessI",
64.445 - rls'=RootEq_erls,
64.446 - srls=e_rls,
64.447 - prls=RootEq_prls,
64.448 - calc=[],
64.449 - crls=RootEq_crls, nrls=norm_Poly(*,
64.450 - asm_rls=[],
64.451 - asm_thm=[("sqrt_square_1",""),("sqrt_square_1",""),("sqrt_square_equation_right_1",""),
64.452 - ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
64.453 - ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
64.454 - ("sqrt_square_equation_right_6","")]*)},
64.455 - "Script Solve_right_sq_root_equation (e_::bool) (v_::real) = \
64.456 - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] r_sqrt_isolate False)) @@ \
64.457 - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
64.458 - \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
64.459 - \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
64.460 - \ (Try (Rewrite_Set rooteq_simplify False))) e_\
64.461 - \ in if ((rhs e_) is_sqrtTerm_in v_) \
64.462 - \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
64.463 - \ [no_met]) [bool_ e_, real_ v_]) \
64.464 - \ else ((SubProblem (RootEq_,[univariate,equation], \
64.465 - \ [no_met]) [bool_ e_, real_ v_])))"
64.466 - ));
64.467 -
64.468 -(*-- left 28.08.02 --*)
64.469 -store_met
64.470 - (prep_met RootEq.thy "met_rooteq_sq_left" [] e_metID
64.471 - (["RootEq","solve_left_sq_root_equation"],
64.472 - [("#Given" ,["equality e_","solveFor v_"]),
64.473 - ("#Where" ,["(lhs e_) is_sqrtTerm_in v_"]),
64.474 - ("#Find" ,["solutions v_i_"])
64.475 - ],
64.476 - {rew_ord'="termlessI",
64.477 - rls'=RootEq_erls,
64.478 - srls=e_rls,
64.479 - prls=RootEq_prls,
64.480 - calc=[],
64.481 - crls=RootEq_crls, nrls=norm_Poly(*,
64.482 - asm_rls=[],
64.483 - asm_thm=[("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
64.484 - ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
64.485 - ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
64.486 - ("sqrt_square_equation_left_6","")]*)},
64.487 - "Script Solve_left_sq_root_equation (e_::bool) (v_::real) = \
64.488 - \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] l_sqrt_isolate False)) @@ \
64.489 - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
64.490 - \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
64.491 - \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
64.492 - \ (Try (Rewrite_Set rooteq_simplify False))) e_\
64.493 - \ in if ((lhs e_) is_sqrtTerm_in v_) \
64.494 - \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
64.495 - \ [no_met]) [bool_ e_, real_ v_]) \
64.496 - \ else ((SubProblem (RootEq_,[univariate,equation], \
64.497 - \ [no_met]) [bool_ e_, real_ v_])))"
64.498 - ));
64.499 -
64.500 -calclist':= overwritel (!calclist',
64.501 - [("is_rootTerm_in", ("RootEq.is'_rootTerm'_in",
64.502 - eval_is_rootTerm_in"")),
64.503 - ("is_sqrtTerm_in", ("RootEq.is'_sqrtTerm'_in",
64.504 - eval_is_sqrtTerm_in"")),
64.505 - ("is_normSqrtTerm_in", ("RootEq.is_normSqrtTerm_in",
64.506 - eval_is_normSqrtTerm_in""))
64.507 - ]);(*("", ("", "")),*)
64.508 -"******* RootEq.ML end *******";
65.1 --- a/src/Tools/isac/IsacKnowledge/RootEq.thy Wed Aug 25 15:15:01 2010 +0200
65.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
65.3 @@ -1,142 +0,0 @@
65.4 -(*.(c) by Richard Lang, 2003 .*)
65.5 -(* collecting all knowledge for Root Equations
65.6 - created by: rlang
65.7 - date: 02.08
65.8 - changed by: rlang
65.9 - last change by: rlang
65.10 - date: 02.11.14
65.11 -*)
65.12 -(* use"../knowledge/RootEq.ML";
65.13 - use"knowledge/RootEq.ML";
65.14 - use"RootEq.ML";
65.15 -
65.16 - remove_thy"RootEq";
65.17 - use_thy"Isac";
65.18 -
65.19 - use"ROOT.ML";
65.20 - cd"knowledge";
65.21 - *)
65.22 -
65.23 -RootEq = Root +
65.24 -
65.25 -(*-------------------- consts------------------------------------------------*)
65.26 -consts
65.27 - (*-------------------------root-----------------------*)
65.28 - is'_rootTerm'_in :: [real, real] => bool ("_ is'_rootTerm'_in _")
65.29 - is'_sqrtTerm'_in :: [real, real] => bool ("_ is'_sqrtTerm'_in _")
65.30 - is'_normSqrtTerm'_in :: [real, real] => bool ("_ is'_normSqrtTerm'_in _")
65.31 - (*----------------------scripts-----------------------*)
65.32 - Norm'_sq'_root'_equation
65.33 - :: "[bool,real, \
65.34 - \ bool list] => bool list"
65.35 - ("((Script Norm'_sq'_root'_equation (_ _ =))// \
65.36 - \ (_))" 9)
65.37 - Solve'_sq'_root'_equation
65.38 - :: "[bool,real, \
65.39 - \ bool list] => bool list"
65.40 - ("((Script Solve'_sq'_root'_equation (_ _ =))// \
65.41 - \ (_))" 9)
65.42 - Solve'_left'_sq'_root'_equation
65.43 - :: "[bool,real, \
65.44 - \ bool list] => bool list"
65.45 - ("((Script Solve'_left'_sq'_root'_equation (_ _ =))// \
65.46 - \ (_))" 9)
65.47 - Solve'_right'_sq'_root'_equation
65.48 - :: "[bool,real, \
65.49 - \ bool list] => bool list"
65.50 - ("((Script Solve'_right'_sq'_root'_equation (_ _ =))// \
65.51 - \ (_))" 9)
65.52 -
65.53 -(*-------------------- rules------------------------------------------------*)
65.54 -rules
65.55 -
65.56 -(* normalize *)
65.57 - makex1_x
65.58 - "a^^^1 = a"
65.59 - real_assoc_1
65.60 - "a+(b+c) = a+b+c"
65.61 - real_assoc_2
65.62 - "a*(b*c) = a*b*c"
65.63 -
65.64 - (* simplification of root*)
65.65 - sqrt_square_1
65.66 - "[|0 <= a|] ==> (sqrt a)^^^2 = a"
65.67 - sqrt_square_2
65.68 - "sqrt (a ^^^ 2) = a"
65.69 - sqrt_times_root_1
65.70 - "sqrt a * sqrt b = sqrt(a*b)"
65.71 - sqrt_times_root_2
65.72 - "a * sqrt b * sqrt c = a * sqrt(b*c)"
65.73 -
65.74 - (* isolate one root on the LEFT or RIGHT hand side of the equation *)
65.75 - sqrt_isolate_l_add1
65.76 - "[|bdv occurs_in c|] ==> (a + b*sqrt(c) = d) = (b * sqrt(c) = d+ (-1) * a)"
65.77 - sqrt_isolate_l_add2
65.78 - "[|bdv occurs_in c|] ==>(a + sqrt(c) = d) = ((sqrt(c) = d+ (-1) * a))"
65.79 - sqrt_isolate_l_add3
65.80 - "[|bdv occurs_in c|] ==> (a + b*(e/sqrt(c)) = d) = (b * (e/sqrt(c)) = d+ (-1) * a)"
65.81 - sqrt_isolate_l_add4
65.82 - "[|bdv occurs_in c|] ==>(a + b/(f*sqrt(c)) = d) = (b / (f*sqrt(c)) = d+ (-1) * a)"
65.83 - sqrt_isolate_l_add5
65.84 - "[|bdv occurs_in c|] ==> (a + b*(e/(f*sqrt(c))) = d) = (b * (e/(f*sqrt(c))) = d+ (-1) * a)"
65.85 - sqrt_isolate_l_add6
65.86 - "[|bdv occurs_in c|] ==>(a + b/sqrt(c) = d) = (b / sqrt(c) = d+ (-1) * a)"
65.87 - sqrt_isolate_r_add1
65.88 - "[|bdv occurs_in f|] ==>(a = d + e*sqrt(f)) = (a + (-1) * d = e*sqrt(f))"
65.89 - sqrt_isolate_r_add2
65.90 - "[|bdv occurs_in f|] ==>(a = d + sqrt(f)) = (a + (-1) * d = sqrt(f))"
65.91 - (* small hack: thm 3,5,6 are not needed if rootnormalize is well done*)
65.92 - sqrt_isolate_r_add3
65.93 - "[|bdv occurs_in f|] ==>(a = d + e*(g/sqrt(f))) = (a + (-1) * d = e*(g/sqrt(f)))"
65.94 - sqrt_isolate_r_add4
65.95 - "[|bdv occurs_in f|] ==>(a = d + g/sqrt(f)) = (a + (-1) * d = g/sqrt(f))"
65.96 - sqrt_isolate_r_add5
65.97 - "[|bdv occurs_in f|] ==>(a = d + e*(g/(h*sqrt(f)))) = (a + (-1) * d = e*(g/(h*sqrt(f))))"
65.98 - sqrt_isolate_r_add6
65.99 - "[|bdv occurs_in f|] ==>(a = d + g/(h*sqrt(f))) = (a + (-1) * d = g/(h*sqrt(f)))"
65.100 -
65.101 - (* eliminate isolates sqrt *)
65.102 - sqrt_square_equation_both_1
65.103 - "[|bdv occurs_in b; bdv occurs_in d|] ==>
65.104 - ( (sqrt a + sqrt b = sqrt c + sqrt d) =
65.105 - (a+2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))"
65.106 - sqrt_square_equation_both_2
65.107 - "[|bdv occurs_in b; bdv occurs_in d|] ==>
65.108 - ( (sqrt a - sqrt b = sqrt c + sqrt d) =
65.109 - (a - 2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))"
65.110 - sqrt_square_equation_both_3
65.111 - "[|bdv occurs_in b; bdv occurs_in d|] ==>
65.112 - ( (sqrt a + sqrt b = sqrt c - sqrt d) =
65.113 - (a + 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))"
65.114 - sqrt_square_equation_both_4
65.115 - "[|bdv occurs_in b; bdv occurs_in d|] ==>
65.116 - ( (sqrt a - sqrt b = sqrt c - sqrt d) =
65.117 - (a - 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))"
65.118 - sqrt_square_equation_left_1
65.119 - "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (sqrt (a) = b) = (a = (b^^^2)))"
65.120 - sqrt_square_equation_left_2
65.121 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( (c*sqrt(a) = b) = (c^^^2*a = b^^^2))"
65.122 - sqrt_square_equation_left_3
65.123 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( c/sqrt(a) = b) = (c^^^2 / a = b^^^2)"
65.124 - (* small hack: thm 4-6 are not needed if rootnormalize is well done*)
65.125 - sqrt_square_equation_left_4
65.126 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( (c*(d/sqrt (a)) = b) = (c^^^2*(d^^^2/a) = b^^^2))"
65.127 - sqrt_square_equation_left_5
65.128 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( c/(d*sqrt(a)) = b) = (c^^^2 / (d^^^2*a) = b^^^2)"
65.129 - sqrt_square_equation_left_6
65.130 - "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d*e|] ==> ( (c*(d/(e*sqrt (a))) = b) = (c^^^2*(d^^^2/(e^^^2*a)) = b^^^2))"
65.131 - sqrt_square_equation_right_1
65.132 - "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = sqrt (b)) = (a^^^2 = b))"
65.133 - sqrt_square_equation_right_2
65.134 - "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c*sqrt (b)) = ((a^^^2) = c^^^2*b))"
65.135 - sqrt_square_equation_right_3
65.136 - "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c/sqrt (b)) = (a^^^2 = c^^^2/b))"
65.137 - (* small hack: thm 4-6 are not needed if rootnormalize is well done*)
65.138 - sqrt_square_equation_right_4
65.139 - "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c*(d/sqrt (b))) = ((a^^^2) = c^^^2*(d^^^2/b)))"
65.140 - sqrt_square_equation_right_5
65.141 - "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c/(d*sqrt (b))) = (a^^^2 = c^^^2/(d^^^2*b)))"
65.142 - sqrt_square_equation_right_6
65.143 - "[|bdv occurs_in b; 0 <= a*c*d*e; 0 <= b|] ==> ( (a = c*(d/(e*sqrt (b)))) = ((a^^^2) = c^^^2*(d^^^2/(e^^^2*b))))"
65.144 -
65.145 -end
66.1 --- a/src/Tools/isac/IsacKnowledge/RootRat.ML Wed Aug 25 15:15:01 2010 +0200
66.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
66.3 @@ -1,50 +0,0 @@
66.4 -(*.(c) by Richard Lang, 2003 .*)
66.5 -(* collecting all knowledge for Root and Rational
66.6 - created by: rlang
66.7 - date: 02.10
66.8 - changed by: rlang
66.9 - last change by: rlang
66.10 - date: 02.10.21
66.11 -*)
66.12 -(* use"knowledge/RootRat.ML";
66.13 - use"RootRat.ML";
66.14 -
66.15 - use"ROOT.ML";
66.16 - cd"knowledge";
66.17 -
66.18 - remove_thy"RootRat";
66.19 - use_thy"Isac";
66.20 - *)
66.21 -
66.22 -"******* RootRat.ML begin *******";
66.23 -theory' := overwritel (!theory', [("RootRat.thy",RootRat.thy)]);
66.24 -
66.25 -(*-------------------------functions---------------------*)
66.26 -
66.27 -(*-------------------------rulse-------------------------*)
66.28 -val rootrat_erls =
66.29 - merge_rls "rootrat_erls" Root_erls
66.30 - (merge_rls "" rational_erls
66.31 - (append_rls "" e_rls
66.32 - []));
66.33 -
66.34 -ruleset' := overwritelthy thy (!ruleset',
66.35 - [("rootrat_erls",rootrat_erls) (*FIXXXME:del with rls.rls'*)
66.36 - ]);
66.37 -
66.38 -(*.calculate numeral groundterms.*)
66.39 -val calculate_RootRat =
66.40 - append_rls "calculate_RootRat" calculate_Rational
66.41 - [Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
66.42 - (* w*(z1.0 + z2.0) = w * z1.0 + w * z2.0 *)
66.43 - Thm ("real_mult_1",num_str real_mult_1),
66.44 - (* 1 * z = z *)
66.45 - Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)),
66.46 - (* "- z1 = -1 * z1" *)
66.47 - Calc ("Root.sqrt",eval_sqrt "#sqrt_")
66.48 - ];
66.49 -ruleset' := overwritelthy thy (!ruleset',
66.50 - [("calculate_RootRat",calculate_RootRat)]);
66.51 -
66.52 -
66.53 -"******* RootRat.ML end *******";
67.1 --- a/src/Tools/isac/IsacKnowledge/RootRat.thy Wed Aug 25 15:15:01 2010 +0200
67.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
67.3 @@ -1,16 +0,0 @@
67.4 -(*.(c) by Richard Lang, 2003 .*)
67.5 -(* collecting all knowledge for Root and Rational
67.6 - created by: rlang
67.7 - date: 02.10
67.8 - changed by: rlang
67.9 - last change by: rlang
67.10 - date: 02.10.20
67.11 -*)
67.12 -
67.13 -RootRat = Root + Rational +
67.14 -(*-------------------- consts------------------------------------------------*)
67.15 -
67.16 -
67.17 -(*-------------------- rules------------------------------------------------*)
67.18 -
67.19 -end
68.1 --- a/src/Tools/isac/IsacKnowledge/RootRatEq.ML Wed Aug 25 15:15:01 2010 +0200
68.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
68.3 @@ -1,166 +0,0 @@
68.4 -(*.(c) by Richard Lang, 2003 .*)
68.5 -(* collecting all knowledge for Root and Rational Equations
68.6 - created by: rlang
68.7 - date: 02.10
68.8 - changed by: rlang
68.9 - last change by: rlang
68.10 - date: 02.11.04
68.11 -*)
68.12 -
68.13 -(* use"knowledge/RootRatEq.ML";
68.14 - use"RootRatEq.ML";
68.15 -
68.16 - use"ROOT.ML";
68.17 - cd"knowledge";
68.18 -
68.19 - remove_thy"RootRatEq";
68.20 - use_thy"Isac";
68.21 - *)
68.22 -
68.23 -"******* RootRatEq.ML begin *******";
68.24 -theory' := overwritel (!theory', [("RootRatEq.thy",RootRatEq.thy)]);
68.25 -
68.26 -(*-------------------------functions---------------------*)
68.27 -(* true if denominator contains (sq)root in + or - term
68.28 - 1/(sqrt(x+3)*(x+4)) -> false; 1/(sqrt(x)+2) -> true
68.29 - if false then (term)^2 contains no (sq)root *)
68.30 -fun is_rootRatAddTerm_in t v =
68.31 - let
68.32 - fun coeff_in c v = member op = (vars c) v;
68.33 - fun rootadd (t as (Const ("op +",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse
68.34 - (is_rootTerm_in t3 v)
68.35 - | rootadd (t as (Const ("op -",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse
68.36 - (is_rootTerm_in t3 v)
68.37 - | rootadd _ _ = false;
68.38 - fun findrootrat (_ $ _ $ _ $ _) v = raise error("is_rootRatAddTerm_in:")
68.39 - (* at the moment there is no term like this, but ....*)
68.40 - | findrootrat (t as (Const ("HOL.divide",_) $ _ $ t3)) v =
68.41 - if (is_rootTerm_in t3 v) then rootadd t3 v else false
68.42 - | findrootrat (_ $ t1 $ t2) v = (findrootrat t1 v) orelse (findrootrat t2 v)
68.43 - | findrootrat (_ $ t1) v = (findrootrat t1 v)
68.44 - | findrootrat _ _ = false;
68.45 - in
68.46 - findrootrat t v
68.47 - end;
68.48 -
68.49 -fun eval_is_rootRatAddTerm_in _ _ (p as (Const ("RootRatEq.is'_rootRatAddTerm'_in",_) $ t $ v)) _ =
68.50 - if is_rootRatAddTerm_in t v then
68.51 - SOME ((term2str p) ^ " = True",
68.52 - Trueprop $ (mk_equality (p, HOLogic.true_const)))
68.53 - else SOME ((term2str p) ^ " = True",
68.54 - Trueprop $ (mk_equality (p, HOLogic.false_const)))
68.55 - | eval_is_rootRatAddTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
68.56 -
68.57 -(*-------------------------rulse-------------------------*)
68.58 -val RootRatEq_prls =
68.59 - append_rls "RootRatEq_prls" e_rls
68.60 - [Calc ("Atools.ident",eval_ident "#ident_"),
68.61 - Calc ("Tools.matches",eval_matches ""),
68.62 - Calc ("Tools.lhs" ,eval_lhs ""),
68.63 - Calc ("Tools.rhs" ,eval_rhs ""),
68.64 - Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""),
68.65 - Calc ("RootRatEq.is'_rootRatAddTerm'_in", eval_is_rootRatAddTerm_in ""),
68.66 - Calc ("op =",eval_equal "#equal_"),
68.67 - Thm ("not_true",num_str not_true),
68.68 - Thm ("not_false",num_str not_false),
68.69 - Thm ("and_true",num_str and_true),
68.70 - Thm ("and_false",num_str and_false),
68.71 - Thm ("or_true",num_str or_true),
68.72 - Thm ("or_false",num_str or_false)
68.73 - ];
68.74 -
68.75 -
68.76 -val RooRatEq_erls =
68.77 - merge_rls "RooRatEq_erls" rootrat_erls
68.78 - (merge_rls "" RootEq_erls
68.79 - (merge_rls "" rateq_erls
68.80 - (append_rls "" e_rls
68.81 - [])));
68.82 -
68.83 -val RootRatEq_crls =
68.84 - merge_rls "RootRatEq_crls" rootrat_erls
68.85 - (merge_rls "" RootEq_erls
68.86 - (merge_rls "" rateq_erls
68.87 - (append_rls "" e_rls
68.88 - [])));
68.89 -
68.90 -ruleset' := overwritelthy thy (!ruleset',
68.91 - [("RooRatEq_erls",RooRatEq_erls) (*FIXXXME:del with rls.rls'*)
68.92 - ]);
68.93 -
68.94 -(* Solves a rootrat Equation *)
68.95 - val rootrat_solve = prep_rls(
68.96 - Rls {id = "rootrat_solve", preconds = [],
68.97 - rew_ord = ("termlessI",termlessI),
68.98 - erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
68.99 - rules = [ Thm("rootrat_equation_left_1",num_str rootrat_equation_left_1),
68.100 - (* [|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c )) *)
68.101 - Thm("rootrat_equation_left_2",num_str rootrat_equation_left_2),
68.102 - (* [|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c )) *)
68.103 - Thm("rootrat_equation_right_1",num_str rootrat_equation_right_1),
68.104 - (* [|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e )) *)
68.105 - Thm("rootrat_equation_right_2",num_str rootrat_equation_right_2)
68.106 - (* [|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e )) *)
68.107 - ],
68.108 - scr = Script ((term_of o the o (parse thy)) "empty_script")
68.109 - }:rls);
68.110 -ruleset' := overwritelthy thy (!ruleset',
68.111 - [("rootrat_solve",rootrat_solve)
68.112 - ]);
68.113 -
68.114 -(*-----------------------probleme------------------------*)
68.115 -(*
68.116 -(get_pbt ["rat","root","univariate","equation"]);
68.117 -show_ptyps();
68.118 -*)
68.119 -store_pbt
68.120 - (prep_pbt RootRatEq.thy "pbl_equ_univ_root_sq_rat" [] e_pblID
68.121 - (["rat","sq","root","univariate","equation"],
68.122 - [("#Given" ,["equality e_","solveFor v_"]),
68.123 - ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) )| \
68.124 - \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]),
68.125 - ("#Find" ,["solutions v_i_"])
68.126 - ],
68.127 - RootRatEq_prls, SOME "solve (e_::bool, v_)",
68.128 - [["RootRatEq","elim_rootrat_equation"]]));
68.129 -
68.130 -(*-------------------------Methode-----------------------*)
68.131 -store_met
68.132 - (prep_met LinEq.thy "met_rootrateq" [] e_metID
68.133 - (["RootRatEq"],
68.134 - [],
68.135 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
68.136 - crls=Atools_erls, nrls=norm_Rational(*,
68.137 - asm_rls=[],asm_thm=[]*)}, "empty_script"));
68.138 -(*-- left 20.10.02 --*)
68.139 -store_met
68.140 - (prep_met RootRatEq.thy "met_rootrateq_elim" [] e_metID
68.141 - (["RootRatEq","elim_rootrat_equation"],
68.142 - [("#Given" ,["equality e_","solveFor v_"]),
68.143 - ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) ) | \
68.144 - \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]),
68.145 - ("#Find" ,["solutions v_i_"])
68.146 - ],
68.147 - {rew_ord'="termlessI",
68.148 - rls'=RooRatEq_erls,
68.149 - srls=e_rls,
68.150 - prls=RootRatEq_prls,
68.151 - calc=[],
68.152 - crls=RootRatEq_crls, nrls=norm_Rational(*,
68.153 - asm_rls=[],
68.154 - asm_thm=[]*)},
68.155 - "Script Elim_rootrat_equation (e_::bool) (v_::real) = \
68.156 - \(let e_ = ((Try (Rewrite_Set expand_rootbinoms False)) @@ \
68.157 - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
68.158 - \ (Try (Rewrite_Set make_rooteq False)) @@ \
68.159 - \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
68.160 - \ (Try (Rewrite_Set_Inst [(bdv,v_)] \
68.161 - \ rootrat_solve False))) e_ \
68.162 - \ in (SubProblem (RootEq_,[univariate,equation], \
68.163 - \ [no_met]) [bool_ e_, real_ v_]))"
68.164 - ));
68.165 -calclist':= overwritel (!calclist',
68.166 - [("is_rootRatAddTerm_in", ("RootRatEq.is_rootRatAddTerm_in",
68.167 - eval_is_rootRatAddTerm_in""))
68.168 - ]);(*("", ("", "")),*)
68.169 -"******* RootRatEq.ML end *******";
69.1 --- a/src/Tools/isac/IsacKnowledge/RootRatEq.thy Wed Aug 25 15:15:01 2010 +0200
69.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
69.3 @@ -1,48 +0,0 @@
69.4 -(*.c) by Richard Lang, 2003 .*)
69.5 -(* collecting all knowledge for Root and Rational Equations
69.6 - created by: rlang
69.7 - date: 02.10
69.8 - changed by: rlang
69.9 - last change by: rlang
69.10 - date: 02.11.04
69.11 -*)
69.12 -
69.13 -(* use"knowledge/RootRatEq.ML";
69.14 - use"RootRatEq.ML";
69.15 -
69.16 - use"ROOT.ML";
69.17 - cd"knowledge";
69.18 -
69.19 - remove_thy"RootRatEq";
69.20 - use_thy"Isac";
69.21 - *)
69.22 -
69.23 -RootRatEq = RootEq + RatEq + RootRat +
69.24 -
69.25 -(*-------------------- consts-----------------------------------------------*)
69.26 -consts
69.27 -
69.28 - is'_rootRatAddTerm'_in :: [real, real] => bool ("_ is'_rootRatAddTerm'_in _") (*RL DA*)
69.29 -
69.30 -(*---------scripts--------------------------*)
69.31 - Elim'_rootrat'_equation
69.32 - :: "[bool,real, \
69.33 - \ bool list] => bool list"
69.34 - ("((Script Elim'_rootrat'_equation (_ _ =))// \
69.35 - \ (_))" 9)
69.36 - (*-------------------- rules------------------------------------------------*)
69.37 -rules
69.38 -
69.39 - (* eliminate ratRootTerm *)
69.40 - rootrat_equation_left_1
69.41 - "[|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c ))"
69.42 - rootrat_equation_left_2
69.43 - "[|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c ))"
69.44 - rootrat_equation_right_2
69.45 - "[|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e ))"
69.46 - rootrat_equation_right_1
69.47 - "[|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e ))"
69.48 -
69.49 -
69.50 -
69.51 -end
70.1 --- a/src/Tools/isac/IsacKnowledge/Simplify.ML Wed Aug 25 15:15:01 2010 +0200
70.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
70.3 @@ -1,76 +0,0 @@
70.4 -(* simplification of terms
70.5 - author: Walther Neuper 050912
70.6 - (c) due to copyright terms
70.7 -
70.8 -use"IsacKnowledge/Simplify.ML";
70.9 -use"Simplify.ML";
70.10 -*)
70.11 -
70.12 -
70.13 -(** interface isabelle -- isac **)
70.14 -
70.15 -theory' := overwritel (!theory', [("Simplify.thy",Simplify.thy)]);
70.16 -
70.17 -(** problems **)
70.18 -
70.19 -store_pbt
70.20 - (prep_pbt Simplify.thy "pbl_simp" [] e_pblID
70.21 - (["simplification"],
70.22 - [("#Given" ,["term t_"]),
70.23 - ("#Find" ,["normalform n_"])
70.24 - ],
70.25 - append_rls "e_rls" e_rls [(*for preds in where_*)],
70.26 - SOME "Simplify t_",
70.27 - []));
70.28 -
70.29 -store_pbt
70.30 - (prep_pbt Simplify.thy "pbl_vereinfache" [] e_pblID
70.31 - (["vereinfachen"],
70.32 - [("#Given" ,["term t_"]),
70.33 - ("#Find" ,["normalform n_"])
70.34 - ],
70.35 - append_rls "e_rls" e_rls [(*for preds in where_*)],
70.36 - SOME "Vereinfache t_",
70.37 - []));
70.38 -
70.39 -(** methods **)
70.40 -
70.41 -store_met
70.42 - (prep_met Simplify.thy "met_simp" [] e_metID
70.43 - (["simplification"],
70.44 - [("#Given" ,["term t_"]),
70.45 - ("#Find" ,["normalform n_"])
70.46 - ],
70.47 - {rew_ord'="tless_true",
70.48 - rls'= e_rls,
70.49 - calc = [],
70.50 - srls = e_rls,
70.51 - prls=e_rls,
70.52 - crls = e_rls, nrls = e_rls},
70.53 - "empty_script"
70.54 - ));
70.55 -
70.56 -(** CAS-command **)
70.57 -
70.58 -(*.function for handling the cas-input "Simplify (2*a + 3*a)":
70.59 - make a model which is already in ptree-internal format.*)
70.60 -(* val (h,argl) = strip_comb (str2term "Simplify (2*a + 3*a)");
70.61 - val (h,argl) = strip_comb ((term_of o the o (parse thy))
70.62 - "Simplify (2*a + 3*a)");
70.63 - *)
70.64 -fun argl2dtss t =
70.65 - [((term_of o the o (parse thy)) "term", t),
70.66 - ((term_of o the o (parse thy)) "normalform",
70.67 - [(term_of o the o (parse thy)) "N"])
70.68 - ]
70.69 - | argl2dtss _ = raise error "Simplify.ML: wrong argument for argl2dtss";
70.70 -
70.71 -castab :=
70.72 -overwritel (!castab,
70.73 - [((term_of o the o (parse thy)) "Simplify",
70.74 - (("Isac.thy", ["simplification"], ["no_met"]),
70.75 - argl2dtss)),
70.76 - ((term_of o the o (parse thy)) "Vereinfache",
70.77 - (("Isac.thy", ["vereinfachen"], ["no_met"]),
70.78 - argl2dtss))
70.79 - ]);
71.1 --- a/src/Tools/isac/IsacKnowledge/Simplify.thy Wed Aug 25 15:15:01 2010 +0200
71.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
71.3 @@ -1,29 +0,0 @@
71.4 -(* simplification of terms
71.5 - author: Walther Neuper 050912
71.6 - (c) due to copyright terms
71.7 -
71.8 -remove_thy"Simplify";
71.9 -use_thy"~/proto2/isac/src/sml/IsacKnowledge/Simplify";
71.10 -
71.11 -use_thy_only"~/proto2/isac/src/sml/IsacKnowledge/Simplify";
71.12 -use_thy"~/proto2/isac/src/sml/IsacKnowledge/Isac";
71.13 -*)
71.14 -
71.15 -Simplify = Atools +
71.16 -
71.17 -consts
71.18 -
71.19 - (*descriptions in the related problem*)
71.20 - term :: real => una
71.21 - normalform :: real => una
71.22 -
71.23 - (*the CAS-command*)
71.24 - Simplify :: "real => real" (*"Simplify (1+2a+3+4a)*)
71.25 - Vereinfache :: "real => real" (*"Vereinfache (1+2a+3+4a)*)
71.26 -
71.27 - (*Script-name*)
71.28 - SimplifyScript :: "[real, real] => real"
71.29 - ("((Script SimplifyScript (_ =))// (_))" 9)
71.30 -
71.31 -
71.32 -end
71.33 \ No newline at end of file
72.1 --- a/src/Tools/isac/IsacKnowledge/Test.ML Wed Aug 25 15:15:01 2010 +0200
72.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
72.3 @@ -1,1301 +0,0 @@
72.4 -(* SML functions for rational arithmetic
72.5 - WN.22.10.99
72.6 - use"../knowledge/Test.ML";
72.7 - use"IsacKnowledge/Test.ML";
72.8 - use"Test.ML";
72.9 - *)
72.10 -
72.11 -
72.12 -(** interface isabelle -- isac **)
72.13 -
72.14 -theory' := overwritel (!theory', [("Test.thy",Test.thy)]);
72.15 -
72.16 -(** evaluation of numerals and predicates **)
72.17 -
72.18 -(*does a term contain a root ?*)
72.19 -fun eval_root_free (thmid:string) _ (t as (Const(op0,t0) $ arg)) thy =
72.20 - if strip_thy op0 <> "is'_root'_free"
72.21 - then raise error ("eval_root_free: wrong "^op0)
72.22 - else if const_in (strip_thy op0) arg
72.23 - then SOME (mk_thmid thmid ""
72.24 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
72.25 - Trueprop $ (mk_equality (t, false_as_term)))
72.26 - else SOME (mk_thmid thmid ""
72.27 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
72.28 - Trueprop $ (mk_equality (t, true_as_term)))
72.29 - | eval_root_free _ _ _ _ = NONE;
72.30 -
72.31 -(*does a term contain a root ?*)
72.32 -fun eval_contains_root (thmid:string) _
72.33 - (t as (Const("Test.contains'_root",t0) $ arg)) thy =
72.34 - if member op = (ids_of arg) "sqrt"
72.35 - then SOME (mk_thmid thmid ""
72.36 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
72.37 - Trueprop $ (mk_equality (t, true_as_term)))
72.38 - else SOME (mk_thmid thmid ""
72.39 - ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
72.40 - Trueprop $ (mk_equality (t, false_as_term)))
72.41 - | eval_contains_root _ _ _ _ = NONE;
72.42 -
72.43 -calclist':= overwritel (!calclist',
72.44 - [("is_root_free", ("Test.is'_root'_free",
72.45 - eval_root_free"#is_root_free_")),
72.46 - ("contains_root", ("Test.contains'_root",
72.47 - eval_contains_root"#contains_root_"))
72.48 - ]);
72.49 -
72.50 -(** term order **)
72.51 -fun term_order (_:subst) tu = (term_ordI [] tu = LESS);
72.52 -
72.53 -(** rule sets **)
72.54 -
72.55 -val testerls =
72.56 - Rls {id = "testerls", preconds = [], rew_ord = ("termlessI",termlessI),
72.57 - erls = e_rls, srls = Erls,
72.58 - calc = [],
72.59 - rules = [Thm ("refl",num_str refl),
72.60 - Thm ("le_refl",num_str le_refl),
72.61 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
72.62 - Thm ("not_true",num_str not_true),
72.63 - Thm ("not_false",num_str not_false),
72.64 - Thm ("and_true",and_true),
72.65 - Thm ("and_false",and_false),
72.66 - Thm ("or_true",or_true),
72.67 - Thm ("or_false",or_false),
72.68 - Thm ("and_commute",num_str and_commute),
72.69 - Thm ("or_commute",num_str or_commute),
72.70 -
72.71 - Calc ("Atools.is'_const",eval_const "#is_const_"),
72.72 - Calc ("Tools.matches",eval_matches ""),
72.73 -
72.74 - Calc ("op +",eval_binop "#add_"),
72.75 - Calc ("op *",eval_binop "#mult_"),
72.76 - Calc ("Atools.pow" ,eval_binop "#power_"),
72.77 -
72.78 - Calc ("op <",eval_equ "#less_"),
72.79 - Calc ("op <=",eval_equ "#less_equal_"),
72.80 -
72.81 - Calc ("Atools.ident",eval_ident "#ident_")],
72.82 - scr = Script ((term_of o the o (parse thy))
72.83 - "empty_script")
72.84 - }:rls;
72.85 -
72.86 -(*.for evaluation of conditions in rewrite rules.*)
72.87 -(*FIXXXXXXME 10.8.02: handle like _simplify*)
72.88 -val tval_rls =
72.89 - Rls{id = "tval_rls", preconds = [],
72.90 - rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")),
72.91 - erls=testerls,srls = e_rls,
72.92 - calc=[],
72.93 - rules = [Thm ("refl",num_str refl),
72.94 - Thm ("le_refl",num_str le_refl),
72.95 - Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
72.96 - Thm ("not_true",num_str not_true),
72.97 - Thm ("not_false",num_str not_false),
72.98 - Thm ("and_true",and_true),
72.99 - Thm ("and_false",and_false),
72.100 - Thm ("or_true",or_true),
72.101 - Thm ("or_false",or_false),
72.102 - Thm ("and_commute",num_str and_commute),
72.103 - Thm ("or_commute",num_str or_commute),
72.104 -
72.105 - Thm ("real_diff_minus",num_str real_diff_minus),
72.106 -
72.107 - Thm ("root_ge0",num_str root_ge0),
72.108 - Thm ("root_add_ge0",num_str root_add_ge0),
72.109 - Thm ("root_ge0_1",num_str root_ge0_1),
72.110 - Thm ("root_ge0_2",num_str root_ge0_2),
72.111 -
72.112 - Calc ("Atools.is'_const",eval_const "#is_const_"),
72.113 - Calc ("Test.is'_root'_free",eval_root_free "#is_root_free_"),
72.114 - Calc ("Tools.matches",eval_matches ""),
72.115 - Calc ("Test.contains'_root",
72.116 - eval_contains_root"#contains_root_"),
72.117 -
72.118 - Calc ("op +",eval_binop "#add_"),
72.119 - Calc ("op *",eval_binop "#mult_"),
72.120 - Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
72.121 - Calc ("Atools.pow" ,eval_binop "#power_"),
72.122 -
72.123 - Calc ("op <",eval_equ "#less_"),
72.124 - Calc ("op <=",eval_equ "#less_equal_"),
72.125 -
72.126 - Calc ("Atools.ident",eval_ident "#ident_")],
72.127 - scr = Script ((term_of o the o (parse thy))
72.128 - "empty_script")
72.129 - }:rls;
72.130 -
72.131 -
72.132 -ruleset' := overwritelthy thy (!ruleset',
72.133 - [("testerls", prep_rls testerls)
72.134 - ]);
72.135 -
72.136 -
72.137 -(*make () dissappear*)
72.138 -val rearrange_assoc =
72.139 - Rls{id = "rearrange_assoc", preconds = [],
72.140 - rew_ord = ("e_rew_ord",e_rew_ord),
72.141 - erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*)
72.142 - rules =
72.143 - [Thm ("sym_radd_assoc",num_str (radd_assoc RS sym)),
72.144 - Thm ("sym_rmult_assoc",num_str (rmult_assoc RS sym))],
72.145 - scr = Script ((term_of o the o (parse thy))
72.146 - "empty_script")
72.147 - }:rls;
72.148 -
72.149 -val ac_plus_times =
72.150 - Rls{id = "ac_plus_times", preconds = [], rew_ord = ("term_order",term_order),
72.151 - erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*)
72.152 - rules =
72.153 - [Thm ("radd_commute",radd_commute),
72.154 - Thm ("radd_left_commute",radd_left_commute),
72.155 - Thm ("radd_assoc",radd_assoc),
72.156 - Thm ("rmult_commute",rmult_commute),
72.157 - Thm ("rmult_left_commute",rmult_left_commute),
72.158 - Thm ("rmult_assoc",rmult_assoc)],
72.159 - scr = Script ((term_of o the o (parse thy))
72.160 - "empty_script")
72.161 - }:rls;
72.162 -
72.163 -(*todo: replace by Rewrite("rnorm_equation_add",num_str rnorm_equation_add)*)
72.164 -val norm_equation =
72.165 - Rls{id = "norm_equation", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
72.166 - erls = tval_rls, srls = e_rls, calc = [], (*asm_thm=[],*)
72.167 - rules = [Thm ("rnorm_equation_add",num_str rnorm_equation_add)
72.168 - ],
72.169 - scr = Script ((term_of o the o (parse thy))
72.170 - "empty_script")
72.171 - }:rls;
72.172 -
72.173 -(** rule sets **)
72.174 -
72.175 -val STest_simplify = (* vv--- not changed to real by parse*)
72.176 - "Script STest_simplify (t_::'z) = \
72.177 - \(Repeat\
72.178 - \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
72.179 - \ (Try (Repeat (Rewrite radd_mult_distrib2 False))) @@ \
72.180 - \ (Try (Repeat (Rewrite rdistr_right_assoc False))) @@ \
72.181 - \ (Try (Repeat (Rewrite rdistr_right_assoc_p False))) @@\
72.182 - \ (Try (Repeat (Rewrite rdistr_div_right False))) @@ \
72.183 - \ (Try (Repeat (Rewrite rbinom_power_2 False))) @@ \
72.184 -
72.185 - \ (Try (Repeat (Rewrite radd_commute False))) @@ \
72.186 - \ (Try (Repeat (Rewrite radd_left_commute False))) @@ \
72.187 - \ (Try (Repeat (Rewrite radd_assoc False))) @@ \
72.188 - \ (Try (Repeat (Rewrite rmult_commute False))) @@ \
72.189 - \ (Try (Repeat (Rewrite rmult_left_commute False))) @@ \
72.190 - \ (Try (Repeat (Rewrite rmult_assoc False))) @@ \
72.191 -
72.192 - \ (Try (Repeat (Rewrite radd_real_const_eq False))) @@ \
72.193 - \ (Try (Repeat (Rewrite radd_real_const False))) @@ \
72.194 - \ (Try (Repeat (Calculate plus))) @@ \
72.195 - \ (Try (Repeat (Calculate times))) @@ \
72.196 - \ (Try (Repeat (Calculate divide_))) @@\
72.197 - \ (Try (Repeat (Calculate power_))) @@ \
72.198 -
72.199 - \ (Try (Repeat (Rewrite rcollect_right False))) @@ \
72.200 - \ (Try (Repeat (Rewrite rcollect_one_left False))) @@ \
72.201 - \ (Try (Repeat (Rewrite rcollect_one_left_assoc False))) @@ \
72.202 - \ (Try (Repeat (Rewrite rcollect_one_left_assoc_p False))) @@ \
72.203 -
72.204 - \ (Try (Repeat (Rewrite rshift_nominator False))) @@ \
72.205 - \ (Try (Repeat (Rewrite rcancel_den False))) @@ \
72.206 - \ (Try (Repeat (Rewrite rroot_square_inv False))) @@ \
72.207 - \ (Try (Repeat (Rewrite rroot_times_root False))) @@ \
72.208 - \ (Try (Repeat (Rewrite rroot_times_root_assoc_p False))) @@ \
72.209 - \ (Try (Repeat (Rewrite rsqare False))) @@ \
72.210 - \ (Try (Repeat (Rewrite power_1 False))) @@ \
72.211 - \ (Try (Repeat (Rewrite rtwo_of_the_same False))) @@ \
72.212 - \ (Try (Repeat (Rewrite rtwo_of_the_same_assoc_p False))) @@ \
72.213 -
72.214 - \ (Try (Repeat (Rewrite rmult_1 False))) @@ \
72.215 - \ (Try (Repeat (Rewrite rmult_1_right False))) @@ \
72.216 - \ (Try (Repeat (Rewrite rmult_0 False))) @@ \
72.217 - \ (Try (Repeat (Rewrite rmult_0_right False))) @@ \
72.218 - \ (Try (Repeat (Rewrite radd_0 False))) @@ \
72.219 - \ (Try (Repeat (Rewrite radd_0_right False)))) \
72.220 - \ t_)";
72.221 -
72.222 -
72.223 -(* expects * distributed over + *)
72.224 -val Test_simplify =
72.225 - Rls{id = "Test_simplify", preconds = [],
72.226 - rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")),
72.227 - erls = tval_rls, srls = e_rls,
72.228 - calc=[(*since 040209 filled by prep_rls*)],
72.229 - (*asm_thm = [],*)
72.230 - rules = [
72.231 - Thm ("real_diff_minus",num_str real_diff_minus),
72.232 - Thm ("radd_mult_distrib2",num_str radd_mult_distrib2),
72.233 - Thm ("rdistr_right_assoc",num_str rdistr_right_assoc),
72.234 - Thm ("rdistr_right_assoc_p",num_str rdistr_right_assoc_p),
72.235 - Thm ("rdistr_div_right",num_str rdistr_div_right),
72.236 - Thm ("rbinom_power_2",num_str rbinom_power_2),
72.237 -
72.238 - Thm ("radd_commute",num_str radd_commute),
72.239 - Thm ("radd_left_commute",num_str radd_left_commute),
72.240 - Thm ("radd_assoc",num_str radd_assoc),
72.241 - Thm ("rmult_commute",num_str rmult_commute),
72.242 - Thm ("rmult_left_commute",num_str rmult_left_commute),
72.243 - Thm ("rmult_assoc",num_str rmult_assoc),
72.244 -
72.245 - Thm ("radd_real_const_eq",num_str radd_real_const_eq),
72.246 - Thm ("radd_real_const",num_str radd_real_const),
72.247 - (* these 2 rules are invers to distr_div_right wrt. termination.
72.248 - thus they MUST be done IMMEDIATELY before calc *)
72.249 - Calc ("op +", eval_binop "#add_"),
72.250 - Calc ("op *", eval_binop "#mult_"),
72.251 - Calc ("HOL.divide", eval_cancel "#divide_"),
72.252 - Calc ("Atools.pow", eval_binop "#power_"),
72.253 -
72.254 - Thm ("rcollect_right",num_str rcollect_right),
72.255 - Thm ("rcollect_one_left",num_str rcollect_one_left),
72.256 - Thm ("rcollect_one_left_assoc",num_str rcollect_one_left_assoc),
72.257 - Thm ("rcollect_one_left_assoc_p",num_str rcollect_one_left_assoc_p),
72.258 -
72.259 - Thm ("rshift_nominator",num_str rshift_nominator),
72.260 - Thm ("rcancel_den",num_str rcancel_den),
72.261 - Thm ("rroot_square_inv",num_str rroot_square_inv),
72.262 - Thm ("rroot_times_root",num_str rroot_times_root),
72.263 - Thm ("rroot_times_root_assoc_p",num_str rroot_times_root_assoc_p),
72.264 - Thm ("rsqare",num_str rsqare),
72.265 - Thm ("power_1",num_str power_1),
72.266 - Thm ("rtwo_of_the_same",num_str rtwo_of_the_same),
72.267 - Thm ("rtwo_of_the_same_assoc_p",num_str rtwo_of_the_same_assoc_p),
72.268 -
72.269 - Thm ("rmult_1",num_str rmult_1),
72.270 - Thm ("rmult_1_right",num_str rmult_1_right),
72.271 - Thm ("rmult_0",num_str rmult_0),
72.272 - Thm ("rmult_0_right",num_str rmult_0_right),
72.273 - Thm ("radd_0",num_str radd_0),
72.274 - Thm ("radd_0_right",num_str radd_0_right)
72.275 - ],
72.276 - scr = Script ((term_of o the o (parse thy)) "empty_script")
72.277 - (*since 040209 filled by prep_rls: STest_simplify*)
72.278 - }:rls;
72.279 -
72.280 -
72.281 -
72.282 -
72.283 -
72.284 -(** rule sets **)
72.285 -
72.286 -
72.287 -
72.288 -(*isolate the root in a root-equation*)
72.289 -val isolate_root =
72.290 - Rls{id = "isolate_root", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
72.291 - erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *)
72.292 - rules = [Thm ("rroot_to_lhs",num_str rroot_to_lhs),
72.293 - Thm ("rroot_to_lhs_mult",num_str rroot_to_lhs_mult),
72.294 - Thm ("rroot_to_lhs_add_mult",num_str rroot_to_lhs_add_mult),
72.295 - Thm ("risolate_root_add",num_str risolate_root_add),
72.296 - Thm ("risolate_root_mult",num_str risolate_root_mult),
72.297 - Thm ("risolate_root_div",num_str risolate_root_div) ],
72.298 - scr = Script ((term_of o the o (parse thy))
72.299 - "empty_script")
72.300 - }:rls;
72.301 -
72.302 -(*isolate the bound variable in an equation; 'bdv' is a meta-constant*)
72.303 -val isolate_bdv =
72.304 - Rls{id = "isolate_bdv", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
72.305 - erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *)
72.306 - rules =
72.307 - [Thm ("risolate_bdv_add",num_str risolate_bdv_add),
72.308 - Thm ("risolate_bdv_mult_add",num_str risolate_bdv_mult_add),
72.309 - Thm ("risolate_bdv_mult",num_str risolate_bdv_mult),
72.310 - Thm ("mult_square",num_str mult_square),
72.311 - Thm ("constant_square",num_str constant_square),
72.312 - Thm ("constant_mult_square",num_str constant_mult_square)
72.313 - ],
72.314 - scr = Script ((term_of o the o (parse thy))
72.315 - "empty_script")
72.316 - }:rls;
72.317 -
72.318 -
72.319 -
72.320 -
72.321 -(* association list for calculate_, calculate
72.322 - "op +" etc. not usable in scripts *)
72.323 -val calclist =
72.324 - [
72.325 - (*as Tools.ML*)
72.326 - ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")),
72.327 - ("matches",("Tools.matches",eval_matches "#matches_")),
72.328 - ("lhs" ,("Tools.lhs" ,eval_lhs "")),
72.329 - (*aus Atools.ML*)
72.330 - ("PLUS" ,("op +" ,eval_binop "#add_")),
72.331 - ("TIMES" ,("op *" ,eval_binop "#mult_")),
72.332 - ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
72.333 - ("POWER" ,("Atools.pow" ,eval_binop "#power_")),
72.334 - ("is_const",("Atools.is'_const",eval_const "#is_const_")),
72.335 - ("le" ,("op <" ,eval_equ "#less_")),
72.336 - ("leq" ,("op <=" ,eval_equ "#less_equal_")),
72.337 - ("ident" ,("Atools.ident",eval_ident "#ident_")),
72.338 - (*von hier (ehem.SqRoot*)
72.339 - ("sqrt" ,("Root.sqrt" ,eval_sqrt "#sqrt_")),
72.340 - ("Test.is_root_free",("is'_root'_free", eval_root_free"#is_root_free_")),
72.341 - ("Test.contains_root",("contains'_root",
72.342 - eval_contains_root"#contains_root_"))
72.343 - ];
72.344 -
72.345 -ruleset' := overwritelthy thy (!ruleset',
72.346 - [("Test_simplify", prep_rls Test_simplify),
72.347 - ("tval_rls", prep_rls tval_rls),
72.348 - ("isolate_root", prep_rls isolate_root),
72.349 - ("isolate_bdv", prep_rls isolate_bdv),
72.350 - ("matches",
72.351 - prep_rls (append_rls "matches" testerls
72.352 - [Calc ("Tools.matches",eval_matches "#matches_")]))
72.353 - ]);
72.354 -
72.355 -(** problem types **)
72.356 -store_pbt
72.357 - (prep_pbt Test.thy "pbl_test" [] e_pblID
72.358 - (["test"],
72.359 - [],
72.360 - e_rls, NONE, []));
72.361 -store_pbt
72.362 - (prep_pbt Test.thy "pbl_test_equ" [] e_pblID
72.363 - (["equation","test"],
72.364 - [("#Given" ,["equality e_","solveFor v_"]),
72.365 - ("#Where" ,["matches (?a = ?b) e_"]),
72.366 - ("#Find" ,["solutions v_i_"])
72.367 - ],
72.368 - assoc_rls "matches",
72.369 - SOME "solve (e_::bool, v_)", []));
72.370 -
72.371 -store_pbt
72.372 - (prep_pbt Test.thy "pbl_test_uni" [] e_pblID
72.373 - (["univariate","equation","test"],
72.374 - [("#Given" ,["equality e_","solveFor v_"]),
72.375 - ("#Where" ,["matches (?a = ?b) e_"]),
72.376 - ("#Find" ,["solutions v_i_"])
72.377 - ],
72.378 - assoc_rls "matches",
72.379 - SOME "solve (e_::bool, v_)", []));
72.380 -
72.381 -store_pbt
72.382 - (prep_pbt Test.thy "pbl_test_uni_lin" [] e_pblID
72.383 - (["linear","univariate","equation","test"],
72.384 - [("#Given" ,["equality e_","solveFor v_"]),
72.385 - ("#Where" ,["(matches ( v_ = 0) e_) | (matches ( ?b*v_ = 0) e_) |\
72.386 - \(matches (?a+v_ = 0) e_) | (matches (?a+?b*v_ = 0) e_) "]),
72.387 - ("#Find" ,["solutions v_i_"])
72.388 - ],
72.389 - assoc_rls "matches",
72.390 - SOME "solve (e_::bool, v_)", [["Test","solve_linear"]]));
72.391 -
72.392 -(*25.8.01 ------
72.393 -store_pbt
72.394 - (prep_pbt Test.thy
72.395 - (["Test.thy"],
72.396 - [("#Given" ,"boolTestGiven g_"),
72.397 - ("#Find" ,"boolTestFind f_")
72.398 - ],
72.399 - []));
72.400 -
72.401 -store_pbt
72.402 - (prep_pbt Test.thy
72.403 - (["testeq","Test.thy"],
72.404 - [("#Given" ,"boolTestGiven g_"),
72.405 - ("#Find" ,"boolTestFind f_")
72.406 - ],
72.407 - []));
72.408 -
72.409 -
72.410 -val ttt = (term_of o the o (parse Isac.thy)) "(matches ( v_ = 0) e_)";
72.411 -
72.412 - ------ 25.8.01*)
72.413 -
72.414 -
72.415 -(** methods **)
72.416 -store_met
72.417 - (prep_met Diff.thy "met_test" [] e_metID
72.418 - (["Test"],
72.419 - [],
72.420 - {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
72.421 - crls=Atools_erls, nrls=e_rls(*,
72.422 - asm_rls=[],asm_thm=[]*)}, "empty_script"));
72.423 -(*
72.424 -store_met
72.425 - (prep_met Script.thy
72.426 - (e_metID,(*empty method*)
72.427 - [],
72.428 - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
72.429 - asm_rls=[],asm_thm=[]},
72.430 - "Undef"));*)
72.431 -store_met
72.432 - (prep_met Test.thy "met_test_solvelin" [] e_metID
72.433 - (["Test","solve_linear"]:metID,
72.434 - [("#Given" ,["equality e_","solveFor v_"]),
72.435 - ("#Where" ,["matches (?a = ?b) e_"]),
72.436 - ("#Find" ,["solutions v_i_"])
72.437 - ],
72.438 - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,
72.439 - prls=assoc_rls "matches",
72.440 - calc=[],
72.441 - crls=tval_rls, nrls=Test_simplify},
72.442 - "Script Solve_linear (e_::bool) (v_::real)= \
72.443 - \(let e_ =\
72.444 - \ Repeat\
72.445 - \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
72.446 - \ (Rewrite_Set Test_simplify False))) e_\
72.447 - \ in [e_::bool])"
72.448 - )
72.449 -(*, prep_met Test.thy (*test for equations*)
72.450 - (["Test","testeq"]:metID,
72.451 - [("#Given" ,["boolTestGiven g_"]),
72.452 - ("#Find" ,["boolTestFind f_"])
72.453 - ],
72.454 - {rew_ord'="e_rew_ord",rls'="tval_rls",asm_rls=[],
72.455 - asm_thm=[("square_equation_left","")]},
72.456 - "Script Testeq (eq_::bool) = \
72.457 - \Repeat \
72.458 - \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False eq_)); \
72.459 - \ e_ = Try (Repeat (Rewrite square_equation_left True e_)); \
72.460 - \ e_ = Try (Repeat (Rewrite rmult_0 False e_)) \
72.461 - \ in e_) Until (is_root_free e_)" (*deleted*)
72.462 - )
72.463 -, ---------27.4.02*)
72.464 -);
72.465 -
72.466 -
72.467 -
72.468 -
72.469 -ruleset' := overwritelthy thy (!ruleset',
72.470 - [("norm_equation", prep_rls norm_equation),
72.471 - ("ac_plus_times", prep_rls ac_plus_times),
72.472 - ("rearrange_assoc", prep_rls rearrange_assoc)
72.473 - ]);
72.474 -
72.475 -
72.476 -fun bin_o (Const (op_,(Type ("fun",
72.477 - [Type (s2,[]),Type ("fun",
72.478 - [Type (s4,tl4),Type (s5,tl5)])])))) =
72.479 - if (s2=s4)andalso(s4=s5)then[op_]else[]
72.480 - | bin_o _ = [];
72.481 -
72.482 -fun bin_op (t1 $ t2) = union op = (bin_op t1) (bin_op t2)
72.483 - | bin_op t = bin_o t;
72.484 -fun is_bin_op t = ((bin_op t)<>[]);
72.485 -
72.486 -fun bin_op_arg1 ((Const (op_,(Type ("fun",
72.487 - [Type (s2,[]),Type ("fun",
72.488 - [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) =
72.489 - arg1;
72.490 -fun bin_op_arg2 ((Const (op_,(Type ("fun",
72.491 - [Type (s2,[]),Type ("fun",
72.492 - [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) =
72.493 - arg2;
72.494 -
72.495 -
72.496 -exception NO_EQUATION_TERM;
72.497 -fun is_equation ((Const ("op =",(Type ("fun",
72.498 - [Type (_,[]),Type ("fun",
72.499 - [Type (_,[]),Type ("bool",[])])])))) $ _ $ _)
72.500 - = true
72.501 - | is_equation _ = false;
72.502 -fun equ_lhs ((Const ("op =",(Type ("fun",
72.503 - [Type (_,[]),Type ("fun",
72.504 - [Type (_,[]),Type ("bool",[])])])))) $ l $ r)
72.505 - = l
72.506 - | equ_lhs _ = raise NO_EQUATION_TERM;
72.507 -fun equ_rhs ((Const ("op =",(Type ("fun",
72.508 - [Type (_,[]),Type ("fun",
72.509 - [Type (_,[]),Type ("bool",[])])])))) $ l $ r)
72.510 - = r
72.511 - | equ_rhs _ = raise NO_EQUATION_TERM;
72.512 -
72.513 -
72.514 -fun atom (Const (_,Type (_,[]))) = true
72.515 - | atom (Free (_,Type (_,[]))) = true
72.516 - | atom (Var (_,Type (_,[]))) = true
72.517 -(*| atom (_ (_,"?DUMMY" )) = true ..ML-error *)
72.518 - | atom((Const ("Bin.integ_of_bin",_)) $ _) = true
72.519 - | atom _ = false;
72.520 -
72.521 -fun varids (Const (s,Type (_,[]))) = [strip_thy s]
72.522 - | varids (Free (s,Type (_,[]))) = if is_no s then []
72.523 - else [strip_thy s]
72.524 - | varids (Var((s,_),Type (_,[]))) = [strip_thy s]
72.525 -(*| varids (_ (s,"?DUMMY" )) = ..ML-error *)
72.526 - | varids((Const ("Bin.integ_of_bin",_)) $ _)= [](*8.01: superfluous?*)
72.527 - | varids (Abs(a,T,t)) = union op = [a] (varids t)
72.528 - | varids (t1 $ t2) = union op = (varids t1) (varids t2)
72.529 - | varids _ = [];
72.530 -(*> val t = term_of (hd (parse Diophant.thy "x"));
72.531 -val t = Free ("x","?DUMMY") : term
72.532 -> varids t;
72.533 -val it = [] : string list [] !!! *)
72.534 -
72.535 -
72.536 -fun bin_ops_only ((Const op_) $ t1 $ t2) =
72.537 - if(is_bin_op (Const op_))
72.538 - then(bin_ops_only t1)andalso(bin_ops_only t2)
72.539 - else false
72.540 - | bin_ops_only t =
72.541 - if atom t then true else bin_ops_only t;
72.542 -
72.543 -fun polynomial opl t bdVar = (* bdVar TODO *)
72.544 - subset op = (bin_op t, opl) andalso (bin_ops_only t);
72.545 -
72.546 -fun poly_equ opl bdVar t = is_equation t (* bdVar TODO *)
72.547 - andalso polynomial opl (equ_lhs t) bdVar
72.548 - andalso polynomial opl (equ_rhs t) bdVar
72.549 - andalso (subset op = (varids bdVar, varids (equ_lhs t)) orelse
72.550 - subset op = (varids bdVar, varids (equ_lhs t)));
72.551 -
72.552 -(*fun max is =
72.553 - let fun max_ m [] = m
72.554 - | max_ m (i::is) = if m<i then max_ i is else max_ m is;
72.555 - in max_ (hd is) is end;
72.556 -> max [1,5,3,7,4,2];
72.557 -val it = 7 : int *)
72.558 -
72.559 -fun max (a,b) = if a < b then b else a;
72.560 -
72.561 -fun degree addl mul bdVar t =
72.562 -let
72.563 -fun deg _ _ v (Const (s,Type (_,[]))) = if v=strip_thy s then 1 else 0
72.564 - | deg _ _ v (Free (s,Type (_,[]))) = if v=strip_thy s then 1 else 0
72.565 - | deg _ _ v (Var((s,_),Type (_,[]))) = if v=strip_thy s then 1 else 0
72.566 -(*| deg _ _ v (_ (s,"?DUMMY" )) = ..ML-error *)
72.567 - | deg _ _ v((Const ("Bin.integ_of_bin",_)) $ _ )= 0
72.568 - | deg addl mul v (h $ t1 $ t2) =
72.569 - if subset op = (bin_op h, addl)
72.570 - then max (deg addl mul v t1 ,deg addl mul v t2)
72.571 - else (*mul!*)(deg addl mul v t1)+(deg addl mul v t2)
72.572 -in if polynomial (addl @ [mul]) t bdVar
72.573 - then SOME (deg addl mul (id_of bdVar) t) else (NONE:int option)
72.574 -end;
72.575 -fun degree_ addl mul bdVar t = (* do not export *)
72.576 - let fun opt (SOME i)= i
72.577 - | opt NONE = 0
72.578 -in opt (degree addl mul bdVar t) end;
72.579 -
72.580 -
72.581 -fun linear addl mul t bdVar = (degree_ addl mul bdVar t)<2;
72.582 -
72.583 -fun linear_equ addl mul bdVar t =
72.584 - if is_equation t
72.585 - then let val degl = degree_ addl mul bdVar (equ_lhs t);
72.586 - val degr = degree_ addl mul bdVar (equ_rhs t)
72.587 - in if (degl>0 orelse degr>0)andalso max(degl,degr)<2
72.588 - then true else false
72.589 - end
72.590 - else false;
72.591 -(* strip_thy op_ before *)
72.592 -fun is_div_op (dv,(Const (op_,(Type ("fun",
72.593 - [Type (s2,[]),Type ("fun",
72.594 - [Type (s4,tl4),Type (s5,tl5)])])))) )= (dv = strip_thy op_)
72.595 - | is_div_op _ = false;
72.596 -
72.597 -fun is_denom bdVar div_op t =
72.598 - let fun is bool[v]dv (Const (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
72.599 - | is bool[v]dv (Free (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
72.600 - | is bool[v]dv (Var((s,_),Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
72.601 - | is bool[v]dv((Const ("Bin.integ_of_bin",_)) $ _) = false
72.602 - | is bool[v]dv (h$n$d) =
72.603 - if is_div_op(dv,h)
72.604 - then (is false[v]dv n)orelse(is true[v]dv d)
72.605 - else (is bool [v]dv n)orelse(is bool[v]dv d)
72.606 -in is false (varids bdVar) (strip_thy div_op) t end;
72.607 -
72.608 -
72.609 -fun rational t div_op bdVar =
72.610 - is_denom bdVar div_op t andalso bin_ops_only t;
72.611 -
72.612 -
72.613 -
72.614 -(** problem types **)
72.615 -
72.616 -store_pbt
72.617 - (prep_pbt Test.thy "pbl_test_uni_plain2" [] e_pblID
72.618 - (["plain_square","univariate","equation","test"],
72.619 - [("#Given" ,["equality e_","solveFor v_"]),
72.620 - ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\
72.621 - \(matches ( ?b*v_ ^^^2 = 0) e_) |\
72.622 - \(matches (?a + v_ ^^^2 = 0) e_) |\
72.623 - \(matches ( v_ ^^^2 = 0) e_)"]),
72.624 - ("#Find" ,["solutions v_i_"])
72.625 - ],
72.626 - assoc_rls "matches",
72.627 - SOME "solve (e_::bool, v_)", [["Test","solve_plain_square"]]));
72.628 -(*
72.629 - val e_ = (term_of o the o (parse thy)) "e_::bool";
72.630 - val ve = (term_of o the o (parse thy)) "4 + 3*x^^^2 = 0";
72.631 - val env = [(e_,ve)];
72.632 -
72.633 - val pre = (term_of o the o (parse thy))
72.634 - "(matches (a + b*v_ ^^^2 = 0, e_::bool)) |\
72.635 - \(matches ( b*v_ ^^^2 = 0, e_::bool)) |\
72.636 - \(matches (a + v_ ^^^2 = 0, e_::bool)) |\
72.637 - \(matches ( v_ ^^^2 = 0, e_::bool))";
72.638 - val prei = subst_atomic env pre;
72.639 - val cpre = (cterm_of thy) prei;
72.640 -
72.641 - val SOME (ct,_) = rewrite_set_ thy false tval_rls cpre;
72.642 -val ct = "True | False | False | False" : cterm
72.643 -
72.644 -> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
72.645 -> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
72.646 -> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
72.647 -val ct = "True" : cterm
72.648 -
72.649 -*)
72.650 -
72.651 -store_pbt
72.652 - (prep_pbt Test.thy "pbl_test_uni_poly" [] e_pblID
72.653 - (["polynomial","univariate","equation","test"],
72.654 - [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]),
72.655 - ("#Where" ,["False"]),
72.656 - ("#Find" ,["solutions v_i_"])
72.657 - ],
72.658 - e_rls, SOME "solve (e_::bool, v_)", []));
72.659 -
72.660 -store_pbt
72.661 - (prep_pbt Test.thy "pbl_test_uni_poly_deg2" [] e_pblID
72.662 - (["degree_two","polynomial","univariate","equation","test"],
72.663 - [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]),
72.664 - ("#Find" ,["solutions v_i_"])
72.665 - ],
72.666 - e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", []));
72.667 -
72.668 -store_pbt
72.669 - (prep_pbt Test.thy "pbl_test_uni_poly_deg2_pq" [] e_pblID
72.670 - (["pq_formula","degree_two","polynomial","univariate","equation","test"],
72.671 - [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]),
72.672 - ("#Find" ,["solutions v_i_"])
72.673 - ],
72.674 - e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", []));
72.675 -
72.676 -store_pbt
72.677 - (prep_pbt Test.thy "pbl_test_uni_poly_deg2_abc" [] e_pblID
72.678 - (["abc_formula","degree_two","polynomial","univariate","equation","test"],
72.679 - [("#Given" ,["equality (a_ * x ^^^2 + b_ * x + c_ = 0)","solveFor v_"]),
72.680 - ("#Find" ,["solutions v_i_"])
72.681 - ],
72.682 - e_rls, SOME "solve (a_ * x ^^^2 + b_ * x + c_ = 0, v_)", []));
72.683 -
72.684 -store_pbt
72.685 - (prep_pbt Test.thy "pbl_test_uni_root" [] e_pblID
72.686 - (["squareroot","univariate","equation","test"],
72.687 - [("#Given" ,["equality e_","solveFor v_"]),
72.688 - ("#Where" ,["contains_root (e_::bool)"]),
72.689 - ("#Find" ,["solutions v_i_"])
72.690 - ],
72.691 - append_rls "contains_root" e_rls [Calc ("Test.contains'_root",
72.692 - eval_contains_root "#contains_root_")],
72.693 - SOME "solve (e_::bool, v_)", [["Test","square_equation"]]));
72.694 -
72.695 -store_pbt
72.696 - (prep_pbt Test.thy "pbl_test_uni_norm" [] e_pblID
72.697 - (["normalize","univariate","equation","test"],
72.698 - [("#Given" ,["equality e_","solveFor v_"]),
72.699 - ("#Where" ,[]),
72.700 - ("#Find" ,["solutions v_i_"])
72.701 - ],
72.702 - e_rls, SOME "solve (e_::bool, v_)", [["Test","norm_univar_equation"]]));
72.703 -
72.704 -store_pbt
72.705 - (prep_pbt Test.thy "pbl_test_uni_roottest" [] e_pblID
72.706 - (["sqroot-test","univariate","equation","test"],
72.707 - [("#Given" ,["equality e_","solveFor v_"]),
72.708 - (*("#Where" ,["contains_root (e_::bool)"]),*)
72.709 - ("#Find" ,["solutions v_i_"])
72.710 - ],
72.711 - e_rls, SOME "solve (e_::bool, v_)", []));
72.712 -
72.713 -(*
72.714 -(#ppc o get_pbt) ["sqroot-test","univariate","equation"];
72.715 - *)
72.716 -
72.717 -
72.718 -store_met
72.719 - (prep_met Test.thy "met_test_sqrt" [] e_metID
72.720 -(*root-equation, version for tests before 8.01.01*)
72.721 - (["Test","sqrt-equ-test"]:metID,
72.722 - [("#Given" ,["equality e_","solveFor v_"]),
72.723 - ("#Where" ,["contains_root (e_::bool)"]),
72.724 - ("#Find" ,["solutions v_i_"])
72.725 - ],
72.726 - {rew_ord'="e_rew_ord",rls'=tval_rls,
72.727 - srls =append_rls "srls_contains_root" e_rls
72.728 - [Calc ("Test.contains'_root",eval_contains_root "")],
72.729 - prls =append_rls "prls_contains_root" e_rls
72.730 - [Calc ("Test.contains'_root",eval_contains_root "")],
72.731 - calc=[],
72.732 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],
72.733 - asm_thm=[("square_equation_left",""),
72.734 - ("square_equation_right","")]*)},
72.735 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.736 - \(let e_ = \
72.737 - \ ((While (contains_root e_) Do\
72.738 - \ ((Rewrite square_equation_left True) @@\
72.739 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.740 - \ (Try (Rewrite_Set rearrange_assoc False)) @@\
72.741 - \ (Try (Rewrite_Set isolate_root False)) @@\
72.742 - \ (Try (Rewrite_Set Test_simplify False)))) @@\
72.743 - \ (Try (Rewrite_Set norm_equation False)) @@\
72.744 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.745 - \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
72.746 - \ (Try (Rewrite_Set Test_simplify False)))\
72.747 - \ e_\
72.748 - \ in [e_::bool])"
72.749 - ));
72.750 -
72.751 -store_met
72.752 - (prep_met Test.thy "met_test_sqrt2" [] e_metID
72.753 -(*root-equation ... for test-*.sml until 8.01*)
72.754 - (["Test","squ-equ-test2"]:metID,
72.755 - [("#Given" ,["equality e_","solveFor v_"]),
72.756 - ("#Find" ,["solutions v_i_"])
72.757 - ],
72.758 - {rew_ord'="e_rew_ord",rls'=tval_rls,
72.759 - srls = append_rls "srls_contains_root" e_rls
72.760 - [Calc ("Test.contains'_root",eval_contains_root"")],
72.761 - prls=e_rls,calc=[],
72.762 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],
72.763 - asm_thm=[("square_equation_left",""),
72.764 - ("square_equation_right","")]*)},
72.765 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.766 - \(let e_ = \
72.767 - \ ((While (contains_root e_) Do\
72.768 - \ ((Rewrite square_equation_left True) @@\
72.769 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.770 - \ (Try (Rewrite_Set rearrange_assoc False)) @@\
72.771 - \ (Try (Rewrite_Set isolate_root False)) @@\
72.772 - \ (Try (Rewrite_Set Test_simplify False)))) @@\
72.773 - \ (Try (Rewrite_Set norm_equation False)) @@\
72.774 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.775 - \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
72.776 - \ (Try (Rewrite_Set Test_simplify False)))\
72.777 - \ e_;\
72.778 - \ (L_::bool list) = Tac subproblem_equation_dummy; \
72.779 - \ L_ = Tac solve_equation_dummy \
72.780 - \ in Check_elementwise L_ {(v_::real). Assumptions})"
72.781 - ));
72.782 -
72.783 -store_met
72.784 - (prep_met Test.thy "met_test_squ_sub" [] e_metID
72.785 -(*tests subproblem fixed linear*)
72.786 - (["Test","squ-equ-test-subpbl1"]:metID,
72.787 - [("#Given" ,["equality e_","solveFor v_"]),
72.788 - ("#Find" ,["solutions v_i_"])
72.789 - ],
72.790 - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
72.791 - crls=tval_rls, nrls=Test_simplify},
72.792 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.793 - \ (let e_ = ((Try (Rewrite_Set norm_equation False)) @@ \
72.794 - \ (Try (Rewrite_Set Test_simplify False))) e_; \
72.795 - \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
72.796 - \ [Test,solve_linear]) [bool_ e_, real_ v_])\
72.797 - \in Check_elementwise L_ {(v_::real). Assumptions})"
72.798 - ));
72.799 -
72.800 -store_met
72.801 - (prep_met Test.thy "met_test_squ_sub2" [] e_metID
72.802 - (*tests subproblem fixed degree 2*)
72.803 - (["Test","squ-equ-test-subpbl2"]:metID,
72.804 - [("#Given" ,["equality e_","solveFor v_"]),
72.805 - ("#Find" ,["solutions v_i_"])
72.806 - ],
72.807 - {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
72.808 - crls=tval_rls, nrls=e_rls(*,
72.809 - asm_rls=[],asm_thm=[("square_equation_left",""),
72.810 - ("square_equation_right","")]*)},
72.811 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.812 - \ (let e_ = Try (Rewrite_Set norm_equation False) e_; \
72.813 - \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
72.814 - \ [Test,solve_by_pq_formula]) [bool_ e_, real_ v_])\
72.815 - \in Check_elementwise L_ {(v_::real). Assumptions})"
72.816 - ));
72.817 -
72.818 -store_met
72.819 - (prep_met Test.thy "met_test_squ_nonterm" [] e_metID
72.820 - (*root-equation: see foils..., but notTerminating*)
72.821 - (["Test","square_equation...notTerminating"]:metID,
72.822 - [("#Given" ,["equality e_","solveFor v_"]),
72.823 - ("#Find" ,["solutions v_i_"])
72.824 - ],
72.825 - {rew_ord'="e_rew_ord",rls'=tval_rls,
72.826 - srls = append_rls "srls_contains_root" e_rls
72.827 - [Calc ("Test.contains'_root",eval_contains_root"")],
72.828 - prls=e_rls,calc=[],
72.829 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],
72.830 - asm_thm=[("square_equation_left",""),
72.831 - ("square_equation_right","")]*)},
72.832 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.833 - \(let e_ = \
72.834 - \ ((While (contains_root e_) Do\
72.835 - \ ((Rewrite square_equation_left True) @@\
72.836 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.837 - \ (Try (Rewrite_Set rearrange_assoc False)) @@\
72.838 - \ (Try (Rewrite_Set isolate_root False)) @@\
72.839 - \ (Try (Rewrite_Set Test_simplify False)))) @@\
72.840 - \ (Try (Rewrite_Set norm_equation False)) @@\
72.841 - \ (Try (Rewrite_Set Test_simplify False)))\
72.842 - \ e_;\
72.843 - \ (L_::bool list) = \
72.844 - \ (SubProblem (Test_,[linear,univariate,equation,test],\
72.845 - \ [Test,solve_linear]) [bool_ e_, real_ v_])\
72.846 - \in Check_elementwise L_ {(v_::real). Assumptions})"
72.847 - ));
72.848 -
72.849 -store_met
72.850 - (prep_met Test.thy "met_test_eq1" [] e_metID
72.851 -(*root-equation1:*)
72.852 - (["Test","square_equation1"]:metID,
72.853 - [("#Given" ,["equality e_","solveFor v_"]),
72.854 - ("#Find" ,["solutions v_i_"])
72.855 - ],
72.856 - {rew_ord'="e_rew_ord",rls'=tval_rls,
72.857 - srls = append_rls "srls_contains_root" e_rls
72.858 - [Calc ("Test.contains'_root",eval_contains_root"")],
72.859 - prls=e_rls,calc=[],
72.860 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],
72.861 - asm_thm=[("square_equation_left",""),
72.862 - ("square_equation_right","")]*)},
72.863 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.864 - \(let e_ = \
72.865 - \ ((While (contains_root e_) Do\
72.866 - \ ((Rewrite square_equation_left True) @@\
72.867 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.868 - \ (Try (Rewrite_Set rearrange_assoc False)) @@\
72.869 - \ (Try (Rewrite_Set isolate_root False)) @@\
72.870 - \ (Try (Rewrite_Set Test_simplify False)))) @@\
72.871 - \ (Try (Rewrite_Set norm_equation False)) @@\
72.872 - \ (Try (Rewrite_Set Test_simplify False)))\
72.873 - \ e_;\
72.874 - \ (L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
72.875 - \ [Test,solve_linear]) [bool_ e_, real_ v_])\
72.876 - \ in Check_elementwise L_ {(v_::real). Assumptions})"
72.877 - ));
72.878 -
72.879 -store_met
72.880 - (prep_met Test.thy "met_test_squ2" [] e_metID
72.881 - (*root-equation2*)
72.882 - (["Test","square_equation2"]:metID,
72.883 - [("#Given" ,["equality e_","solveFor v_"]),
72.884 - ("#Find" ,["solutions v_i_"])
72.885 - ],
72.886 - {rew_ord'="e_rew_ord",rls'=tval_rls,
72.887 - srls = append_rls "srls_contains_root" e_rls
72.888 - [Calc ("Test.contains'_root",eval_contains_root"")],
72.889 - prls=e_rls,calc=[],
72.890 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],
72.891 - asm_thm=[("square_equation_left",""),
72.892 - ("square_equation_right","")]*)},
72.893 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.894 - \(let e_ = \
72.895 - \ ((While (contains_root e_) Do\
72.896 - \ (((Rewrite square_equation_left True) Or \
72.897 - \ (Rewrite square_equation_right True)) @@\
72.898 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.899 - \ (Try (Rewrite_Set rearrange_assoc False)) @@\
72.900 - \ (Try (Rewrite_Set isolate_root False)) @@\
72.901 - \ (Try (Rewrite_Set Test_simplify False)))) @@\
72.902 - \ (Try (Rewrite_Set norm_equation False)) @@\
72.903 - \ (Try (Rewrite_Set Test_simplify False)))\
72.904 - \ e_;\
72.905 - \ (L_::bool list) = (SubProblem (Test_,[plain_square,univariate,equation,test],\
72.906 - \ [Test,solve_plain_square]) [bool_ e_, real_ v_])\
72.907 - \ in Check_elementwise L_ {(v_::real). Assumptions})"
72.908 - ));
72.909 -
72.910 -store_met
72.911 - (prep_met Test.thy "met_test_squeq" [] e_metID
72.912 - (*root-equation*)
72.913 - (["Test","square_equation"]:metID,
72.914 - [("#Given" ,["equality e_","solveFor v_"]),
72.915 - ("#Find" ,["solutions v_i_"])
72.916 - ],
72.917 - {rew_ord'="e_rew_ord",rls'=tval_rls,
72.918 - srls = append_rls "srls_contains_root" e_rls
72.919 - [Calc ("Test.contains'_root",eval_contains_root"")],
72.920 - prls=e_rls,calc=[],
72.921 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],
72.922 - asm_thm=[("square_equation_left",""),
72.923 - ("square_equation_right","")]*)},
72.924 - "Script Solve_root_equation (e_::bool) (v_::real) = \
72.925 - \(let e_ = \
72.926 - \ ((While (contains_root e_) Do\
72.927 - \ (((Rewrite square_equation_left True) Or\
72.928 - \ (Rewrite square_equation_right True)) @@\
72.929 - \ (Try (Rewrite_Set Test_simplify False)) @@\
72.930 - \ (Try (Rewrite_Set rearrange_assoc False)) @@\
72.931 - \ (Try (Rewrite_Set isolate_root False)) @@\
72.932 - \ (Try (Rewrite_Set Test_simplify False)))) @@\
72.933 - \ (Try (Rewrite_Set norm_equation False)) @@\
72.934 - \ (Try (Rewrite_Set Test_simplify False)))\
72.935 - \ e_;\
72.936 - \ (L_::bool list) = (SubProblem (Test_,[univariate,equation,test],\
72.937 - \ [no_met]) [bool_ e_, real_ v_])\
72.938 - \ in Check_elementwise L_ {(v_::real). Assumptions})"
72.939 - ) ); (*#######*)
72.940 -
72.941 -store_met
72.942 - (prep_met Test.thy "met_test_eq_plain" [] e_metID
72.943 - (*solve_plain_square*)
72.944 - (["Test","solve_plain_square"]:metID,
72.945 - [("#Given",["equality e_","solveFor v_"]),
72.946 - ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\
72.947 - \(matches ( ?b*v_ ^^^2 = 0) e_) |\
72.948 - \(matches (?a + v_ ^^^2 = 0) e_) |\
72.949 - \(matches ( v_ ^^^2 = 0) e_)"]),
72.950 - ("#Find" ,["solutions v_i_"])
72.951 - ],
72.952 - {rew_ord'="e_rew_ord",rls'=tval_rls,calc=[],srls=e_rls,
72.953 - prls = assoc_rls "matches",
72.954 - crls=tval_rls, nrls=e_rls(*,
72.955 - asm_rls=[],asm_thm=[]*)},
72.956 - "Script Solve_plain_square (e_::bool) (v_::real) = \
72.957 - \ (let e_ = ((Try (Rewrite_Set isolate_bdv False)) @@ \
72.958 - \ (Try (Rewrite_Set Test_simplify False)) @@ \
72.959 - \ ((Rewrite square_equality_0 False) Or \
72.960 - \ (Rewrite square_equality True)) @@ \
72.961 - \ (Try (Rewrite_Set tval_rls False))) e_ \
72.962 - \ in ((Or_to_List e_)::bool list))"
72.963 - ));
72.964 -
72.965 -store_met
72.966 - (prep_met Test.thy "met_test_norm_univ" [] e_metID
72.967 - (["Test","norm_univar_equation"]:metID,
72.968 - [("#Given",["equality e_","solveFor v_"]),
72.969 - ("#Where" ,[]),
72.970 - ("#Find" ,["solutions v_i_"])
72.971 - ],
72.972 - {rew_ord'="e_rew_ord",rls'=tval_rls,srls = e_rls,prls=e_rls,
72.973 - calc=[],
72.974 - crls=tval_rls, nrls=e_rls(*,asm_rls=[],asm_thm=[]*)},
72.975 - "Script Norm_univar_equation (e_::bool) (v_::real) = \
72.976 - \ (let e_ = ((Try (Rewrite rnorm_equation_add False)) @@ \
72.977 - \ (Try (Rewrite_Set Test_simplify False))) e_ \
72.978 - \ in (SubProblem (Test_,[univariate,equation,test], \
72.979 - \ [no_met]) [bool_ e_, real_ v_]))"
72.980 - ));
72.981 -
72.982 -
72.983 -
72.984 -(*17.9.02 aus SqRoot.ML------------------------------^^^---*)
72.985 -
72.986 -(*8.4.03 aus Poly.ML--------------------------------vvv---
72.987 - make_polynomial ---> make_poly
72.988 - ^-- for user ^-- for systest _ONLY_*)
72.989 -
72.990 -local (*. for make_polytest .*)
72.991 -
72.992 -open Term; (* for type order = EQUAL | LESS | GREATER *)
72.993 -
72.994 -fun pr_ord EQUAL = "EQUAL"
72.995 - | pr_ord LESS = "LESS"
72.996 - | pr_ord GREATER = "GREATER";
72.997 -
72.998 -fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
72.999 - (case a of
72.1000 - "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest *)
72.1001 - | _ => (((a, 0), T), 0))
72.1002 - | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
72.1003 - | dest_hd' (Var v) = (v, 2)
72.1004 - | dest_hd' (Bound i) = ((("", i), dummyT), 3)
72.1005 - | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
72.1006 -(* RL *)
72.1007 -fun get_order_pow (t $ (Free(order,_))) =
72.1008 - (case int_of_str (order) of
72.1009 - SOME d => d
72.1010 - | NONE => 0)
72.1011 - | get_order_pow _ = 0;
72.1012 -
72.1013 -fun size_of_term' (Const(str,_) $ t) =
72.1014 - if "Atools.pow"= str then 1000 + size_of_term' t else 1 + size_of_term' t (*WN*)
72.1015 - | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
72.1016 - | size_of_term' (f$t) = size_of_term' f + size_of_term' t
72.1017 - | size_of_term' _ = 1;
72.1018 -
72.1019 -fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
72.1020 - (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
72.1021 - | term_ord' pr thy (t, u) =
72.1022 - (if pr then
72.1023 - let
72.1024 - val (f, ts) = strip_comb t and (g, us) = strip_comb u;
72.1025 - val _=writeln("t= f@ts= \""^
72.1026 - ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
72.1027 - (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\"");
72.1028 - val _=writeln("u= g@us= \""^
72.1029 - ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
72.1030 - (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\"");
72.1031 - val _=writeln("size_of_term(t,u)= ("^
72.1032 - (string_of_int(size_of_term' t))^", "^
72.1033 - (string_of_int(size_of_term' u))^")");
72.1034 - val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
72.1035 - val _=writeln("terms_ord(ts,us) = "^
72.1036 - ((pr_ord o terms_ord str false)(ts,us)));
72.1037 - val _=writeln("-------");
72.1038 - in () end
72.1039 - else ();
72.1040 - case int_ord (size_of_term' t, size_of_term' u) of
72.1041 - EQUAL =>
72.1042 - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
72.1043 - (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
72.1044 - | ord => ord)
72.1045 - end
72.1046 - | ord => ord)
72.1047 -and hd_ord (f, g) = (* ~ term.ML *)
72.1048 - prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
72.1049 -and terms_ord str pr (ts, us) =
72.1050 - list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
72.1051 -in
72.1052 -
72.1053 -fun ord_make_polytest (pr:bool) thy (_:subst) tu =
72.1054 - (term_ord' pr thy(***) tu = LESS );
72.1055 -
72.1056 -end;(*local*)
72.1057 -
72.1058 -rew_ord' := overwritel (!rew_ord',
72.1059 -[("termlessI", termlessI),
72.1060 - ("ord_make_polytest", ord_make_polytest false thy)
72.1061 - ]);
72.1062 -
72.1063 -(*WN060510 this was a preparation for prep_rls ...
72.1064 -val scr_make_polytest =
72.1065 -"Script Expand_binomtest t_ =\
72.1066 -\(Repeat \
72.1067 -\((Try (Repeat (Rewrite real_diff_minus False))) @@ \
72.1068 -
72.1069 -\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \
72.1070 -\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \
72.1071 -\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \
72.1072 -\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \
72.1073 -
72.1074 -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
72.1075 -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
72.1076 -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
72.1077 -
72.1078 -\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \
72.1079 -\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \
72.1080 -\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \
72.1081 -\ (Try (Repeat (Rewrite real_add_commute False))) @@ \
72.1082 -\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \
72.1083 -\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \
72.1084 -
72.1085 -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
72.1086 -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
72.1087 -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
72.1088 -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
72.1089 -
72.1090 -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
72.1091 -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
72.1092 -
72.1093 -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
72.1094 -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
72.1095 -
72.1096 -\ (Try (Repeat (Calculate plus ))) @@ \
72.1097 -\ (Try (Repeat (Calculate times ))) @@ \
72.1098 -\ (Try (Repeat (Calculate power_)))) \
72.1099 -\ t_)";
72.1100 ------------------------------------------------------*)
72.1101 -
72.1102 -val make_polytest =
72.1103 - Rls{id = "make_polytest", preconds = []:term list, rew_ord = ("ord_make_polytest",
72.1104 - ord_make_polytest false Poly.thy),
72.1105 - erls = testerls, srls = Erls,
72.1106 - calc = [("PLUS" , ("op +", eval_binop "#add_")),
72.1107 - ("TIMES" , ("op *", eval_binop "#mult_")),
72.1108 - ("POWER", ("Atools.pow", eval_binop "#power_"))
72.1109 - ],
72.1110 - (*asm_thm = [],*)
72.1111 - rules = [Thm ("real_diff_minus",num_str real_diff_minus),
72.1112 - (*"a - b = a + (-1) * b"*)
72.1113 - Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
72.1114 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
72.1115 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
72.1116 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
72.1117 - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
72.1118 - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
72.1119 - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
72.1120 - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
72.1121 - Thm ("real_mult_1",num_str real_mult_1),
72.1122 - (*"1 * z = z"*)
72.1123 - Thm ("real_mult_0",num_str real_mult_0),
72.1124 - (*"0 * z = 0"*)
72.1125 - Thm ("real_add_zero_left",num_str real_add_zero_left),
72.1126 - (*"0 + z = z"*)
72.1127 -
72.1128 - (*AC-rewriting*)
72.1129 - Thm ("real_mult_commute",num_str real_mult_commute),
72.1130 - (* z * w = w * z *)
72.1131 - Thm ("real_mult_left_commute",num_str real_mult_left_commute),
72.1132 - (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
72.1133 - Thm ("real_mult_assoc",num_str real_mult_assoc),
72.1134 - (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
72.1135 - Thm ("real_add_commute",num_str real_add_commute),
72.1136 - (*z + w = w + z*)
72.1137 - Thm ("real_add_left_commute",num_str real_add_left_commute),
72.1138 - (*x + (y + z) = y + (x + z)*)
72.1139 - Thm ("real_add_assoc",num_str real_add_assoc),
72.1140 - (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
72.1141 -
72.1142 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
72.1143 - (*"r1 * r1 = r1 ^^^ 2"*)
72.1144 - Thm ("realpow_plus_1",num_str realpow_plus_1),
72.1145 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
72.1146 - Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
72.1147 - (*"z1 + z1 = 2 * z1"*)
72.1148 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
72.1149 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
72.1150 -
72.1151 - Thm ("real_num_collect",num_str real_num_collect),
72.1152 - (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
72.1153 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
72.1154 - (*"[| l is_const; m is_const |] ==>
72.1155 - l * n + (m * n + k) = (l + m) * n + k"*)
72.1156 - Thm ("real_one_collect",num_str real_one_collect),
72.1157 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
72.1158 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
72.1159 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
72.1160 -
72.1161 - Calc ("op +", eval_binop "#add_"),
72.1162 - Calc ("op *", eval_binop "#mult_"),
72.1163 - Calc ("Atools.pow", eval_binop "#power_")
72.1164 - ],
72.1165 - scr = EmptyScr(*Script ((term_of o the o (parse thy))
72.1166 - scr_make_polytest)*)
72.1167 - }:rls;
72.1168 -(*WN060510 this was done before 'fun prep_rls' ...
72.1169 -val scr_expand_binomtest =
72.1170 -"Script Expand_binomtest t_ =\
72.1171 -\(Repeat \
72.1172 -\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \
72.1173 -\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \
72.1174 -\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \
72.1175 -\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \
72.1176 -\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \
72.1177 -\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \
72.1178 -
72.1179 -\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
72.1180 -\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
72.1181 -\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
72.1182 -
72.1183 -\ (Try (Repeat (Calculate plus ))) @@ \
72.1184 -\ (Try (Repeat (Calculate times ))) @@ \
72.1185 -\ (Try (Repeat (Calculate power_))) @@ \
72.1186 -
72.1187 -\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
72.1188 -\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
72.1189 -\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
72.1190 -\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
72.1191 -
72.1192 -\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
72.1193 -\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
72.1194 -
72.1195 -\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
72.1196 -\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
72.1197 -
72.1198 -\ (Try (Repeat (Calculate plus ))) @@ \
72.1199 -\ (Try (Repeat (Calculate times ))) @@ \
72.1200 -\ (Try (Repeat (Calculate power_)))) \
72.1201 -\ t_)";
72.1202 -------------------------------------------------------*)
72.1203 -
72.1204 -val expand_binomtest =
72.1205 - Rls{id = "expand_binomtest", preconds = [],
72.1206 - rew_ord = ("termlessI",termlessI),
72.1207 - erls = testerls, srls = Erls,
72.1208 - calc = [("PLUS" , ("op +", eval_binop "#add_")),
72.1209 - ("TIMES" , ("op *", eval_binop "#mult_")),
72.1210 - ("POWER", ("Atools.pow", eval_binop "#power_"))
72.1211 - ],
72.1212 - (*asm_thm = [],*)
72.1213 - rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
72.1214 - (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
72.1215 - Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
72.1216 - (*"(a + b)*(a + b) = ...*)
72.1217 - Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
72.1218 - (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
72.1219 - Thm ("real_minus_binom_times",num_str real_minus_binom_times),
72.1220 - (*"(a - b)*(a - b) = ...*)
72.1221 - Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
72.1222 - (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
72.1223 - Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
72.1224 - (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
72.1225 - (*RL 020915*)
72.1226 - Thm ("real_pp_binom_times",num_str real_pp_binom_times),
72.1227 - (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
72.1228 - Thm ("real_pm_binom_times",num_str real_pm_binom_times),
72.1229 - (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
72.1230 - Thm ("real_mp_binom_times",num_str real_mp_binom_times),
72.1231 - (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
72.1232 - Thm ("real_mm_binom_times",num_str real_mm_binom_times),
72.1233 - (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
72.1234 - Thm ("realpow_multI",num_str realpow_multI),
72.1235 - (*(a*b)^^^n = a^^^n * b^^^n*)
72.1236 - Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
72.1237 - (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *)
72.1238 - Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3),
72.1239 - (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *)
72.1240 -
72.1241 -
72.1242 - (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
72.1243 - (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
72.1244 - Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
72.1245 - (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
72.1246 - Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
72.1247 - (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
72.1248 - Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
72.1249 - (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
72.1250 - *)
72.1251 -
72.1252 - Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
72.1253 - Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
72.1254 - Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*)
72.1255 -
72.1256 - Calc ("op +", eval_binop "#add_"),
72.1257 - Calc ("op *", eval_binop "#mult_"),
72.1258 - Calc ("Atools.pow", eval_binop "#power_"),
72.1259 - (*
72.1260 - Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
72.1261 - Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
72.1262 - Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
72.1263 - Thm ("real_add_commute",num_str real_add_commute), (**)
72.1264 - Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
72.1265 - Thm ("real_add_assoc",num_str real_add_assoc), (**)
72.1266 - *)
72.1267 -
72.1268 - Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
72.1269 - (*"r1 * r1 = r1 ^^^ 2"*)
72.1270 - Thm ("realpow_plus_1",num_str realpow_plus_1),
72.1271 - (*"r * r ^^^ n = r ^^^ (n + 1)"*)
72.1272 - (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
72.1273 - (*"z1 + z1 = 2 * z1"*)*)
72.1274 - Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
72.1275 - (*"z1 + (z1 + k) = 2 * z1 + k"*)
72.1276 -
72.1277 - Thm ("real_num_collect",num_str real_num_collect),
72.1278 - (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
72.1279 - Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
72.1280 - (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
72.1281 - Thm ("real_one_collect",num_str real_one_collect),
72.1282 - (*"m is_const ==> n + m * n = (1 + m) * n"*)
72.1283 - Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
72.1284 - (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
72.1285 -
72.1286 - Calc ("op +", eval_binop "#add_"),
72.1287 - Calc ("op *", eval_binop "#mult_"),
72.1288 - Calc ("Atools.pow", eval_binop "#power_")
72.1289 - ],
72.1290 - scr = EmptyScr
72.1291 -(*Script ((term_of o the o (parse thy)) scr_expand_binomtest)*)
72.1292 - }:rls;
72.1293 -
72.1294 -
72.1295 -ruleset' := overwritelthy thy (!ruleset',
72.1296 - [("make_polytest", prep_rls make_polytest),
72.1297 - ("expand_binomtest", prep_rls expand_binomtest)
72.1298 - ]);
72.1299 -
72.1300 -
72.1301 -
72.1302 -
72.1303 -
72.1304 -
73.1 --- a/src/Tools/isac/IsacKnowledge/Test.sml Wed Aug 25 15:15:01 2010 +0200
73.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
73.3 @@ -1,158 +0,0 @@
73.4 -val ttt = (term_of o the o (parse thy))
73.5 -"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_";
73.6 -val ttt = (term_of o the o (parse thy))
73.7 -"(Try (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_)";
73.8 -
73.9 -val ttt = (term_of o the o (parse thy))
73.10 - "(Rewrite_Set SqRoot_simplify False) e_ ";
73.11 -val ttt = (term_of o the o (parseold thy))
73.12 - "%e_. (Rewrite_Set SqRoot_simplify False) e_";
73.13 -val ttt = (term_of o the o (parseold thy))
73.14 - "Repeat (%e_. (Rewrite_Set SqRoot_simplify False)) e_";
73.15 -
73.16 -val ttt = (term_of o the o (parse thy))
73.17 - "Script Solve_linear (e_::bool) (v_::real)= \
73.18 - \[e_]";
73.19 -val ttt = (term_of o the o (parse thy))
73.20 - "Script Solve_linear (e_::bool) (v_::real)= \
73.21 - \((%e_. [e_]) e_)";
73.22 -val ttt = (term_of o the o (parse thy))
73.23 - "Script Solve_linear (e_::bool) (v_::real)= \
73.24 - \((%e_. (let e_ = e_ in [e_])) e_)";
73.25 -val ttt = (term_of o the o (parse thy))
73.26 - "Script Solve_linear (e_::bool) (v_::real)= \
73.27 - \((%e_. \
73.28 - \ (let e_ = ((Rewrite_Set SqRoot_simplify False) e_)\
73.29 - \ in [e_]))\
73.30 - \ e_)";
73.31 -val ttt = (term_of o the o (parse thy))
73.32 - "Script Solve_linear (e_::bool) (v_::real)= \
73.33 - \((%ee_. (let e_ = ((Rewrite_Set SqRoot_simplify False) ee_) in [e_])) e_)";
73.34 -
73.35 -val ttt = (term_of o the o (parse thy))
73.36 - "Script Solve_linear (e_::bool) (v_::real)= \
73.37 - \(let e_ = \
73.38 - \ (Repeat ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False)) e_)\
73.39 - \ in [e_])";
73.40 -(*----*)
73.41 -val ttt = (term_of o the o (parse thy))
73.42 -
73.43 -(*----*)
73.44 -val ttt = (term_of o the o (parse thy))
73.45 - "Script Solve_linear (e_::bool) (v_::real)= \
73.46 - \(let e_ = \
73.47 - \ (Repeat\
73.48 - \ ((%ee_. (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\
73.49 - \ e_)\
73.50 - \ e_)\
73.51 - \ in [e_])";
73.52 -val ttt = (term_of o the o (parse thy))
73.53 - "Script Solve_linear (e_::bool) (v_::real)= \
73.54 - \(let e_ = \
73.55 - \ (Repeat\
73.56 - \ ((%ee_.\
73.57 - \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_))\
73.58 - \ e_)\
73.59 - \ e_)\
73.60 - \ in [e_])";
73.61 -val ttt = (term_of o the o (parse thy))
73.62 - "Script Solve_linear (e_::bool) (v_::real)= \
73.63 - \(let e_ = \
73.64 - \ (Repeat\
73.65 - \ ((%ee_.\
73.66 - \ (let e_ = ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\
73.67 - \ in ((Rewrite_Set SqRoot_simplify False) e_)) )\
73.68 - \ e_)\
73.69 - \ e_)\
73.70 - \ in [e_])";
73.71 -atomty ttt;
73.72 -atomt ttt;
73.73 -
73.74 -val ttt = (term_of o the o (parse thy))
73.75 - "Script Testterm (g_::real) = \
73.76 - \Repeat\
73.77 - \ (Rewrite rmult_1 False) g_";
73.78 -val ttt = (term_of o the o (parse thy))
73.79 - "Script Testterm (g_::real) = \
73.80 - \Repeat\
73.81 - \ (((Rewrite rmult_1 False)) Or ((Rewrite rmult_0 False))) g_";
73.82 -val ttt = (term_of o the o (parse thy))
73.83 - "Script Testterm (g_::real) = \
73.84 - \Repeat\
73.85 - \ ((Repeat (Rewrite rmult_1 False)) Or (Repeat (Rewrite rmult_0 False))) g_";
73.86 -val ttt = (term_of o the o (parse thy))
73.87 - "Script Testterm (g_::real) = \
73.88 - \Repeat\
73.89 - \ ((Repeat (Rewrite rmult_1 False)) Or\
73.90 - \ (Repeat (Rewrite rmult_0 False))) g_";
73.91 -val ttt = (term_of o the o (parse thy))
73.92 - "Script Testterm (g_::real) = \
73.93 - \Repeat\
73.94 - \ ((Repeat (Rewrite rmult_1 False)) Or\
73.95 - \ (Repeat (Rewrite rmult_0 False)) Or\
73.96 - \ (Repeat (Rewrite rmult_0 False))) g_";
73.97 -val ttt = (term_of o the o (parse thy))
73.98 - "Script Testterm (g_::real) = \
73.99 - \Repeat\
73.100 - \ ((Try Repeat (Rewrite rmult_1 False)) Or\
73.101 - \ (Try Repeat (Rewrite rmult_0 False)) Or\
73.102 - \ (Try Repeat (Rewrite rmult_0 False))) g_";
73.103 -
73.104 -
73.105 -
73.106 -
73.107 -
73.108 -
73.109 -
73.110 -
73.111 -
73.112 -
73.113 -
73.114 -
73.115 -
73.116 -(*################### 29.4.02: Rewrite o Rewrite o ...###############*)
73.117 -(*################### 29.4.02: Rewrite o Rewrite o ...###############*)
73.118 -(*################### 29.4.02: Rewrite o Rewrite o ...###############*)
73.119 -
73.120 -
73.121 -
73.122 -atomt ttt;
73.123 -val ttt = (term_of o the o (parse thy))
73.124 - "Script Solve_linear (e_::bool) (v_::real)= \
73.125 - \(let e_ = \
73.126 - \ ((Repeat\
73.127 - \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
73.128 - \ (Rewrite_Set SqRoot_simplify False)))) e_)\
73.129 - \ in [e_])";
73.130 -atomty ttt;
73.131 -
73.132 -
73.133 -val ttt = (term_of o the o (parse thy))
73.134 -"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@ yyy";
73.135 -atomty ttt;
73.136 -val ttt = (term_of o the o (parse thy))
73.137 - "(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
73.138 - \ (Rewrite_Set SqRoot_simplify False)";
73.139 -atomty ttt;
73.140 -val ttt = (term_of o the o (parse thy))
73.141 - "(Repeat\
73.142 - \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
73.143 - \ (Rewrite_Set SqRoot_simplify False))) e_";
73.144 -atomty ttt;
73.145 -val ttt = (term_of o the o (parseold thy))
73.146 -"(let e_ = Repeat xxx e_ in [e_::bool])";
73.147 -atomty ttt;
73.148 -val ttt = (term_of o the o (parseold thy))
73.149 - "Script Solve_linear (e_::bool) (v_::real)= \
73.150 - \(let e_ = Repeat (xxx) e_ in [e_::bool])";
73.151 -atomty ttt;
73.152 -val ttt = (term_of o the o (parseold thy))
73.153 - "Script Solve_linear (e_::bool) (v_::real)= \
73.154 - \(let e_ =\
73.155 - \ Repeat\
73.156 - \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
73.157 - \ (Rewrite_Set SqRoot_simplify False))) e_\
73.158 - \ in [e_::bool])"
73.159 -;
73.160 -atomty ttt;
73.161 -
74.1 --- a/src/Tools/isac/IsacKnowledge/Test.thy Wed Aug 25 15:15:01 2010 +0200
74.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
74.3 @@ -1,169 +0,0 @@
74.4 -(* use_thy"IsacKnowledge/Test";
74.5 - *)
74.6 -
74.7 -Test = Atools + Rational + Root + Poly +
74.8 -
74.9 -consts
74.10 -
74.11 -(*"cancel":: [real, real] => real (infixl "'/'/'/" 70) ...divide 2002*)
74.12 -
74.13 - Expand'_binomtest
74.14 - :: "['y, \
74.15 - \ 'y] => 'y"
74.16 - ("((Script Expand'_binomtest (_ =))// \
74.17 - \ (_))" 9)
74.18 -
74.19 - Solve'_univar'_err
74.20 - :: "[bool,real,bool, \
74.21 - \ bool list] => bool list"
74.22 - ("((Script Solve'_univar'_err (_ _ _ =))// \
74.23 - \ (_))" 9)
74.24 -
74.25 - Solve'_linear
74.26 - :: "[bool,real, \
74.27 - \ bool list] => bool list"
74.28 - ("((Script Solve'_linear (_ _ =))// \
74.29 - \ (_))" 9)
74.30 -
74.31 -(*17.9.02 aus SqRoot.thy------------------------------vvv---*)
74.32 -
74.33 - "is'_root'_free" :: 'a => bool ("is'_root'_free _" 10)
74.34 - "contains'_root" :: 'a => bool ("contains'_root _" 10)
74.35 -
74.36 - Solve'_root'_equation
74.37 - :: "[bool,real, \
74.38 - \ bool list] => bool list"
74.39 - ("((Script Solve'_root'_equation (_ _ =))// \
74.40 - \ (_))" 9)
74.41 -
74.42 - Solve'_plain'_square
74.43 - :: "[bool,real, \
74.44 - \ bool list] => bool list"
74.45 - ("((Script Solve'_plain'_square (_ _ =))// \
74.46 - \ (_))" 9)
74.47 -
74.48 - Norm'_univar'_equation
74.49 - :: "[bool,real, \
74.50 - \ bool] => bool"
74.51 - ("((Script Norm'_univar'_equation (_ _ =))// \
74.52 - \ (_))" 9)
74.53 -
74.54 - STest'_simplify
74.55 - :: "['z, \
74.56 - \ 'z] => 'z"
74.57 - ("((Script STest'_simplify (_ =))// \
74.58 - \ (_))" 9)
74.59 -
74.60 -(*17.9.02 aus SqRoot.thy------------------------------^^^---*)
74.61 -
74.62 -rules (*stated as axioms, todo: prove as theorems*)
74.63 -
74.64 - radd_mult_distrib2 "(k::real) * (m + n) = k * m + k * n"
74.65 - rdistr_right_assoc "(k::real) + l * n + m * n = k + (l + m) * n"
74.66 - rdistr_right_assoc_p "l * n + (m * n + (k::real)) = (l + m) * n + k"
74.67 - rdistr_div_right "((k::real) + l) / n = k / n + l / n"
74.68 - rcollect_right
74.69 - "[| l is_const; m is_const |] ==> (l::real)*n + m*n = (l + m) * n"
74.70 - rcollect_one_left
74.71 - "m is_const ==> (n::real) + m * n = (1 + m) * n"
74.72 - rcollect_one_left_assoc
74.73 - "m is_const ==> (k::real) + n + m * n = k + (1 + m) * n"
74.74 - rcollect_one_left_assoc_p
74.75 - "m is_const ==> n + (m * n + (k::real)) = (1 + m) * n + k"
74.76 -
74.77 - rtwo_of_the_same "a + a = 2 * a"
74.78 - rtwo_of_the_same_assoc "(x + a) + a = x + 2 * a"
74.79 - rtwo_of_the_same_assoc_p"a + (a + x) = 2 * a + x"
74.80 -
74.81 - rcancel_den "not(a=0) ==> a * (b / a) = b"
74.82 - rcancel_const "[| a is_const; b is_const |] ==> a*(x/b) = a/b*x"
74.83 - rshift_nominator "(a::real) * b / c = a / c * b"
74.84 -
74.85 - exp_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)"
74.86 - rsqare "(a::real) * a = a ^^^ 2"
74.87 - power_1 "(a::real) ^^^ 1 = a"
74.88 - rbinom_power_2 "((a::real) + b)^^^ 2 = a^^^ 2 + 2*a*b + b^^^ 2"
74.89 -
74.90 - rmult_1 "1 * k = (k::real)"
74.91 - rmult_1_right "k * 1 = (k::real)"
74.92 - rmult_0 "0 * k = (0::real)"
74.93 - rmult_0_right "k * 0 = (0::real)"
74.94 - radd_0 "0 + k = (k::real)"
74.95 - radd_0_right "k + 0 = (k::real)"
74.96 -
74.97 - radd_real_const_eq
74.98 - "[| a is_const; c is_const; d is_const |] ==> a/d + c/d = (a+c)/(d::real)"
74.99 - radd_real_const
74.100 - "[| a is_const; b is_const; c is_const; d is_const |] ==> a/b + c/d = (a*d + b*c)/(b*(d::real))"
74.101 -
74.102 -(*for AC-operators*)
74.103 - radd_commute "(m::real) + (n::real) = n + m"
74.104 - radd_left_commute "(x::real) + (y + z) = y + (x + z)"
74.105 - radd_assoc "(m::real) + n + k = m + (n + k)"
74.106 - rmult_commute "(m::real) * n = n * m"
74.107 - rmult_left_commute "(x::real) * (y * z) = y * (x * z)"
74.108 - rmult_assoc "(m::real) * n * k = m * (n * k)"
74.109 -
74.110 -(*for equations: 'bdv' is a meta-constant*)
74.111 - risolate_bdv_add "((k::real) + bdv = m) = (bdv = m + (-1)*k)"
74.112 - risolate_bdv_mult_add "((k::real) + n*bdv = m) = (n*bdv = m + (-1)*k)"
74.113 - risolate_bdv_mult "((n::real) * bdv = m) = (bdv = m / n)"
74.114 -
74.115 - rnorm_equation_add
74.116 - "~(b =!= 0) ==> (a = b) = (a + (-1)*b = 0)"
74.117 -
74.118 -(*17.9.02 aus SqRoot.thy------------------------------vvv---*)
74.119 - root_ge0 "0 <= a ==> 0 <= sqrt a"
74.120 - (*should be dropped with better simplification in eval_rls ...*)
74.121 - root_add_ge0
74.122 - "[| 0 <= a; 0 <= b |] ==> (0 <= sqrt a + sqrt b) = True"
74.123 - root_ge0_1
74.124 - "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= a * sqrt b + sqrt c) = True"
74.125 - root_ge0_2
74.126 - "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= sqrt a + b * sqrt c) = True"
74.127 -
74.128 -
74.129 - rroot_square_inv "(sqrt a)^^^ 2 = a"
74.130 - rroot_times_root "sqrt a * sqrt b = sqrt(a*b)"
74.131 - rroot_times_root_assoc "(a * sqrt b) * sqrt c = a * sqrt(b*c)"
74.132 - rroot_times_root_assoc_p "sqrt b * (sqrt c * a)= sqrt(b*c) * a"
74.133 -
74.134 -
74.135 -(*for root-equations*)
74.136 - square_equation_left
74.137 - "[| 0 <= a; 0 <= b |] ==> (((sqrt a)=b)=(a=(b^^^ 2)))"
74.138 - square_equation_right
74.139 - "[| 0 <= a; 0 <= b |] ==> ((a=(sqrt b))=((a^^^ 2)=b))"
74.140 - (*causes frequently non-termination:*)
74.141 - square_equation
74.142 - "[| 0 <= a; 0 <= b |] ==> ((a=b)=((a^^^ 2)=b^^^ 2))"
74.143 -
74.144 - risolate_root_add "(a+ sqrt c = d) = ( sqrt c = d + (-1)*a)"
74.145 - risolate_root_mult "(a+b*sqrt c = d) = (b*sqrt c = d + (-1)*a)"
74.146 - risolate_root_div "(a * sqrt c = d) = ( sqrt c = d / a)"
74.147 -
74.148 -(*for polynomial equations of degree 2; linear case in RatArith*)
74.149 - mult_square "(a*bdv^^^2 = b) = (bdv^^^2 = b / a)"
74.150 - constant_square "(a + bdv^^^2 = b) = (bdv^^^2 = b + -1*a)"
74.151 - constant_mult_square "(a + b*bdv^^^2 = c) = (b*bdv^^^2 = c + -1*a)"
74.152 -
74.153 - square_equality
74.154 - "0 <= a ==> (x^^^2 = a) = ((x=sqrt a) | (x=-1*sqrt a))"
74.155 - square_equality_0
74.156 - "(x^^^2 = 0) = (x = 0)"
74.157 -
74.158 -(*isolate root on the LEFT hand side of the equation
74.159 - otherwise shuffling from left to right would not terminate*)
74.160 -
74.161 - rroot_to_lhs
74.162 - "is_root_free a ==> (a = sqrt b) = (a + (-1)*sqrt b = 0)"
74.163 - rroot_to_lhs_mult
74.164 - "is_root_free a ==> (a = c*sqrt b) = (a + (-1)*c*sqrt b = 0)"
74.165 - rroot_to_lhs_add_mult
74.166 - "is_root_free a ==> (a = d+c*sqrt b) = (a + (-1)*c*sqrt b = d)"
74.167 -
74.168 -
74.169 -(*17.9.02 aus SqRoot.thy------------------------------^^^---*)
74.170 -
74.171 -
74.172 -end
75.1 --- a/src/Tools/isac/IsacKnowledge/Trig.thy Wed Aug 25 15:15:01 2010 +0200
75.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
75.3 @@ -1,4 +0,0 @@
75.4 -
75.5 -Trig = Real +
75.6 -
75.7 -end
75.8 \ No newline at end of file
76.1 --- a/src/Tools/isac/IsacKnowledge/Typefix.thy Wed Aug 25 15:15:01 2010 +0200
76.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
76.3 @@ -1,68 +0,0 @@
76.4 -(* Title: fixed type for _RE_parsing of strings from frontend
76.5 - Author: Walther Neuper
76.6 - 9911xx
76.7 - (c) due to copyright terms
76.8 - with hints from Markus Wenzel
76.9 - *)
76.10 -
76.11 -theory Typefix imports "../Scripts/Script"
76.12 -uses ("../Scripts/scrtools.sml")
76.13 -("../ME/mstools.sml") ("../ME/ctree.sml") ("../ME/ptyps.sml")
76.14 -("../ME/generate.sml") ("../ME/calchead.sml") ("../ME/appl.sml")
76.15 -("../ME/rewtools.sml") ("../ME/script.sml") ("../ME/solve.sml")
76.16 -("../ME/inform.sml") ("../ME/mathengine.sml")
76.17 -("../xmlsrc/mathml.sml") ("../xmlsrc/datatypes.sml")
76.18 -("../xmlsrc/pbl-met-hierarchy.sml") ("../xmlsrc/thy-hierarchy.sml")
76.19 -("../xmlsrc/interface-xml.sml") ("../FE-interface/messages.sml")
76.20 -("../FE-interface/states.sml") ("../FE-interface/interface.sml")
76.21 -("../print_exn_G.sml")
76.22 -begin
76.23 -use "../Scripts/scrtools.sml"
76.24 -
76.25 -use "../ME/mstools.sml"
76.26 -use "../ME/ctree.sml"
76.27 -use "../ME/ptyps.sml"
76.28 -use "../ME/generate.sml"
76.29 -use "../ME/calchead.sml"
76.30 -use "../ME/appl.sml"
76.31 -use "../ME/rewtools.sml"
76.32 -use "../ME/script.sml"
76.33 -use "../ME/solve.sml"
76.34 -use "../ME/inform.sml"
76.35 -use "../ME/mathengine.sml"
76.36 -
76.37 -use "../xmlsrc/mathml.sml"
76.38 -use "../xmlsrc/datatypes.sml"
76.39 -use "../xmlsrc/pbl-met-hierarchy.sml"
76.40 -use "../xmlsrc/thy-hierarchy.sml"
76.41 -use "../xmlsrc/interface-xml.sml"
76.42 -
76.43 -use "../FE-interface/messages.sml"
76.44 -use "../FE-interface/states.sml"
76.45 -use "../FE-interface/interface.sml"
76.46 -
76.47 -use "../print_exn_G.sml"
76.48 -
76.49 -syntax
76.50 -
76.51 - "_plus" :: 'a
76.52 - "_minus" :: 'a
76.53 - "_umin" :: 'a
76.54 - "_times" :: 'a
76.55 -
76.56 -translations
76.57 -
76.58 - "op +" => "_plus :: [real, real] => real" (*infixl 65 *)
76.59 - "op -" => "_minus :: [real, real] => real" (*infixl 65 *)
76.60 - "uminus"=> "_umin :: [real] => real" (*"- _" [80] 80*)
76.61 - "op *" => "_times :: [real, real] => real" (*infixl 70 *)
76.62 -
76.63 -ML {*
76.64 -val parse_translation =
76.65 - [("_plus", curry Term.list_comb (Syntax.const "op +")),
76.66 - ("_minus", curry Term.list_comb (Syntax.const "op -")),
76.67 - ("_umin", curry Term.list_comb (Syntax.const "uminus")),
76.68 - ("_times", curry Term.list_comb (Syntax.const "op *"))];
76.69 -*}
76.70 -
76.71 -end
76.72 \ No newline at end of file
77.1 --- a/src/Tools/isac/IsacKnowledge/Vect.thy Wed Aug 25 15:15:01 2010 +0200
77.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
77.3 @@ -1,5 +0,0 @@
77.4 -Vect = Real +
77.5 -(*-------------------- consts ------------------------------------------------*)
77.6 -
77.7 -(*-------------------- rules -------------------------------------------------*)
77.8 -end
78.1 --- a/src/Tools/isac/Isac_Mathengine.thy Wed Aug 25 15:15:01 2010 +0200
78.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
78.3 @@ -1,102 +0,0 @@
78.4 -(* Title: ~~~/isac/Isac_Mathengine.thy
78.5 - Author: Walther Neuper, TU Graz
78.6 -
78.7 -$ cd /usr/local/Isabelle2009-1/src/Tools/isac
78.8 -$ /usr/local/isabisac/bin/isabelle emacs Isac_Mathengine.thy &
78.9 -$ /usr/local/isabisac/bin/isabelle jedit Isac_Mathengine.thy &
78.10 -
78.11 -12345678901234567890123456789012345678901234567890123456789012345678901234567890
78.12 - 10 20 30 40 50 60 70 80
78.13 -*)
78.14 -
78.15 -header {* Loading the isac mathengine *}
78.16 -
78.17 -theory Isac_Mathengine
78.18 -(*imports Complex_Main*)
78.19 -imports Complex_Main "Scripts/Script" (*ListG, Tools, Script*)
78.20 -begin
78.21 -
78.22 -ML {*
78.23 -writeln "**** build the isac kernel = math-engine + IsacKnowledge ";
78.24 -writeln "**** build the math-engine ******************************" *}
78.25 -
78.26 -ML {* Toplevel.debug := true; *}
78.27 -use "library.sml"
78.28 -use "calcelems.sml"
78.29 -ML {* check_guhs_unique := true *}
78.30 -
78.31 -use "Scripts/term_G.sml"
78.32 -use "Scripts/calculate.sml"
78.33 -use "Scripts/rewrite.sml"
78.34 -use_thy"Scripts/Script"
78.35 -use "Scripts/scrtools.sml"
78.36 -
78.37 -use "ME/mstools.sml"
78.38 -use "ME/ctree.sml"
78.39 -use "ME/ptyps.sml"
78.40 -use "ME/generate.sml"
78.41 -use "ME/calchead.sml"
78.42 -use "ME/appl.sml"
78.43 -use "ME/rewtools.sml"
78.44 -use "ME/script.sml"
78.45 -use "ME/solve.sml"
78.46 -use "ME/inform.sml"
78.47 -use "ME/mathengine.sml"
78.48 -
78.49 -use "xmlsrc/mathml.sml"
78.50 -use "xmlsrc/datatypes.sml"
78.51 -use "xmlsrc/pbl-met-hierarchy.sml"
78.52 -use "xmlsrc/thy-hierarchy.sml"
78.53 -use "xmlsrc/interface-xml.sml"
78.54 -
78.55 -use "FE-interface/messages.sml"
78.56 -use "FE-interface/states.sml"
78.57 -use "FE-interface/interface.sml"
78.58 -
78.59 -use "print_exn_G.sml"
78.60 -text "**** build math-engine complete *************************"
78.61 -
78.62 -ML {* writeln "**** build the IsacKnowledge ****************************" *}
78.63 -use_thy"IsacKnowledge/Typefix"
78.64 -use_thy"IsacKnowledge/Descript"
78.65 -
78.66 -ML {*
78.67 -
78.68 -111;
78.69 -*}
78.70 -
78.71 -use_thy"IsacKnowledge/Atools"
78.72 -
78.73 -
78.74 -ML {*
78.75 -val str = "1234567890";
78.76 -*}
78.77 -
78.78 -(*
78.79 -use_thy"IsacKnowledge/Simplify"
78.80 -use_thy"IsacKnowledge/Poly"
78.81 -use_thy"IsacKnowledge/Rational"
78.82 -use_thy"IsacKnowledge/PolyMinus"
78.83 -use_thy"IsacKnowledge/Equation"
78.84 -use_thy"IsacKnowledge/LinEq"
78.85 -use_thy"IsacKnowledge/Root"
78.86 -use_thy"IsacKnowledge/RootEq"
78.87 -use_thy"IsacKnowledge/RatEq"
78.88 -use_thy"IsacKnowledge/RootRat"
78.89 -use_thy"IsacKnowledge/RootRatEq"
78.90 -use_thy"IsacKnowledge/PolyEq"
78.91 -use_thy"IsacKnowledge/Vect"
78.92 -use_thy"IsacKnowledge/Calculus"
78.93 -use_thy"IsacKnowledge/Trig"
78.94 -use_thy"IsacKnowledge/LogExp"
78.95 -use_thy"IsacKnowledge/Diff"
78.96 -use_thy"IsacKnowledge/DiffApp"
78.97 -use_thy"IsacKnowledge/Integrate"
78.98 -use_thy"IsacKnowledge/EqSystem"
78.99 -use_thy"IsacKnowledge/Biegelinie"
78.100 -use_thy"IsacKnowledge/AlgEin"
78.101 -use_thy"IsacKnowledge/Test"
78.102 -use_thy"IsacKnowledge/Isac"
78.103 -*)
78.104 -end
78.105 -
79.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
79.2 +++ b/src/Tools/isac/Knowledge/AlgEin.ML Wed Aug 25 16:20:07 2010 +0200
79.3 @@ -0,0 +1,141 @@
79.4 +(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt
79.5 + author: Walther Neuper 2007
79.6 + (c) due to copyright terms
79.7 +
79.8 +use"Knowledge/AlgEin.ML";
79.9 +use"AlgEin.ML";
79.10 +
79.11 +remove_thy"Typefix";
79.12 +remove_thy"AlgEin";
79.13 +use_thy"Knowledge/Isac";
79.14 +*)
79.15 +
79.16 +(** interface isabelle -- isac **)
79.17 +
79.18 +theory' := overwritel (!theory', [("AlgEin.thy",AlgEin.thy)]);
79.19 +
79.20 +(** problems **)
79.21 +
79.22 +store_pbt
79.23 + (prep_pbt AlgEin.thy "pbl_algein" [] e_pblID
79.24 + (["Berechnung"], [], e_rls, NONE,
79.25 + []));
79.26 +(* WN070405
79.27 +store_pbt
79.28 + (prep_pbt AlgEin.thy "pbl_algein_num" [] e_pblID
79.29 + (["numerische", "Berechnung"],
79.30 + [("#Given" ,["KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]),
79.31 + ("#Find" ,["GesamtLaenge l_"])
79.32 + ],
79.33 + append_rls "e_rls" e_rls [],
79.34 + NONE,
79.35 + []));
79.36 +*)
79.37 +store_pbt
79.38 + (prep_pbt AlgEin.thy "pbl_algein_numsym" [] e_pblID
79.39 + (["numerischSymbolische", "Berechnung"],
79.40 + [("#Given" ,["KantenLaenge k_","Querschnitt q__"(*q_ in Biegelinie.thy*),
79.41 + "KantenUnten u_", "KantenSenkrecht s_", "KantenOben o_"]),
79.42 + ("#Find" ,["GesamtLaenge l_"])
79.43 + ],
79.44 + e_rls,
79.45 + NONE,
79.46 + [["Berechnung","erstNumerisch"],["Berechnung","erstSymbolisch"]]));
79.47 +
79.48 +(* show_ptyps();
79.49 + *)
79.50 +
79.51 +
79.52 +(** methods **)
79.53 +
79.54 +store_met
79.55 + (prep_met AlgEin.thy "met_algein" [] e_metID
79.56 + (["Berechnung"],
79.57 + [],
79.58 + {rew_ord'="tless_true", rls'= Erls, calc = [],
79.59 + srls = Erls, prls = Erls,
79.60 + crls =Erls , nrls = Erls},
79.61 +"empty_script"
79.62 +));
79.63 +
79.64 +store_met
79.65 + (prep_met AlgEin.thy "met_algein_numsym" [] e_metID
79.66 + (["Berechnung","erstNumerisch"],
79.67 + [],
79.68 + {rew_ord'="tless_true", rls'= Erls, calc = [],
79.69 + srls = Erls, prls = Erls,
79.70 + crls =Erls , nrls = Erls},
79.71 +"empty_script"
79.72 +));
79.73 +
79.74 +store_met
79.75 + (prep_met AlgEin.thy "met_algein_numsym" [] e_metID
79.76 + (["Berechnung","erstNumerisch"],
79.77 + [("#Given" ,["KantenLaenge k_","Querschnitt q__",
79.78 + "KantenUnten u_", "KantenSenkrecht s_",
79.79 + "KantenOben o_"]),
79.80 + ("#Find" ,["GesamtLaenge l_"])
79.81 + ],
79.82 + {rew_ord'="tless_true", rls'= e_rls, calc = [],
79.83 + srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls
79.84 + [Calc ("Atools.boollist2sum",
79.85 + eval_boollist2sum "")],
79.86 + prls = e_rls, crls =e_rls , nrls = norm_Rational},
79.87 +"Script RechnenSymbolScript (k_::bool) (q__::bool) \
79.88 +\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\
79.89 +\ (let t_ = Take (l_ = oben + senkrecht + unten); \
79.90 +\ sum_ = boollist2sum o_;\
79.91 +\ t_ = Substitute [oben = sum_] t_;\
79.92 +\ t_ = Substitute o_ t_;\
79.93 +\ t_ = Substitute [k_, q__] t_;\
79.94 +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
79.95 +\ sum_ = boollist2sum s_;\
79.96 +\ t_ = Substitute [senkrecht = sum_] t_;\
79.97 +\ t_ = Substitute s_ t_;\
79.98 +\ t_ = Substitute [k_, q__] t_;\
79.99 +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
79.100 +\ sum_ = boollist2sum u_;\
79.101 +\ t_ = Substitute [unten = sum_] t_;\
79.102 +\ t_ = Substitute u_ t_;\
79.103 +\ t_ = Substitute [k_, q__] t_;\
79.104 +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_\
79.105 +\ in (Try (Rewrite_Set norm_Poly False)) t_)"
79.106 +));
79.107 +
79.108 +store_met
79.109 + (prep_met AlgEin.thy "met_algein_symnum" [] e_metID
79.110 + (["Berechnung","erstSymbolisch"],
79.111 + [("#Given" ,["KantenLaenge k_","Querschnitt q__",
79.112 + "KantenUnten u_", "KantenSenkrecht s_",
79.113 + "KantenOben o_"]),
79.114 + ("#Find" ,["GesamtLaenge l_"])
79.115 + ],
79.116 + {rew_ord'="tless_true", rls'= e_rls, calc = [],
79.117 + srls = append_rls "srls_..Berechnung-erstSymbolisch" e_rls
79.118 + [Calc ("Atools.boollist2sum",
79.119 + eval_boollist2sum "")],
79.120 + prls = e_rls,
79.121 + crls =e_rls , nrls = norm_Rational},
79.122 +"Script RechnenSymbolScript (k_::bool) (q__::bool) \
79.123 +\(u_::bool list) (s_::bool list) (o_::bool list) (l_::real) =\
79.124 +\ (let t_ = Take (l_ = oben + senkrecht + unten); \
79.125 +\ sum_ = boollist2sum o_;\
79.126 +\ t_ = Substitute [oben = sum_] t_;\
79.127 +\ t_ = Substitute o_ t_;\
79.128 +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
79.129 +\ sum_ = boollist2sum s_;\
79.130 +\ t_ = Substitute [senkrecht = sum_] t_;\
79.131 +\ t_ = Substitute s_ t_;\
79.132 +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
79.133 +\ sum_ = boollist2sum u_;\
79.134 +\ t_ = Substitute [unten = sum_] t_;\
79.135 +\ t_ = Substitute u_ t_;\
79.136 +\ t_ = (Repeat (Try (Rewrite_Set norm_Poly False))) t_;\
79.137 +\ t_ = Substitute [k_, q__] t_\
79.138 +\ in (Try (Rewrite_Set norm_Poly False)) t_)"
79.139 +));
79.140 +
79.141 +(* show_mets();
79.142 + *)
79.143 +(* use"Knowledge/AlgEin.ML";
79.144 + *)
79.145 \ No newline at end of file
80.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
80.2 +++ b/src/Tools/isac/Knowledge/AlgEin.thy Wed Aug 25 16:20:07 2010 +0200
80.3 @@ -0,0 +1,37 @@
80.4 +(* Algebra Einf"uhrung, Unterrichtsversuch IMST-Projekt
80.5 + author: Walther Neuper 2007
80.6 + (c) due to copyright terms
80.7 +
80.8 +remove_thy"AlgEin";
80.9 +use_thy"Knowledge/AlgEin";
80.10 +use_thy_only"Knowledge/AlgEin";
80.11 +
80.12 +remove_thy"AlgEin";
80.13 +use_thy"Knowledge/Isac";
80.14 +*)
80.15 +
80.16 +AlgEin = Rational +
80.17 +(*Poly + ..shouldbe sufficient, but norm_Poly *)
80.18 +
80.19 +consts
80.20 +
80.21 + (*new Descriptions in the related problems*)
80.22 + KantenUnten :: bool list => una
80.23 + KantenSenkrecht :: bool list => una
80.24 + KantenOben :: bool list => una
80.25 + KantenLaenge :: bool => una
80.26 + Querschnitt :: bool => una
80.27 + GesamtLaenge :: real => una
80.28 +
80.29 + (*Script-names*)
80.30 + RechnenSymbolScript :: "[bool,bool,bool list,bool list,bool list,real,
80.31 + bool] => bool"
80.32 + ("((Script RechnenSymbolScript (_ _ _ _ _ _ =))// (_))" 9)
80.33 +
80.34 +(*
80.35 +rules
80.36 + (*this axiom creates a contradictory formal system,
80.37 + see problem TOOODO *)
80.38 +*)
80.39 +
80.40 +end
81.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
81.2 +++ b/src/Tools/isac/Knowledge/Atools.ML Wed Aug 25 16:20:07 2010 +0200
81.3 @@ -0,0 +1,645 @@
81.4 +(* tools for arithmetic
81.5 + WN.8.3.01
81.6 + use"../Knowledge/Atools.ML";
81.7 + use"Knowledge/Atools.ML";
81.8 + use"Atools.ML";
81.9 + *)
81.10 +
81.11 +(*
81.12 +copy from doc/math-eng.tex WN.28.3.03
81.13 +WN071228 extended
81.14 +
81.15 +\section{Coding standards}
81.16 +
81.17 +%WN071228 extended -----vvv
81.18 +\subsection{Identifiers}
81.19 +Naming is particularily crucial, because Isabelles name space is global, and isac does not yet use the novel locale features introduces by Isar. For instance, {\tt probe} sounds reasonable as (1) a description in the model of a problem-pattern, (2) as an element of the problem hierarchies key, (3) as a socalled CAS-command, (4) as the name of a related script etc. However, all the cases (1)..(4) require different typing for one and the same identifier {\tt probe} which is impossible, and actually leads to strange errors (for instance (1) is used as string, except in a script addressing a Subproblem).
81.20 +
81.21 +This are the preliminary rules for naming identifiers>
81.22 +\begin{description}
81.23 +\item [elements of a key] into the hierarchy of problems or methods must not contain capital letters and may contain underscrores, e.g. {\tt probe, for_polynomials}.
81.24 +\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}.
81.25 +\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~!
81.26 +\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}.
81.27 +\item [???] ???
81.28 +\item [???] ???
81.29 +\end{description}
81.30 +%WN071228 extended -----^^^
81.31 +
81.32 +
81.33 +\subsection{Rule sets}
81.34 +The actual version of the coding standards for rulesets is in {\tt /Knowledge/Atools.ML where it can be viewed using the knowledge browsers.
81.35 +
81.36 +There are rulesets visible to the student, and there are rulesets visible (in general) only for math authors. There are also rulesets which {\em must} exist for {\em each} theory; these contain the identifier of the respective theory (including all capital letters) as indicated by {\it Thy} below.
81.37 +\begin{description}
81.38 +
81.39 +\item [norm\_{\it Thy}] exists for each theory, and {\em efficiently} calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents).
81.40 +
81.41 +\item [simplify\_{\it Thy}] exists for each theory, and calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents) such, that the rewrites can be presented to the student.
81.42 +
81.43 +\item [calculate\_{\it Thy}] exists for each theory, and evaluates terms with numerical constants only (i.e. all terms which can be expressed by the definitions of the respective theory and the respective parent theories). In particular, this ruleset includes evaluating in/equalities with numerical constants only.
81.44 +WN.3.7.03: may be dropped due to more generality: numericals and non-numericals are logically equivalent, where the latter often add to the assumptions (e.g. in Check_elementwise).
81.45 +
81.46 +\end{description}
81.47 +The above rulesets are all visible to the user, and also may be input; thus they must be contained in the global associationlist {\tt ruleset':= }~! All these rulesets must undergo a preparation using the function {\tt prep_rls}, which generates a script for stepwise rewriting etc.
81.48 +The following rulesets are used for internal purposes and usually invisible to the (naive) user:
81.49 +\begin{description}
81.50 +
81.51 +\item [*\_erls]
81.52 +\item [*\_prls]
81.53 +\item [*\_srls]
81.54 +
81.55 +\end{description}
81.56 +{\tt append_rls, merge_rls, remove_rls}
81.57 +*)
81.58 +
81.59 +"******* Atools.ML begin *******";
81.60 +theory' := overwritel (!theory', [("Atools.thy",Atools.thy)]);
81.61 +
81.62 +(** evaluation of numerals and special predicates on the meta-level **)
81.63 +(*-------------------------functions---------------------*)
81.64 +local (* rlang 09.02 *)
81.65 + (*.a 'c is coefficient of v' if v does occur in c.*)
81.66 + fun coeff_in v c = member op = (vars c) v;
81.67 +in
81.68 + fun occurs_in v t = coeff_in v t;
81.69 +end;
81.70 +
81.71 +(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*)
81.72 +fun eval_occurs_in _ "Atools.occurs'_in"
81.73 + (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ =
81.74 + ((*writeln("@@@ eval_occurs_in: v= "^(term2str v));
81.75 + writeln("@@@ eval_occurs_in: t= "^(term2str t));*)
81.76 + if occurs_in v t
81.77 + then SOME ((term2str p) ^ " = True",
81.78 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
81.79 + else SOME ((term2str p) ^ " = False",
81.80 + Trueprop $ (mk_equality (p, HOLogic.false_const))))
81.81 + | eval_occurs_in _ _ _ _ = NONE;
81.82 +
81.83 +(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*)
81.84 +fun some_occur_in vs t =
81.85 + let fun occurs_in' a b = occurs_in b a
81.86 + in foldl or_ (false, map (occurs_in' t) vs) end;
81.87 +
81.88 +(*("some_occur_in", ("Atools.some'_occur'_in",
81.89 + eval_some_occur_in "#eval_some_occur_in_"))*)
81.90 +fun eval_some_occur_in _ "Atools.some'_occur'_in"
81.91 + (p as (Const ("Atools.some'_occur'_in",_)
81.92 + $ vs $ t)) _ =
81.93 + if some_occur_in (isalist2list vs) t
81.94 + then SOME ((term2str p) ^ " = True",
81.95 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
81.96 + else SOME ((term2str p) ^ " = False",
81.97 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
81.98 + | eval_some_occur_in _ _ _ _ = NONE;
81.99 +
81.100 +
81.101 +
81.102 +
81.103 +(*evaluate 'is_atom'*)
81.104 +(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*)
81.105 +fun eval_is_atom (thmid:string) "Atools.is'_atom"
81.106 + (t as (Const(op0,_) $ arg)) thy =
81.107 + (case arg of
81.108 + Free (n,_) => SOME (mk_thmid thmid op0 n "",
81.109 + Trueprop $ (mk_equality (t, true_as_term)))
81.110 + | _ => SOME (mk_thmid thmid op0 "" "",
81.111 + Trueprop $ (mk_equality (t, false_as_term))))
81.112 + | eval_is_atom _ _ _ _ = NONE;
81.113 +
81.114 +(*evaluate 'is_even'*)
81.115 +fun even i = (i div 2) * 2 = i;
81.116 +(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*)
81.117 +fun eval_is_even (thmid:string) "Atools.is'_even"
81.118 + (t as (Const(op0,_) $ arg)) thy =
81.119 + (case arg of
81.120 + Free (n,_) =>
81.121 + (case int_of_str n of
81.122 + SOME i =>
81.123 + if even i then SOME (mk_thmid thmid op0 n "",
81.124 + Trueprop $ (mk_equality (t, true_as_term)))
81.125 + else SOME (mk_thmid thmid op0 "" "",
81.126 + Trueprop $ (mk_equality (t, false_as_term)))
81.127 + | _ => NONE)
81.128 + | _ => NONE)
81.129 + | eval_is_even _ _ _ _ = NONE;
81.130 +
81.131 +(*evaluate 'is_const'*)
81.132 +(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*)
81.133 +fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*)
81.134 + (t as (Const(op0,t0) $ arg)) (thy:theory) =
81.135 + (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*)
81.136 + (case arg of
81.137 + Const (n1,_) =>
81.138 + SOME (mk_thmid thmid op0 n1 "",
81.139 + Trueprop $ (mk_equality (t, false_as_term)))
81.140 + | Free (n1,_) =>
81.141 + if is_numeral n1
81.142 + then SOME (mk_thmid thmid op0 n1 "",
81.143 + Trueprop $ (mk_equality (t, true_as_term)))
81.144 + else SOME (mk_thmid thmid op0 n1 "",
81.145 + Trueprop $ (mk_equality (t, false_as_term)))
81.146 + | Const ("Float.Float",_) =>
81.147 + SOME (mk_thmid thmid op0 (term2str arg) "",
81.148 + Trueprop $ (mk_equality (t, true_as_term)))
81.149 + | _ => (*NONE*)
81.150 + SOME (mk_thmid thmid op0 (term2str arg) "",
81.151 + Trueprop $ (mk_equality (t, false_as_term))))
81.152 + | eval_const _ _ _ _ = NONE;
81.153 +
81.154 +(*. evaluate binary, associative, commutative operators: *,+,^ .*)
81.155 +(*("PLUS" ,("op +" ,eval_binop "#add_")),
81.156 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
81.157 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*)
81.158 +
81.159 +(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) =
81.160 + ("xxxxxx",op_,t,thy);
81.161 + *)
81.162 +fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) =
81.163 + thmid ^ "Float ((" ^
81.164 + (string_of_int v11)^","^(string_of_int v12)^"), ("^
81.165 + (string_of_int p11)^","^(string_of_int p12)^")) __ (("^
81.166 + (string_of_int v21)^","^(string_of_int v22)^"), ("^
81.167 + (string_of_int p21)^","^(string_of_int p22)^"))";
81.168 +
81.169 +(*.convert int and float to internal floatingpoint prepresentation.*)
81.170 +fun numeral (Free (str, T)) =
81.171 + (case int_of_str str of
81.172 + SOME i => SOME ((i, 0), (0, 0))
81.173 + | NONE => NONE)
81.174 + | numeral (Const ("Float.Float", _) $
81.175 + (Const ("Pair", _) $
81.176 + (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $
81.177 + (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))=
81.178 + (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of
81.179 + (SOME v1', SOME v2', SOME p1', SOME p2') =>
81.180 + SOME ((v1', v2'), (p1', p2'))
81.181 + | _ => NONE)
81.182 + | numeral _ = NONE;
81.183 +
81.184 +(*.evaluate binary associative operations.*)
81.185 +fun eval_binop (thmid:string) (op_:string)
81.186 + (t as ( Const(op0,t0) $
81.187 + (Const(op0',t0') $ v $ t1) $ t2))
81.188 + thy = (*binary . (v.n1).n2*)
81.189 + if op0 = op0' then
81.190 + case (numeral t1, numeral t2) of
81.191 + (SOME n1, SOME n2) =>
81.192 + let val (T1,T2,Trange) = dest_binop_typ t0
81.193 + val res = calc (if op0 = "op -" then "op +" else op0) n1 n2
81.194 + (*WN071229 "HOL.divide" never tried*)
81.195 + val rhs = var_op_float v op_ t0 T1 res
81.196 + val prop = Trueprop $ (mk_equality (t, rhs))
81.197 + in SOME (mk_thmid_f thmid n1 n2, prop) end
81.198 + | _ => NONE
81.199 + else NONE
81.200 + | eval_binop (thmid:string) (op_:string)
81.201 + (t as
81.202 + (Const (op0, t0) $ t1 $
81.203 + (Const (op0', t0') $ t2 $ v)))
81.204 + thy = (*binary . n1.(n2.v)*)
81.205 + if op0 = op0' then
81.206 + case (numeral t1, numeral t2) of
81.207 + (SOME n1, SOME n2) =>
81.208 + if op0 = "op -" then NONE else
81.209 + let val (T1,T2,Trange) = dest_binop_typ t0
81.210 + val res = calc op0 n1 n2
81.211 + val rhs = float_op_var v op_ t0 T1 res
81.212 + val prop = Trueprop $ (mk_equality (t, rhs))
81.213 + in SOME (mk_thmid_f thmid n1 n2, prop) end
81.214 + | _ => NONE
81.215 + else NONE
81.216 +
81.217 + | eval_binop (thmid:string) (op_:string)
81.218 + (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*)
81.219 + (case (numeral t1, numeral t2) of
81.220 + (SOME n1, SOME n2) =>
81.221 + let val (T1,T2,Trange) = dest_binop_typ t0;
81.222 + val res = calc op0 n1 n2;
81.223 + val rhs = term_of_float Trange res;
81.224 + val prop = Trueprop $ (mk_equality (t, rhs));
81.225 + in SOME (mk_thmid_f thmid n1 n2, prop) end
81.226 + | _ => NONE)
81.227 + | eval_binop _ _ _ _ = NONE;
81.228 +(*
81.229 +> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy;
81.230 +> term2str t;
81.231 +val it = "-1 + 2 = 1"
81.232 +> val t = str2term "-1 * (-1 * a)";
81.233 +> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy;
81.234 +> term2str t;
81.235 +val it = "-1 * (-1 * a) = 1 * a"*)
81.236 +
81.237 +
81.238 +
81.239 +(*.evaluate < and <= for numerals.*)
81.240 +(*("le" ,("op <" ,eval_equ "#less_")),
81.241 + ("leq" ,("op <=" ,eval_equ "#less_equal_"))*)
81.242 +fun eval_equ (thmid:string) (op_:string) (t as
81.243 + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
81.244 + (case (int_of_str n1, int_of_str n2) of
81.245 + (SOME n1', SOME n2') =>
81.246 + if calc_equ (strip_thy op0) (n1', n2')
81.247 + then SOME (mk_thmid thmid op0 n1 n2,
81.248 + Trueprop $ (mk_equality (t, true_as_term)))
81.249 + else SOME (mk_thmid thmid op0 n1 n2,
81.250 + Trueprop $ (mk_equality (t, false_as_term)))
81.251 + | _ => NONE)
81.252 +
81.253 + | eval_equ _ _ _ _ = NONE;
81.254 +
81.255 +
81.256 +(*evaluate identity
81.257 +> reflI;
81.258 +val it = "(?t = ?t) = True"
81.259 +> val t = str2term "x = 0";
81.260 +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
81.261 +
81.262 +> val t = str2term "1 = 0";
81.263 +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
81.264 +----------- thus needs Calc !
81.265 +> val t = str2term "0 = 0";
81.266 +> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t;
81.267 +> term2str t';
81.268 +val it = "True"
81.269 +
81.270 +val t = str2term "Not (x = 0)";
81.271 +atomt t; term2str t;
81.272 +*** -------------
81.273 +*** Const ( Not)
81.274 +*** . Const ( op =)
81.275 +*** . . Free ( x, )
81.276 +*** . . Free ( 0, )
81.277 +val it = "x ~= 0" : string*)
81.278 +
81.279 +(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of
81.280 + the arguments: thus special handling by 'fun eval_binop'*)
81.281 +(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*)
81.282 +fun eval_ident (thmid:string) "Atools.ident" (t as
81.283 + (Const (op0,t0) $ t1 $ t2 )) thy =
81.284 + if t1 = t2
81.285 + then SOME (mk_thmid thmid op0
81.286 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
81.287 + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
81.288 + Trueprop $ (mk_equality (t, true_as_term)))
81.289 + else SOME (mk_thmid thmid op0
81.290 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
81.291 + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
81.292 + Trueprop $ (mk_equality (t, false_as_term)))
81.293 + | eval_ident _ _ _ _ = NONE;
81.294 +(* TODO
81.295 +> val t = str2term "x =!= 0";
81.296 +> val SOME (str, t') = eval_ident "ident_" "b" t thy;
81.297 +> term2str t';
81.298 +val str = "ident_(x)_(0)" : string
81.299 +val it = "(x =!= 0) = False" : string
81.300 +> val t = str2term "1 =!= 0";
81.301 +> val SOME (str, t') = eval_ident "ident_" "b" t thy;
81.302 +> term2str t';
81.303 +val str = "ident_(1)_(0)" : string
81.304 +val it = "(1 =!= 0) = False" : string
81.305 +> val t = str2term "0 =!= 0";
81.306 +> val SOME (str, t') = eval_ident "ident_" "b" t thy;
81.307 +> term2str t';
81.308 +val str = "ident_(0)_(0)" : string
81.309 +val it = "(0 =!= 0) = True" : string
81.310 +*)
81.311 +
81.312 +(*.evaluate identity of terms, which stay ready for evaluation in turn;
81.313 + thus returns False only for atoms.*)
81.314 +(*("equal" ,("op =",eval_equal "#equal_")):calc*)
81.315 +fun eval_equal (thmid:string) "op =" (t as
81.316 + (Const (op0,t0) $ t1 $ t2 )) thy =
81.317 + if t1 = t2
81.318 + then ((*writeln"... eval_equal: t1 = t2 --> True";*)
81.319 + SOME (mk_thmid thmid op0
81.320 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
81.321 + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
81.322 + Trueprop $ (mk_equality (t, true_as_term)))
81.323 + )
81.324 + else (case (is_atom t1, is_atom t2) of
81.325 + (true, true) =>
81.326 + ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*)
81.327 + SOME (mk_thmid thmid op0
81.328 + ("("^(term2str t1)^")") ("("^(term2str t2)^")"),
81.329 + Trueprop $ (mk_equality (t, false_as_term)))
81.330 + )
81.331 + | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*)
81.332 + NONE))
81.333 + | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit";
81.334 + NONE);
81.335 +(*
81.336 +val t = str2term "x ~= 0";
81.337 +val NONE = eval_equal "equal_" "b" t thy;
81.338 +
81.339 +
81.340 +> val t = str2term "(x + 1) = (x + 1)";
81.341 +> val SOME (str, t') = eval_equal "equal_" "b" t thy;
81.342 +> term2str t';
81.343 +val str = "equal_(x + 1)_(x + 1)" : string
81.344 +val it = "(x + 1 = x + 1) = True" : string
81.345 +> val t = str2term "x = 0";
81.346 +> val NONE = eval_equal "equal_" "b" t thy;
81.347 +
81.348 +> val t = str2term "1 = 0";
81.349 +> val SOME (str, t') = eval_equal "equal_" "b" t thy;
81.350 +> term2str t';
81.351 +val str = "equal_(1)_(0)" : string
81.352 +val it = "(1 = 0) = False" : string
81.353 +> val t = str2term "0 = 0";
81.354 +> val SOME (str, t') = eval_equal "equal_" "b" t thy;
81.355 +> term2str t';
81.356 +val str = "equal_(0)_(0)" : string
81.357 +val it = "(0 = 0) = True" : string
81.358 +*)
81.359 +
81.360 +
81.361 +(** evaluation on the metalevel **)
81.362 +
81.363 +(*. evaluate HOL.divide .*)
81.364 +(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*)
81.365 +fun eval_cancel (thmid:string) "HOL.divide" (t as
81.366 + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
81.367 + (case (int_of_str n1, int_of_str n2) of
81.368 + (SOME n1', SOME n2') =>
81.369 + let
81.370 + val sg = sign2 n1' n2';
81.371 + val (T1,T2,Trange) = dest_binop_typ t0;
81.372 + val gcd' = gcd (abs n1') (abs n2');
81.373 + in if gcd' = abs n2'
81.374 + then let val rhs = term_of_num Trange (sg * (abs n1') div gcd')
81.375 + val prop = Trueprop $ (mk_equality (t, rhs))
81.376 + in SOME (mk_thmid thmid op0 n1 n2, prop) end
81.377 + else if 0 < n2' andalso gcd' = 1 then NONE
81.378 + else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd')
81.379 + ((abs n2') div gcd')
81.380 + val prop = Trueprop $ (mk_equality (t, rhs))
81.381 + in SOME (mk_thmid thmid op0 n1 n2, prop) end
81.382 + end
81.383 + | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE))
81.384 +
81.385 + | eval_cancel _ _ _ _ = NONE;
81.386 +
81.387 +(*. get the argument from a function-definition.*)
81.388 +(*("argument_in" ,("Atools.argument'_in",
81.389 + eval_argument_in "Atools.argument'_in"))*)
81.390 +fun eval_argument_in _ "Atools.argument'_in"
81.391 + (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ =
81.392 + if is_Free arg (*could be something to be simplified before*)
81.393 + then SOME (term2str t ^ " = " ^ term2str arg,
81.394 + Trueprop $ (mk_equality (t, arg)))
81.395 + else NONE
81.396 + | eval_argument_in _ _ _ _ = NONE;
81.397 +
81.398 +(*.check if the function-identifier of the first argument matches
81.399 + the function-identifier of the lhs of the second argument.*)
81.400 +(*("sameFunId" ,("Atools.sameFunId",
81.401 + eval_same_funid "Atools.sameFunId"))*)
81.402 +fun eval_sameFunId _ "Atools.sameFunId"
81.403 + (p as Const ("Atools.sameFunId",_) $
81.404 + (f1 $ _) $
81.405 + (Const ("op =", _) $ (f2 $ _) $ _)) _ =
81.406 + if f1 = f2
81.407 + then SOME ((term2str p) ^ " = True",
81.408 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
81.409 + else SOME ((term2str p) ^ " = False",
81.410 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
81.411 +| eval_sameFunId _ _ _ _ = NONE;
81.412 +
81.413 +
81.414 +(*.from a list of fun-definitions "f x = ..." as 2nd argument
81.415 + filter the elements with the same fun-identfier in "f y"
81.416 + as the fst argument;
81.417 + this is, because Isabelles filter takes more than 1 sec.*)
81.418 +fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2
81.419 + | same_funid f1 t = raise error ("same_funid called with t = ("
81.420 + ^term2str f1^") ("^term2str t^")");
81.421 +(*("filter_sameFunId" ,("Atools.filter'_sameFunId",
81.422 + eval_filter_sameFunId "Atools.filter'_sameFunId"))*)
81.423 +fun eval_filter_sameFunId _ "Atools.filter'_sameFunId"
81.424 + (p as Const ("Atools.filter'_sameFunId",_) $
81.425 + (fid $ _) $ fs) _ =
81.426 + let val fs' = ((list2isalist HOLogic.boolT) o
81.427 + (filter (same_funid fid))) (isalist2list fs)
81.428 + in SOME (term2str (mk_equality (p, fs')),
81.429 + Trueprop $ (mk_equality (p, fs'))) end
81.430 +| eval_filter_sameFunId _ _ _ _ = NONE;
81.431 +
81.432 +
81.433 +(*make a list of terms to a sum*)
81.434 +fun list2sum [] = error ("list2sum called with []")
81.435 + | list2sum [s] = s
81.436 + | list2sum (s::ss) =
81.437 + let fun sum su [s'] =
81.438 + Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
81.439 + $ su $ s'
81.440 + | sum su (s'::ss') =
81.441 + sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
81.442 + $ su $ s') ss'
81.443 + in sum s ss end;
81.444 +
81.445 +(*make a list of equalities to the sum of the lhs*)
81.446 +(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*)
81.447 +fun eval_boollist2sum _ "Atools.boollist2sum"
81.448 + (p as Const ("Atools.boollist2sum", _) $
81.449 + (l as Const ("List.list.Cons", _) $ _ $ _)) _ =
81.450 + let val isal = isalist2list l
81.451 + val lhss = map lhs isal
81.452 + val sum = list2sum lhss
81.453 + in SOME ((term2str p) ^ " = " ^ (term2str sum),
81.454 + Trueprop $ (mk_equality (p, sum)))
81.455 + end
81.456 +| eval_boollist2sum _ _ _ _ = NONE;
81.457 +
81.458 +
81.459 +
81.460 +local
81.461 +
81.462 +open Term;
81.463 +
81.464 +in
81.465 +fun termlessI (_:subst) uv = termless uv;
81.466 +fun term_ordI (_:subst) uv = term_ord uv;
81.467 +end;
81.468 +
81.469 +
81.470 +(** rule set, for evaluating list-expressions in scripts 8.01.02 **)
81.471 +
81.472 +
81.473 +val list_rls =
81.474 + append_rls "list_rls" list_rls
81.475 + [Calc ("op *",eval_binop "#mult_"),
81.476 + Calc ("op +", eval_binop "#add_"),
81.477 + Calc ("op <",eval_equ "#less_"),
81.478 + Calc ("op <=",eval_equ "#less_equal_"),
81.479 + Calc ("Atools.ident",eval_ident "#ident_"),
81.480 + Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*)
81.481 +
81.482 + Calc ("Tools.Vars",eval_var "#Vars_"),
81.483 +
81.484 + Thm ("if_True",num_str if_True),
81.485 + Thm ("if_False",num_str if_False)
81.486 + ];
81.487 +
81.488 +ruleset' := overwritelthy thy (!ruleset',
81.489 + [("list_rls",list_rls)
81.490 + ]);
81.491 +
81.492 +(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*)
81.493 +val tless_true = dummy_ord;
81.494 +rew_ord' := overwritel (!rew_ord',
81.495 + [("tless_true", tless_true),
81.496 + ("e_rew_ord'", tless_true),
81.497 + ("dummy_ord", dummy_ord)]);
81.498 +
81.499 +val calculate_Atools =
81.500 + append_rls "calculate_Atools" e_rls
81.501 + [Calc ("op <",eval_equ "#less_"),
81.502 + Calc ("op <=",eval_equ "#less_equal_"),
81.503 + Calc ("op =",eval_equal "#equal_"),
81.504 +
81.505 + Thm ("real_unari_minus",num_str real_unari_minus),
81.506 + Calc ("op +",eval_binop "#add_"),
81.507 + Calc ("op -",eval_binop "#sub_"),
81.508 + Calc ("op *",eval_binop "#mult_")
81.509 + ];
81.510 +
81.511 +val Atools_erls =
81.512 + append_rls "Atools_erls" e_rls
81.513 + [Calc ("op =",eval_equal "#equal_"),
81.514 + Thm ("not_true",num_str not_true),
81.515 + (*"(~ True) = False"*)
81.516 + Thm ("not_false",num_str not_false),
81.517 + (*"(~ False) = True"*)
81.518 + Thm ("and_true",and_true),
81.519 + (*"(?a & True) = ?a"*)
81.520 + Thm ("and_false",and_false),
81.521 + (*"(?a & False) = False"*)
81.522 + Thm ("or_true",or_true),
81.523 + (*"(?a | True) = True"*)
81.524 + Thm ("or_false",or_false),
81.525 + (*"(?a | False) = ?a"*)
81.526 +
81.527 + Thm ("rat_leq1",rat_leq1),
81.528 + Thm ("rat_leq2",rat_leq2),
81.529 + Thm ("rat_leq3",rat_leq3),
81.530 + Thm ("refl",num_str refl),
81.531 + Thm ("le_refl",num_str le_refl),
81.532 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
81.533 +
81.534 + Calc ("op <",eval_equ "#less_"),
81.535 + Calc ("op <=",eval_equ "#less_equal_"),
81.536 +
81.537 + Calc ("Atools.ident",eval_ident "#ident_"),
81.538 + Calc ("Atools.is'_const",eval_const "#is_const_"),
81.539 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
81.540 + Calc ("Tools.matches",eval_matches "")
81.541 + ];
81.542 +
81.543 +val Atools_crls =
81.544 + append_rls "Atools_crls" e_rls
81.545 + [Calc ("op =",eval_equal "#equal_"),
81.546 + Thm ("not_true",num_str not_true),
81.547 + Thm ("not_false",num_str not_false),
81.548 + Thm ("and_true",and_true),
81.549 + Thm ("and_false",and_false),
81.550 + Thm ("or_true",or_true),
81.551 + Thm ("or_false",or_false),
81.552 +
81.553 + Thm ("rat_leq1",rat_leq1),
81.554 + Thm ("rat_leq2",rat_leq2),
81.555 + Thm ("rat_leq3",rat_leq3),
81.556 + Thm ("refl",num_str refl),
81.557 + Thm ("le_refl",num_str le_refl),
81.558 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
81.559 +
81.560 + Calc ("op <",eval_equ "#less_"),
81.561 + Calc ("op <=",eval_equ "#less_equal_"),
81.562 +
81.563 + Calc ("Atools.ident",eval_ident "#ident_"),
81.564 + Calc ("Atools.is'_const",eval_const "#is_const_"),
81.565 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
81.566 + Calc ("Tools.matches",eval_matches "")
81.567 + ];
81.568 +
81.569 +(*val atools_erls = ... waere zu testen ...
81.570 + merge_rls calculate_Atools
81.571 + (append_rls Atools_erls (*i.A. zu viele rules*)
81.572 + [Calc ("Atools.ident",eval_ident "#ident_"),
81.573 + Calc ("Atools.is'_const",eval_const "#is_const_"),
81.574 + Calc ("Atools.occurs'_in",
81.575 + eval_occurs_in "#occurs_in"),
81.576 + Calc ("Tools.matches",eval_matches "#matches")
81.577 + ] (*i.A. zu viele rules*)
81.578 + );*)
81.579 +(* val atools_erls = prep_rls(
81.580 + Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI),
81.581 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
81.582 + rules = [Thm ("refl",num_str refl),
81.583 + Thm ("le_refl",num_str le_refl),
81.584 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
81.585 + Thm ("not_true",num_str not_true),
81.586 + Thm ("not_false",num_str not_false),
81.587 + Thm ("and_true",and_true),
81.588 + Thm ("and_false",and_false),
81.589 + Thm ("or_true",or_true),
81.590 + Thm ("or_false",or_false),
81.591 + Thm ("and_commute",num_str and_commute),
81.592 + Thm ("or_commute",num_str or_commute),
81.593 +
81.594 + Calc ("op <",eval_equ "#less_"),
81.595 + Calc ("op <=",eval_equ "#less_equal_"),
81.596 +
81.597 + Calc ("Atools.ident",eval_ident "#ident_"),
81.598 + Calc ("Atools.is'_const",eval_const "#is_const_"),
81.599 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
81.600 + Calc ("Tools.matches",eval_matches "")
81.601 + ],
81.602 + scr = Script ((term_of o the o (parse thy))
81.603 + "empty_script")
81.604 + }:rls);
81.605 +ruleset' := overwritelth thy
81.606 + (!ruleset',
81.607 + [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*)
81.608 + ]);
81.609 +*)
81.610 +"******* Atools.ML end *******";
81.611 +
81.612 +calclist':= overwritel (!calclist',
81.613 + [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")),
81.614 + ("some_occur_in",
81.615 + ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")),
81.616 + ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")),
81.617 + ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")),
81.618 + ("is_const" ,("Atools.is'_const",eval_const "#is_const_")),
81.619 + ("le" ,("op <" ,eval_equ "#less_")),
81.620 + ("leq" ,("op <=" ,eval_equ "#less_equal_")),
81.621 + ("ident" ,("Atools.ident",eval_ident "#ident_")),
81.622 + ("equal" ,("op =",eval_equal "#equal_")),
81.623 + ("PLUS" ,("op +" ,eval_binop "#add_")),
81.624 + ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls
81.625 + no script with "minus"*)
81.626 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
81.627 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
81.628 + ("POWER" ,("Atools.pow" ,eval_binop "#power_")),
81.629 + ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum ""))
81.630 + ]);
81.631 +
81.632 +val list_rls = prep_rls(
81.633 + merge_rls "list_erls"
81.634 + (Rls {id="replaced",preconds = [],
81.635 + rew_ord = ("termlessI", termlessI),
81.636 + erls = Rls {id="list_elrs", preconds = [],
81.637 + rew_ord = ("termlessI",termlessI),
81.638 + erls = e_rls,
81.639 + srls = Erls, calc = [], (*asm_thm = [],*)
81.640 + rules = [Calc ("op +", eval_binop "#add_"),
81.641 + Calc ("op <",eval_equ "#less_")
81.642 + (* ~~~~~~ for nth_Cons_*)
81.643 + ],
81.644 + scr = EmptyScr},
81.645 + srls = Erls, calc = [], (*asm_thm = [], *)
81.646 + rules = [], scr = EmptyScr})
81.647 + list_rls);
81.648 +ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]);
82.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
82.2 +++ b/src/Tools/isac/Knowledge/Atools.thy Wed Aug 25 16:20:07 2010 +0200
82.3 @@ -0,0 +1,711 @@
82.4 +(* Title: tools for arithmetic
82.5 + Author: Walther Neuper 010308
82.6 + (c) due to copyright terms
82.7 +
82.8 +remove_thy"Atools";
82.9 +use_thy"Knowledge/Atools";
82.10 +use_thy"Knowledge/Isac";
82.11 +
82.12 +use_thy_only"Knowledge/Atools";
82.13 +use_thy"Knowledge/Isac";
82.14 +*)
82.15 +
82.16 +theory Atools imports Descript Typefix begin
82.17 +
82.18 +consts
82.19 +
82.20 + Arbfix :: "real"
82.21 + Undef :: "real"
82.22 + dummy :: "real"
82.23 +
82.24 + some'_occur'_in :: "[real list, 'a] => bool" ("some'_of _ occur'_in _")
82.25 + occurs'_in :: "[real , 'a] => bool" ("_ occurs'_in _")
82.26 +
82.27 + pow :: "[real, real] => real" (infixr "^^^" 80)
82.28 +(* ~~~ power doesn't allow Free("2",real) ^ Free("2",nat)
82.29 + ~~~~ ~~~~ ~~~~ ~~~*)
82.30 +(*WN0603 at Frontend encoded strings to '^',
82.31 + see 'fun encode', fun 'decode'*)
82.32 +
82.33 + abs :: "real => real" ("(|| _ ||)")
82.34 +(* ~~~ FIXXXME Isabelle2002 has abs already !!!*)
82.35 + absset :: "real set => real" ("(||| _ |||)")
82.36 + (*is numeral constant ?*)
82.37 + is'_const :: "real => bool" ("_ is'_const" 10)
82.38 + (*is_const rename to is_num FIXXXME.WN.16.5.03 *)
82.39 + is'_atom :: "real => bool" ("_ is'_atom" 10)
82.40 + is'_even :: "real => bool" ("_ is'_even" 10)
82.41 +
82.42 + (* identity on term level*)
82.43 + ident :: "['a, 'a] => bool" ("(_ =!=/ _)" [51, 51] 50)
82.44 +
82.45 + argument'_in :: "real => real" ("argument'_in _" 10)
82.46 + sameFunId :: "[real, bool] => bool" (**"same'_funid _ _" 10
82.47 + WN0609 changed the id, because ".. _ _" inhibits currying**)
82.48 + filter'_sameFunId:: "[real, bool list] => bool list"
82.49 + ("filter'_sameFunId _ _" 10)
82.50 + boollist2sum :: "bool list => real"
82.51 +
82.52 +axioms (*for evaluating the assumptions of conditional rules*)
82.53 +
82.54 + last_thmI "lastI (x#xs) = (if xs =!= [] then x else lastI xs)"
82.55 + real_unari_minus "- a = (-1) * a" (*Isa!*)
82.56 +
82.57 + rle_refl "(n::real) <= n"
82.58 +(*reflI "(t = t) = True"*)
82.59 + radd_left_cancel_le "((k::real) + m <= k + n) = (m <= n)"
82.60 + not_true "(~ True) = False"
82.61 + not_false "(~ False) = True"
82.62 + and_true "(a & True) = a"
82.63 + and_false "(a & False) = False"
82.64 + or_true "(a | True) = True"
82.65 + or_false "(a | False) = a"
82.66 + and_commute "(a & b) = (b & a)"
82.67 + or_commute "(a | b) = (b | a)"
82.68 +
82.69 + (*.should be in Rational.thy, but:
82.70 + needed for asms in e.g. d2_pqformula1 in PolyEq.ML, RootEq.ML.*)
82.71 + rat_leq1 "[| b ~= 0; d ~= 0 |] ==> \
82.72 + \((a / b) <= (c / d)) = ((a*d) <= (b*c))"(*Isa?*)
82.73 + rat_leq2 "d ~= 0 ==> \
82.74 + \( a <= (c / d)) = ((a*d) <= c )"(*Isa?*)
82.75 + rat_leq3 "b ~= 0 ==> \
82.76 + \((a / b) <= c ) = ( a <= (b*c))"(*Isa?*)
82.77 +
82.78 +text {*copy from doc/math-eng.tex WN.28.3.03
82.79 +WN071228 extended *}
82.80 +
82.81 +
82.82 +section {*Coding standards*}
82.83 +subsection {*Identifiers*}
82.84 +text {*Naming is particularily crucial, because Isabelles name space is global, and isac does not yet use the novel locale features introduces by Isar. For instance, {\tt probe} sounds reasonable as (1) a description in the model of a problem-pattern, (2) as an element of the problem hierarchies key, (3) as a socalled CAS-command, (4) as the name of a related script etc. However, all the cases (1)..(4) require different typing for one and the same identifier {\tt probe} which is impossible, and actually leads to strange errors (for instance (1) is used as string, except in a script addressing a Subproblem).
82.85 +
82.86 +This are the preliminary rules for naming identifiers>
82.87 +\begin{description}
82.88 +\item [elements of a key] into the hierarchy of problems or methods must not contain capital letters and may contain underscrores, e.g. {\tt probe, for_polynomials}.
82.89 +\item [descriptions in problem-patterns] must contain at least 1 capital letter and must not contain underscores, e.g. {\tt Probe, forPolynomials}.
82.90 +\item [CAS-commands] follow the same rules as descriptions in problem-patterns above, thus beware of conflicts~!
82.91 +\item [script identifiers] always end with {\tt Script}, e.g. {\tt ProbeScript}.
82.92 +\item [???] ???
82.93 +\item [???] ???
82.94 +\end{description}
82.95 +%WN071228 extended *}
82.96 +
82.97 +subsection {*Rule sets*}
82.98 +text {*The actual version of the coding standards for rulesets is in {\tt /Knowledge/Atools.ML where it can be viewed using the knowledge browsers.
82.99 +
82.100 +There are rulesets visible to the student, and there are rulesets visible (in general) only for math authors. There are also rulesets which {\em must} exist for {\em each} theory; these contain the identifier of the respective theory (including all capital letters) as indicated by {\it Thy} below.
82.101 +\begin{description}
82.102 +
82.103 +\item [norm\_{\it Thy}] exists for each theory, and {\em efficiently} calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents).
82.104 +
82.105 +\item [simplify\_{\it Thy}] exists for each theory, and calculates a normalform for all terms which can be expressed by the definitions of the respective theory (and the respective parents) such, that the rewrites can be presented to the student.
82.106 +
82.107 +\item [calculate\_{\it Thy}] exists for each theory, and evaluates terms with numerical constants only (i.e. all terms which can be expressed by the definitions of the respective theory and the respective parent theories). In particular, this ruleset includes evaluating in/equalities with numerical constants only.
82.108 +WN.3.7.03: may be dropped due to more generality: numericals and non-numericals are logically equivalent, where the latter often add to the assumptions (e.g. in Check_elementwise).
82.109 +\end{description}
82.110 +
82.111 +The above rulesets are all visible to the user, and also may be input; thus they must be contained in the global associationlist {\tt ruleset':= }~! All these rulesets must undergo a preparation using the function {\tt prep_rls}, which generates a script for stepwise rewriting etc.
82.112 +The following rulesets are used for internal purposes and usually invisible to the (naive) user:
82.113 +\begin{description}
82.114 +
82.115 +\item [*\_erls]
82.116 +\item [*\_prls]
82.117 +\item [*\_srls]
82.118 +
82.119 +\end{description}
82.120 +{\tt append_rls, merge_rls, remove_rls}
82.121 +*}
82.122 +
82.123 +ML {*
82.124 +
82.125 +(** evaluation of numerals and special predicates on the meta-level **)
82.126 +(*-------------------------functions---------------------*)
82.127 +local (* rlang 09.02 *)
82.128 + (*.a 'c is coefficient of v' if v does occur in c.*)
82.129 + fun coeff_in v c = member op = (vars c) v;
82.130 +in
82.131 + fun occurs_in v t = coeff_in v t;
82.132 +end;
82.133 +
82.134 +(*("occurs_in", ("Atools.occurs'_in", eval_occurs_in ""))*)
82.135 +fun eval_occurs_in _ "Atools.occurs'_in"
82.136 + (p as (Const ("Atools.occurs'_in",_) $ v $ t)) _ =
82.137 + ((*writeln("@@@ eval_occurs_in: v= "^(term2str v));
82.138 + writeln("@@@ eval_occurs_in: t= "^(term2str t));*)
82.139 + if occurs_in v t
82.140 + then SOME ((term2str p) ^ " = True",
82.141 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
82.142 + else SOME ((term2str p) ^ " = False",
82.143 + Trueprop $ (mk_equality (p, HOLogic.false_const))))
82.144 + | eval_occurs_in _ _ _ _ = NONE;
82.145 +
82.146 +(*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*)
82.147 +fun some_occur_in vs t =
82.148 + let fun occurs_in' a b = occurs_in b a
82.149 + in foldl or_ (false, map (occurs_in' t) vs) end;
82.150 +
82.151 +(*("some_occur_in", ("Atools.some'_occur'_in",
82.152 + eval_some_occur_in "#eval_some_occur_in_"))*)
82.153 +fun eval_some_occur_in _ "Atools.some'_occur'_in"
82.154 + (p as (Const ("Atools.some'_occur'_in",_)
82.155 + $ vs $ t)) _ =
82.156 + if some_occur_in (isalist2list vs) t
82.157 + then SOME ((term2str p) ^ " = True",
82.158 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
82.159 + else SOME ((term2str p) ^ " = False",
82.160 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
82.161 + | eval_some_occur_in _ _ _ _ = NONE;
82.162 +
82.163 +
82.164 +
82.165 +
82.166 +(*evaluate 'is_atom'*)
82.167 +(*("is_atom",("Atools.is'_atom",eval_is_atom "#is_atom_"))*)
82.168 +fun eval_is_atom (thmid:string) "Atools.is'_atom"
82.169 + (t as (Const(op0,_) $ arg)) thy =
82.170 + (case arg of
82.171 + Free (n,_) => SOME (mk_thmid thmid op0 n "",
82.172 + Trueprop $ (mk_equality (t, true_as_term)))
82.173 + | _ => SOME (mk_thmid thmid op0 "" "",
82.174 + Trueprop $ (mk_equality (t, false_as_term))))
82.175 + | eval_is_atom _ _ _ _ = NONE;
82.176 +
82.177 +(*evaluate 'is_even'*)
82.178 +fun even i = (i div 2) * 2 = i;
82.179 +(*("is_even",("Atools.is'_even",eval_is_even "#is_even_"))*)
82.180 +fun eval_is_even (thmid:string) "Atools.is'_even"
82.181 + (t as (Const(op0,_) $ arg)) thy =
82.182 + (case arg of
82.183 + Free (n,_) =>
82.184 + (case int_of_str n of
82.185 + SOME i =>
82.186 + if even i then SOME (mk_thmid thmid op0 n "",
82.187 + Trueprop $ (mk_equality (t, true_as_term)))
82.188 + else SOME (mk_thmid thmid op0 "" "",
82.189 + Trueprop $ (mk_equality (t, false_as_term)))
82.190 + | _ => NONE)
82.191 + | _ => NONE)
82.192 + | eval_is_even _ _ _ _ = NONE;
82.193 +
82.194 +(*evaluate 'is_const'*)
82.195 +(*("is_const",("Atools.is'_const",eval_const "#is_const_"))*)
82.196 +fun eval_const (thmid:string) _(*"Atools.is'_const" WN050820 diff.beh. rooteq*)
82.197 + (t as (Const(op0,t0) $ arg)) (thy:theory) =
82.198 + (*eval_const FIXXXXXME.WN.16.5.03 still forgets ComplexI*)
82.199 + (case arg of
82.200 + Const (n1,_) =>
82.201 + SOME (mk_thmid thmid op0 n1 "",
82.202 + Trueprop $ (mk_equality (t, false_as_term)))
82.203 + | Free (n1,_) =>
82.204 + if is_numeral n1
82.205 + then SOME (mk_thmid thmid op0 n1 "",
82.206 + Trueprop $ (mk_equality (t, true_as_term)))
82.207 + else SOME (mk_thmid thmid op0 n1 "",
82.208 + Trueprop $ (mk_equality (t, false_as_term)))
82.209 + | Const ("Float.Float",_) =>
82.210 + SOME (mk_thmid thmid op0 (term2str arg) "",
82.211 + Trueprop $ (mk_equality (t, true_as_term)))
82.212 + | _ => (*NONE*)
82.213 + SOME (mk_thmid thmid op0 (term2str arg) "",
82.214 + Trueprop $ (mk_equality (t, false_as_term))))
82.215 + | eval_const _ _ _ _ = NONE;
82.216 +
82.217 +(*. evaluate binary, associative, commutative operators: *,+,^ .*)
82.218 +(*("PLUS" ,("op +" ,eval_binop "#add_")),
82.219 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
82.220 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))*)
82.221 +
82.222 +(* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) =
82.223 + ("xxxxxx",op_,t,thy);
82.224 + *)
82.225 +fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) =
82.226 + thmid ^ "Float ((" ^
82.227 + (string_of_int v11)^","^(string_of_int v12)^"), ("^
82.228 + (string_of_int p11)^","^(string_of_int p12)^")) __ (("^
82.229 + (string_of_int v21)^","^(string_of_int v22)^"), ("^
82.230 + (string_of_int p21)^","^(string_of_int p22)^"))";
82.231 +
82.232 +(*.convert int and float to internal floatingpoint prepresentation.*)
82.233 +fun numeral (Free (str, T)) =
82.234 + (case int_of_str str of
82.235 + SOME i => SOME ((i, 0), (0, 0))
82.236 + | NONE => NONE)
82.237 + | numeral (Const ("Float.Float", _) $
82.238 + (Const ("Pair", _) $
82.239 + (Const ("Pair", T) $ Free (v1, _) $ Free (v2,_)) $
82.240 + (Const ("Pair", _) $ Free (p1, _) $ Free (p2,_))))=
82.241 + (case (int_of_str v1, int_of_str v2, int_of_str p1, int_of_str p2) of
82.242 + (SOME v1', SOME v2', SOME p1', SOME p2') =>
82.243 + SOME ((v1', v2'), (p1', p2'))
82.244 + | _ => NONE)
82.245 + | numeral _ = NONE;
82.246 +
82.247 +(*.evaluate binary associative operations.*)
82.248 +fun eval_binop (thmid:string) (op_:string)
82.249 + (t as ( Const(op0,t0) $
82.250 + (Const(op0',t0') $ v $ t1) $ t2))
82.251 + thy = (*binary . (v.n1).n2*)
82.252 + if op0 = op0' then
82.253 + case (numeral t1, numeral t2) of
82.254 + (SOME n1, SOME n2) =>
82.255 + let val (T1,T2,Trange) = dest_binop_typ t0
82.256 + val res = calc (if op0 = "op -" then "op +" else op0) n1 n2
82.257 + (*WN071229 "HOL.divide" never tried*)
82.258 + val rhs = var_op_float v op_ t0 T1 res
82.259 + val prop = Trueprop $ (mk_equality (t, rhs))
82.260 + in SOME (mk_thmid_f thmid n1 n2, prop) end
82.261 + | _ => NONE
82.262 + else NONE
82.263 + | eval_binop (thmid:string) (op_:string)
82.264 + (t as
82.265 + (Const (op0, t0) $ t1 $
82.266 + (Const (op0', t0') $ t2 $ v)))
82.267 + thy = (*binary . n1.(n2.v)*)
82.268 + if op0 = op0' then
82.269 + case (numeral t1, numeral t2) of
82.270 + (SOME n1, SOME n2) =>
82.271 + if op0 = "op -" then NONE else
82.272 + let val (T1,T2,Trange) = dest_binop_typ t0
82.273 + val res = calc op0 n1 n2
82.274 + val rhs = float_op_var v op_ t0 T1 res
82.275 + val prop = Trueprop $ (mk_equality (t, rhs))
82.276 + in SOME (mk_thmid_f thmid n1 n2, prop) end
82.277 + | _ => NONE
82.278 + else NONE
82.279 +
82.280 + | eval_binop (thmid:string) (op_:string)
82.281 + (t as (Const (op0,t0) $ t1 $ t2)) thy = (*binary . n1.n2*)
82.282 + (case (numeral t1, numeral t2) of
82.283 + (SOME n1, SOME n2) =>
82.284 + let val (T1,T2,Trange) = dest_binop_typ t0;
82.285 + val res = calc op0 n1 n2;
82.286 + val rhs = term_of_float Trange res;
82.287 + val prop = Trueprop $ (mk_equality (t, rhs));
82.288 + in SOME (mk_thmid_f thmid n1 n2, prop) end
82.289 + | _ => NONE)
82.290 + | eval_binop _ _ _ _ = NONE;
82.291 +(*
82.292 +> val SOME (thmid, t) = eval_binop "#add_" "op +" (str2term "-1 + 2") thy;
82.293 +> term2str t;
82.294 +val it = "-1 + 2 = 1"
82.295 +> val t = str2term "-1 * (-1 * a)";
82.296 +> val SOME (thmid, t) = eval_binop "#mult_" "op *" t thy;
82.297 +> term2str t;
82.298 +val it = "-1 * (-1 * a) = 1 * a"*)
82.299 +
82.300 +
82.301 +
82.302 +(*.evaluate < and <= for numerals.*)
82.303 +(*("le" ,("op <" ,eval_equ "#less_")),
82.304 + ("leq" ,("op <=" ,eval_equ "#less_equal_"))*)
82.305 +fun eval_equ (thmid:string) (op_:string) (t as
82.306 + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
82.307 + (case (int_of_str n1, int_of_str n2) of
82.308 + (SOME n1', SOME n2') =>
82.309 + if calc_equ (strip_thy op0) (n1', n2')
82.310 + then SOME (mk_thmid thmid op0 n1 n2,
82.311 + Trueprop $ (mk_equality (t, true_as_term)))
82.312 + else SOME (mk_thmid thmid op0 n1 n2,
82.313 + Trueprop $ (mk_equality (t, false_as_term)))
82.314 + | _ => NONE)
82.315 +
82.316 + | eval_equ _ _ _ _ = NONE;
82.317 +
82.318 +
82.319 +(*evaluate identity
82.320 +> reflI;
82.321 +val it = "(?t = ?t) = True"
82.322 +> val t = str2term "x = 0";
82.323 +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
82.324 +
82.325 +> val t = str2term "1 = 0";
82.326 +> val NONE = rewrite_ thy dummy_ord e_rls false reflI t;
82.327 +----------- thus needs Calc !
82.328 +> val t = str2term "0 = 0";
82.329 +> val SOME (t',_) = rewrite_ thy dummy_ord e_rls false reflI t;
82.330 +> term2str t';
82.331 +val it = "True"
82.332 +
82.333 +val t = str2term "Not (x = 0)";
82.334 +atomt t; term2str t;
82.335 +*** -------------
82.336 +*** Const ( Not)
82.337 +*** . Const ( op =)
82.338 +*** . . Free ( x, )
82.339 +*** . . Free ( 0, )
82.340 +val it = "x ~= 0" : string*)
82.341 +
82.342 +(*.evaluate identity on the term-level, =!= ,i.e. without evaluation of
82.343 + the arguments: thus special handling by 'fun eval_binop'*)
82.344 +(*("ident" ,("Atools.ident",eval_ident "#ident_")):calc*)
82.345 +fun eval_ident (thmid:string) "Atools.ident" (t as
82.346 + (Const (op0,t0) $ t1 $ t2 )) thy =
82.347 + if t1 = t2
82.348 + then SOME (mk_thmid thmid op0
82.349 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
82.350 + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
82.351 + Trueprop $ (mk_equality (t, true_as_term)))
82.352 + else SOME (mk_thmid thmid op0
82.353 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
82.354 + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
82.355 + Trueprop $ (mk_equality (t, false_as_term)))
82.356 + | eval_ident _ _ _ _ = NONE;
82.357 +(* TODO
82.358 +> val t = str2term "x =!= 0";
82.359 +> val SOME (str, t') = eval_ident "ident_" "b" t thy;
82.360 +> term2str t';
82.361 +val str = "ident_(x)_(0)" : string
82.362 +val it = "(x =!= 0) = False" : string
82.363 +> val t = str2term "1 =!= 0";
82.364 +> val SOME (str, t') = eval_ident "ident_" "b" t thy;
82.365 +> term2str t';
82.366 +val str = "ident_(1)_(0)" : string
82.367 +val it = "(1 =!= 0) = False" : string
82.368 +> val t = str2term "0 =!= 0";
82.369 +> val SOME (str, t') = eval_ident "ident_" "b" t thy;
82.370 +> term2str t';
82.371 +val str = "ident_(0)_(0)" : string
82.372 +val it = "(0 =!= 0) = True" : string
82.373 +*)
82.374 +
82.375 +(*.evaluate identity of terms, which stay ready for evaluation in turn;
82.376 + thus returns False only for atoms.*)
82.377 +(*("equal" ,("op =",eval_equal "#equal_")):calc*)
82.378 +fun eval_equal (thmid:string) "op =" (t as
82.379 + (Const (op0,t0) $ t1 $ t2 )) thy =
82.380 + if t1 = t2
82.381 + then ((*writeln"... eval_equal: t1 = t2 --> True";*)
82.382 + SOME (mk_thmid thmid op0
82.383 + ("("^(Syntax.string_of_term (thy2ctxt thy) t1)^")")
82.384 + ("("^(Syntax.string_of_term (thy2ctxt thy) t2)^")"),
82.385 + Trueprop $ (mk_equality (t, true_as_term)))
82.386 + )
82.387 + else (case (is_atom t1, is_atom t2) of
82.388 + (true, true) =>
82.389 + ((*writeln"... eval_equal: t1<>t2, is_atom t1,t2 --> False";*)
82.390 + SOME (mk_thmid thmid op0
82.391 + ("("^(term2str t1)^")") ("("^(term2str t2)^")"),
82.392 + Trueprop $ (mk_equality (t, false_as_term)))
82.393 + )
82.394 + | _ => ((*writeln"... eval_equal: t1<>t2, NOT is_atom t1,t2 --> go-on";*)
82.395 + NONE))
82.396 + | eval_equal _ _ _ _ = (writeln"... eval_equal: error-exit";
82.397 + NONE);
82.398 +(*
82.399 +val t = str2term "x ~= 0";
82.400 +val NONE = eval_equal "equal_" "b" t thy;
82.401 +
82.402 +
82.403 +> val t = str2term "(x + 1) = (x + 1)";
82.404 +> val SOME (str, t') = eval_equal "equal_" "b" t thy;
82.405 +> term2str t';
82.406 +val str = "equal_(x + 1)_(x + 1)" : string
82.407 +val it = "(x + 1 = x + 1) = True" : string
82.408 +> val t = str2term "x = 0";
82.409 +> val NONE = eval_equal "equal_" "b" t thy;
82.410 +
82.411 +> val t = str2term "1 = 0";
82.412 +> val SOME (str, t') = eval_equal "equal_" "b" t thy;
82.413 +> term2str t';
82.414 +val str = "equal_(1)_(0)" : string
82.415 +val it = "(1 = 0) = False" : string
82.416 +> val t = str2term "0 = 0";
82.417 +> val SOME (str, t') = eval_equal "equal_" "b" t thy;
82.418 +> term2str t';
82.419 +val str = "equal_(0)_(0)" : string
82.420 +val it = "(0 = 0) = True" : string
82.421 +*)
82.422 +
82.423 +
82.424 +(** evaluation on the metalevel **)
82.425 +
82.426 +(*. evaluate HOL.divide .*)
82.427 +(*("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_"))*)
82.428 +fun eval_cancel (thmid:string) "HOL.divide" (t as
82.429 + (Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2))) thy =
82.430 + (case (int_of_str n1, int_of_str n2) of
82.431 + (SOME n1', SOME n2') =>
82.432 + let
82.433 + val sg = sign2 n1' n2';
82.434 + val (T1,T2,Trange) = dest_binop_typ t0;
82.435 + val gcd' = gcd (abs n1') (abs n2');
82.436 + in if gcd' = abs n2'
82.437 + then let val rhs = term_of_num Trange (sg * (abs n1') div gcd')
82.438 + val prop = Trueprop $ (mk_equality (t, rhs))
82.439 + in SOME (mk_thmid thmid op0 n1 n2, prop) end
82.440 + else if 0 < n2' andalso gcd' = 1 then NONE
82.441 + else let val rhs = num_op_num T1 T2 (op0,t0) (sg * (abs n1') div gcd')
82.442 + ((abs n2') div gcd')
82.443 + val prop = Trueprop $ (mk_equality (t, rhs))
82.444 + in SOME (mk_thmid thmid op0 n1 n2, prop) end
82.445 + end
82.446 + | _ => ((*writeln"@@@ eval_cancel NONE";*)NONE))
82.447 +
82.448 + | eval_cancel _ _ _ _ = NONE;
82.449 +
82.450 +(*. get the argument from a function-definition.*)
82.451 +(*("argument_in" ,("Atools.argument'_in",
82.452 + eval_argument_in "Atools.argument'_in"))*)
82.453 +fun eval_argument_in _ "Atools.argument'_in"
82.454 + (t as (Const ("Atools.argument'_in", _) $ (f $ arg))) _ =
82.455 + if is_Free arg (*could be something to be simplified before*)
82.456 + then SOME (term2str t ^ " = " ^ term2str arg,
82.457 + Trueprop $ (mk_equality (t, arg)))
82.458 + else NONE
82.459 + | eval_argument_in _ _ _ _ = NONE;
82.460 +
82.461 +(*.check if the function-identifier of the first argument matches
82.462 + the function-identifier of the lhs of the second argument.*)
82.463 +(*("sameFunId" ,("Atools.sameFunId",
82.464 + eval_same_funid "Atools.sameFunId"))*)
82.465 +fun eval_sameFunId _ "Atools.sameFunId"
82.466 + (p as Const ("Atools.sameFunId",_) $
82.467 + (f1 $ _) $
82.468 + (Const ("op =", _) $ (f2 $ _) $ _)) _ =
82.469 + if f1 = f2
82.470 + then SOME ((term2str p) ^ " = True",
82.471 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
82.472 + else SOME ((term2str p) ^ " = False",
82.473 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
82.474 +| eval_sameFunId _ _ _ _ = NONE;
82.475 +
82.476 +
82.477 +(*.from a list of fun-definitions "f x = ..." as 2nd argument
82.478 + filter the elements with the same fun-identfier in "f y"
82.479 + as the fst argument;
82.480 + this is, because Isabelles filter takes more than 1 sec.*)
82.481 +fun same_funid f1 (Const ("op =", _) $ (f2 $ _) $ _) = f1 = f2
82.482 + | same_funid f1 t = raise error ("same_funid called with t = ("
82.483 + ^term2str f1^") ("^term2str t^")");
82.484 +(*("filter_sameFunId" ,("Atools.filter'_sameFunId",
82.485 + eval_filter_sameFunId "Atools.filter'_sameFunId"))*)
82.486 +fun eval_filter_sameFunId _ "Atools.filter'_sameFunId"
82.487 + (p as Const ("Atools.filter'_sameFunId",_) $
82.488 + (fid $ _) $ fs) _ =
82.489 + let val fs' = ((list2isalist HOLogic.boolT) o
82.490 + (filter (same_funid fid))) (isalist2list fs)
82.491 + in SOME (term2str (mk_equality (p, fs')),
82.492 + Trueprop $ (mk_equality (p, fs'))) end
82.493 +| eval_filter_sameFunId _ _ _ _ = NONE;
82.494 +
82.495 +
82.496 +(*make a list of terms to a sum*)
82.497 +fun list2sum [] = error ("list2sum called with []")
82.498 + | list2sum [s] = s
82.499 + | list2sum (s::ss) =
82.500 + let fun sum su [s'] =
82.501 + Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
82.502 + $ su $ s'
82.503 + | sum su (s'::ss') =
82.504 + sum (Const ("op +", [HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
82.505 + $ su $ s') ss'
82.506 + in sum s ss end;
82.507 +
82.508 +(*make a list of equalities to the sum of the lhs*)
82.509 +(*("boollist2sum" ,("Atools.boollist2sum" ,eval_boollist2sum "")):calc*)
82.510 +fun eval_boollist2sum _ "Atools.boollist2sum"
82.511 + (p as Const ("Atools.boollist2sum", _) $
82.512 + (l as Const ("List.list.Cons", _) $ _ $ _)) _ =
82.513 + let val isal = isalist2list l
82.514 + val lhss = map lhs isal
82.515 + val sum = list2sum lhss
82.516 + in SOME ((term2str p) ^ " = " ^ (term2str sum),
82.517 + Trueprop $ (mk_equality (p, sum)))
82.518 + end
82.519 +| eval_boollist2sum _ _ _ _ = NONE;
82.520 +
82.521 +
82.522 +
82.523 +local
82.524 +
82.525 +open Term;
82.526 +
82.527 +in
82.528 +fun termlessI (_:subst) uv = termless uv;
82.529 +fun term_ordI (_:subst) uv = term_ord uv;
82.530 +end;
82.531 +
82.532 +
82.533 +(** rule set, for evaluating list-expressions in scripts 8.01.02 **)
82.534 +
82.535 +
82.536 +val list_rls =
82.537 + append_rls "list_rls" list_rls
82.538 + [Calc ("op *",eval_binop "#mult_"),
82.539 + Calc ("op +", eval_binop "#add_"),
82.540 + Calc ("op <",eval_equ "#less_"),
82.541 + Calc ("op <=",eval_equ "#less_equal_"),
82.542 + Calc ("Atools.ident",eval_ident "#ident_"),
82.543 + Calc ("op =",eval_equal "#equal_"),(*atom <> atom -> False*)
82.544 +
82.545 + Calc ("Tools.Vars",eval_var "#Vars_"),
82.546 +
82.547 + Thm ("if_True",num_str if_True),
82.548 + Thm ("if_False",num_str if_False)
82.549 + ];
82.550 +
82.551 +ruleset' := overwritelthy thy (!ruleset',
82.552 + [("list_rls",list_rls)
82.553 + ]);
82.554 +
82.555 +(*TODO.WN0509 reduce ids: tless_true = e_rew_ord' = e_rew_ord = dummy_ord*)
82.556 +val tless_true = dummy_ord;
82.557 +rew_ord' := overwritel (!rew_ord',
82.558 + [("tless_true", tless_true),
82.559 + ("e_rew_ord'", tless_true),
82.560 + ("dummy_ord", dummy_ord)]);
82.561 +
82.562 +val calculate_Atools =
82.563 + append_rls "calculate_Atools" e_rls
82.564 + [Calc ("op <",eval_equ "#less_"),
82.565 + Calc ("op <=",eval_equ "#less_equal_"),
82.566 + Calc ("op =",eval_equal "#equal_"),
82.567 +
82.568 + Thm ("real_unari_minus",num_str real_unari_minus),
82.569 + Calc ("op +",eval_binop "#add_"),
82.570 + Calc ("op -",eval_binop "#sub_"),
82.571 + Calc ("op *",eval_binop "#mult_")
82.572 + ];
82.573 +
82.574 +val Atools_erls =
82.575 + append_rls "Atools_erls" e_rls
82.576 + [Calc ("op =",eval_equal "#equal_"),
82.577 + Thm ("not_true",num_str not_true),
82.578 + (*"(~ True) = False"*)
82.579 + Thm ("not_false",num_str not_false),
82.580 + (*"(~ False) = True"*)
82.581 + Thm ("and_true",and_true),
82.582 + (*"(?a & True) = ?a"*)
82.583 + Thm ("and_false",and_false),
82.584 + (*"(?a & False) = False"*)
82.585 + Thm ("or_true",or_true),
82.586 + (*"(?a | True) = True"*)
82.587 + Thm ("or_false",or_false),
82.588 + (*"(?a | False) = ?a"*)
82.589 +
82.590 + Thm ("rat_leq1",rat_leq1),
82.591 + Thm ("rat_leq2",rat_leq2),
82.592 + Thm ("rat_leq3",rat_leq3),
82.593 + Thm ("refl",num_str refl),
82.594 + Thm ("le_refl",num_str le_refl),
82.595 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
82.596 +
82.597 + Calc ("op <",eval_equ "#less_"),
82.598 + Calc ("op <=",eval_equ "#less_equal_"),
82.599 +
82.600 + Calc ("Atools.ident",eval_ident "#ident_"),
82.601 + Calc ("Atools.is'_const",eval_const "#is_const_"),
82.602 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
82.603 + Calc ("Tools.matches",eval_matches "")
82.604 + ];
82.605 +
82.606 +val Atools_crls =
82.607 + append_rls "Atools_crls" e_rls
82.608 + [Calc ("op =",eval_equal "#equal_"),
82.609 + Thm ("not_true",num_str not_true),
82.610 + Thm ("not_false",num_str not_false),
82.611 + Thm ("and_true",and_true),
82.612 + Thm ("and_false",and_false),
82.613 + Thm ("or_true",or_true),
82.614 + Thm ("or_false",or_false),
82.615 +
82.616 + Thm ("rat_leq1",rat_leq1),
82.617 + Thm ("rat_leq2",rat_leq2),
82.618 + Thm ("rat_leq3",rat_leq3),
82.619 + Thm ("refl",num_str refl),
82.620 + Thm ("le_refl",num_str le_refl),
82.621 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
82.622 +
82.623 + Calc ("op <",eval_equ "#less_"),
82.624 + Calc ("op <=",eval_equ "#less_equal_"),
82.625 +
82.626 + Calc ("Atools.ident",eval_ident "#ident_"),
82.627 + Calc ("Atools.is'_const",eval_const "#is_const_"),
82.628 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
82.629 + Calc ("Tools.matches",eval_matches "")
82.630 + ];
82.631 +
82.632 +(*val atools_erls = ... waere zu testen ...
82.633 + merge_rls calculate_Atools
82.634 + (append_rls Atools_erls (*i.A. zu viele rules*)
82.635 + [Calc ("Atools.ident",eval_ident "#ident_"),
82.636 + Calc ("Atools.is'_const",eval_const "#is_const_"),
82.637 + Calc ("Atools.occurs'_in",
82.638 + eval_occurs_in "#occurs_in"),
82.639 + Calc ("Tools.matches",eval_matches "#matches")
82.640 + ] (*i.A. zu viele rules*)
82.641 + );*)
82.642 +(* val atools_erls = prep_rls(
82.643 + Rls {id="atools_erls",preconds = [], rew_ord = ("termlessI",termlessI),
82.644 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
82.645 + rules = [Thm ("refl",num_str refl),
82.646 + Thm ("le_refl",num_str le_refl),
82.647 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
82.648 + Thm ("not_true",num_str not_true),
82.649 + Thm ("not_false",num_str not_false),
82.650 + Thm ("and_true",and_true),
82.651 + Thm ("and_false",and_false),
82.652 + Thm ("or_true",or_true),
82.653 + Thm ("or_false",or_false),
82.654 + Thm ("and_commute",num_str and_commute),
82.655 + Thm ("or_commute",num_str or_commute),
82.656 +
82.657 + Calc ("op <",eval_equ "#less_"),
82.658 + Calc ("op <=",eval_equ "#less_equal_"),
82.659 +
82.660 + Calc ("Atools.ident",eval_ident "#ident_"),
82.661 + Calc ("Atools.is'_const",eval_const "#is_const_"),
82.662 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
82.663 + Calc ("Tools.matches",eval_matches "")
82.664 + ],
82.665 + scr = Script ((term_of o the o (parse thy))
82.666 + "empty_script")
82.667 + }:rls);
82.668 +ruleset' := overwritelth thy
82.669 + (!ruleset',
82.670 + [("atools_erls",atools_erls)(*FIXXXME:del with rls.rls'*)
82.671 + ]);
82.672 +*)
82.673 +"******* Atools.ML end *******";
82.674 +
82.675 +calclist':= overwritel (!calclist',
82.676 + [("occurs_in",("Atools.occurs'_in", eval_occurs_in "#occurs_in_")),
82.677 + ("some_occur_in",
82.678 + ("Atools.some'_occur'_in", eval_some_occur_in "#some_occur_in_")),
82.679 + ("is_atom" ,("Atools.is'_atom",eval_is_atom "#is_atom_")),
82.680 + ("is_even" ,("Atools.is'_even",eval_is_even "#is_even_")),
82.681 + ("is_const" ,("Atools.is'_const",eval_const "#is_const_")),
82.682 + ("le" ,("op <" ,eval_equ "#less_")),
82.683 + ("leq" ,("op <=" ,eval_equ "#less_equal_")),
82.684 + ("ident" ,("Atools.ident",eval_ident "#ident_")),
82.685 + ("equal" ,("op =",eval_equal "#equal_")),
82.686 + ("PLUS" ,("op +" ,eval_binop "#add_")),
82.687 + ("minus" ,("op -",eval_binop "#sub_")), (*040207 only for prep_rls
82.688 + no script with "minus"*)
82.689 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
82.690 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
82.691 + ("POWER" ,("Atools.pow" ,eval_binop "#power_")),
82.692 + ("boollist2sum",("Atools.boollist2sum",eval_boollist2sum ""))
82.693 + ]);
82.694 +
82.695 +val list_rls = prep_rls(
82.696 + merge_rls "list_erls"
82.697 + (Rls {id="replaced",preconds = [],
82.698 + rew_ord = ("termlessI", termlessI),
82.699 + erls = Rls {id="list_elrs", preconds = [],
82.700 + rew_ord = ("termlessI",termlessI),
82.701 + erls = e_rls,
82.702 + srls = Erls, calc = [], (*asm_thm = [],*)
82.703 + rules = [Calc ("op +", eval_binop "#add_"),
82.704 + Calc ("op <",eval_equ "#less_")
82.705 + (* ~~~~~~ for nth_Cons_*)
82.706 + ],
82.707 + scr = EmptyScr},
82.708 + srls = Erls, calc = [], (*asm_thm = [], *)
82.709 + rules = [], scr = EmptyScr})
82.710 + list_rls);
82.711 +ruleset' := overwritelthy thy (!ruleset', [("list_rls", list_rls)]);
82.712 +*}
82.713 +
82.714 +end
83.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
83.2 +++ b/src/Tools/isac/Knowledge/Biegelinie.ML Wed Aug 25 16:20:07 2010 +0200
83.3 @@ -0,0 +1,468 @@
83.4 +(* chapter 'Biegelinie' from the textbook:
83.5 + Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271.
83.6 + authors: Walther Neuper 2005
83.7 + (c) due to copyright terms
83.8 +
83.9 +use"Knowledge/Biegelinie.ML";
83.10 +use"Biegelinie.ML";
83.11 +
83.12 +remove_thy"Typefix";
83.13 +remove_thy"Biegelinie";
83.14 +use_thy"Knowledge/Isac";
83.15 +*)
83.16 +
83.17 +(** interface isabelle -- isac **)
83.18 +
83.19 +theory' := overwritel (!theory', [("Biegelinie.thy",Biegelinie.thy)]);
83.20 +
83.21 +(** theory elements **)
83.22 +
83.23 +store_isa ["IsacKnowledge"] [];
83.24 +store_thy Biegelinie.thy
83.25 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.26 +store_isa ["IsacKnowledge", theory2thyID Biegelinie.thy, "Theorems"]
83.27 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.28 +store_thm Biegelinie.thy ("Belastung_Querkraft", Belastung_Querkraft)
83.29 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.30 +store_thm Biegelinie.thy ("Moment_Neigung", Moment_Neigung)
83.31 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.32 +store_thm Biegelinie.thy ("Moment_Querkraft", Moment_Querkraft)
83.33 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.34 +store_thm Biegelinie.thy ("Neigung_Moment", Neigung_Moment)
83.35 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.36 +store_thm Biegelinie.thy ("Querkraft_Belastung", Querkraft_Belastung)
83.37 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.38 +store_thm Biegelinie.thy ("Querkraft_Moment", Querkraft_Moment)
83.39 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.40 +store_thm Biegelinie.thy ("make_fun_explicit", make_fun_explicit)
83.41 + ["Walther Neuper 2005 supported by a grant from NMI Austria"];
83.42 +
83.43 +
83.44 +(** problems **)
83.45 +
83.46 +store_pbt
83.47 + (prep_pbt Biegelinie.thy "pbl_bieg" [] e_pblID
83.48 + (["Biegelinien"],
83.49 + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]),
83.50 + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
83.51 + ("#Find" ,["Biegelinie b_"]),
83.52 + ("#Relate",["Randbedingungen rb_"])
83.53 + ],
83.54 + append_rls "e_rls" e_rls [],
83.55 + NONE,
83.56 + [["IntegrierenUndKonstanteBestimmen2"]]));
83.57 +
83.58 +store_pbt
83.59 + (prep_pbt Biegelinie.thy "pbl_bieg_mom" [] e_pblID
83.60 + (["MomentBestimmte","Biegelinien"],
83.61 + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__"]),
83.62 + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
83.63 + ("#Find" ,["Biegelinie b_"]),
83.64 + ("#Relate",["RandbedingungenBiegung rb_","RandbedingungenMoment rm_"])
83.65 + ],
83.66 + append_rls "e_rls" e_rls [],
83.67 + NONE,
83.68 + [["IntegrierenUndKonstanteBestimmen"]]));
83.69 +
83.70 +store_pbt
83.71 + (prep_pbt Biegelinie.thy "pbl_bieg_momg" [] e_pblID
83.72 + (["MomentGegebene","Biegelinien"],
83.73 + [],
83.74 + append_rls "e_rls" e_rls [],
83.75 + NONE,
83.76 + [["IntegrierenUndKonstanteBestimmen","2xIntegrieren"]]));
83.77 +
83.78 +store_pbt
83.79 + (prep_pbt Biegelinie.thy "pbl_bieg_einf" [] e_pblID
83.80 + (["einfache","Biegelinien"],
83.81 + [],
83.82 + append_rls "e_rls" e_rls [],
83.83 + NONE,
83.84 + [["IntegrierenUndKonstanteBestimmen","4x4System"]]));
83.85 +
83.86 +store_pbt
83.87 + (prep_pbt Biegelinie.thy "pbl_bieg_momquer" [] e_pblID
83.88 + (["QuerkraftUndMomentBestimmte","Biegelinien"],
83.89 + [],
83.90 + append_rls "e_rls" e_rls [],
83.91 + NONE,
83.92 + [["IntegrierenUndKonstanteBestimmen","1xIntegrieren"]]));
83.93 +
83.94 +store_pbt
83.95 + (prep_pbt Biegelinie.thy "pbl_bieg_vonq" [] e_pblID
83.96 + (["vonBelastungZu","Biegelinien"],
83.97 + [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]),
83.98 + ("#Find" ,["Funktionen funs___"])],
83.99 + append_rls "e_rls" e_rls [],
83.100 + NONE,
83.101 + [["Biegelinien","ausBelastung"]]));
83.102 +
83.103 +store_pbt
83.104 + (prep_pbt Biegelinie.thy "pbl_bieg_randbed" [] e_pblID
83.105 + (["setzeRandbedingungen","Biegelinien"],
83.106 + [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]),
83.107 + ("#Find" ,["Gleichungen equs___"])],
83.108 + append_rls "e_rls" e_rls [],
83.109 + NONE,
83.110 + [["Biegelinien","setzeRandbedingungenEin"]]));
83.111 +
83.112 +store_pbt
83.113 + (prep_pbt Biegelinie.thy "pbl_equ_fromfun" [] e_pblID
83.114 + (["makeFunctionTo","equation"],
83.115 + [("#Given" ,["functionEq fun_","substitution sub_"]),
83.116 + ("#Find" ,["equality equ___"])],
83.117 + append_rls "e_rls" e_rls [],
83.118 + NONE,
83.119 + [["Equation","fromFunction"]]));
83.120 +
83.121 +
83.122 +
83.123 +(** methods **)
83.124 +
83.125 +val srls = Rls {id="srls_IntegrierenUnd..",
83.126 + preconds = [],
83.127 + rew_ord = ("termlessI",termlessI),
83.128 + erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls
83.129 + [(*for asm in nth_Cons_ ...*)
83.130 + Calc ("op <",eval_equ "#less_"),
83.131 + (*2nd nth_Cons_ pushes n+-1 into asms*)
83.132 + Calc("op +", eval_binop "#add_")
83.133 + ],
83.134 + srls = Erls, calc = [],
83.135 + rules = [Thm ("nth_Cons_",num_str nth_Cons_),
83.136 + Calc("op +", eval_binop "#add_"),
83.137 + Thm ("nth_Nil_",num_str nth_Nil_),
83.138 + Calc("Tools.lhs", eval_lhs"eval_lhs_"),
83.139 + Calc("Tools.rhs", eval_rhs"eval_rhs_"),
83.140 + Calc("Atools.argument'_in",
83.141 + eval_argument_in "Atools.argument'_in")
83.142 + ],
83.143 + scr = EmptyScr};
83.144 +
83.145 +val srls2 =
83.146 + Rls {id="srls_IntegrierenUnd..",
83.147 + preconds = [],
83.148 + rew_ord = ("termlessI",termlessI),
83.149 + erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls
83.150 + [(*for asm in nth_Cons_ ...*)
83.151 + Calc ("op <",eval_equ "#less_"),
83.152 + (*2nd nth_Cons_ pushes n+-1 into asms*)
83.153 + Calc("op +", eval_binop "#add_")
83.154 + ],
83.155 + srls = Erls, calc = [],
83.156 + rules = [Thm ("nth_Cons_",num_str nth_Cons_),
83.157 + Calc("op +", eval_binop "#add_"),
83.158 + Thm ("nth_Nil_", num_str nth_Nil_),
83.159 + Calc("Tools.lhs", eval_lhs "eval_lhs_"),
83.160 + Calc("Atools.filter'_sameFunId",
83.161 + eval_filter_sameFunId "Atools.filter'_sameFunId"),
83.162 + (*WN070514 just for smltest/../biegelinie.sml ...*)
83.163 + Calc("Atools.sameFunId", eval_sameFunId "Atools.sameFunId"),
83.164 + Thm ("filter_Cons", num_str filter_Cons),
83.165 + Thm ("filter_Nil", num_str filter_Nil),
83.166 + Thm ("if_True", num_str if_True),
83.167 + Thm ("if_False", num_str if_False),
83.168 + Thm ("hd_thm", num_str hd_thm)
83.169 + ],
83.170 + scr = EmptyScr};
83.171 +(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
83.172 +(* use"Knowledge/Biegelinie.ML";
83.173 + *)
83.174 +
83.175 +store_met
83.176 + (prep_met Biegelinie.thy "met_biege" [] e_metID
83.177 + (["IntegrierenUndKonstanteBestimmen"],
83.178 + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__",
83.179 + "FunktionsVariable v_"]),
83.180 + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
83.181 + ("#Find" ,["Biegelinie b_"]),
83.182 + ("#Relate",["RandbedingungenBiegung rb_",
83.183 + "RandbedingungenMoment rm_"])
83.184 + ],
83.185 + {rew_ord'="tless_true",
83.186 + rls' = append_rls "erls_IntegrierenUndK.." e_rls
83.187 + [Calc ("Atools.ident",eval_ident "#ident_"),
83.188 + Thm ("not_true",num_str not_true),
83.189 + Thm ("not_false",num_str not_false)],
83.190 + calc = [], srls = srls, prls = Erls,
83.191 + crls = Atools_erls, nrls = Erls},
83.192 +"Script BiegelinieScript \
83.193 +\(l_::real) (q__::real) (v_::real) (b_::real=>real) \
83.194 +\(rb_::bool list) (rm_::bool list) = \
83.195 +\ (let q___ = Take (q_ v_ = q__); \
83.196 +\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \
83.197 +\ (Rewrite Belastung_Querkraft True)) q___; \
83.198 +\ (Q__:: bool) = \
83.199 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.200 +\ [diff,integration,named]) \
83.201 +\ [real_ (rhs q___), real_ v_, real_real_ Q]); \
83.202 +\ Q__ = Rewrite Querkraft_Moment True Q__; \
83.203 +\ (M__::bool) = \
83.204 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.205 +\ [diff,integration,named]) \
83.206 +\ [real_ (rhs Q__), real_ v_, real_real_ M_b]); \
83.207 +\ e1__ = nth_ 1 rm_; \
83.208 +\ (x1__::real) = argument_in (lhs e1__); \
83.209 +\ (M1__::bool) = (Substitute [v_ = x1__]) M__; \
83.210 +\ M1__ = (Substitute [e1__]) M1__ ; \
83.211 +\ M2__ = Take M__; "^
83.212 +(*without this Take 'Substitute [v_ = x2__]' takes _last formula from ctree_*)
83.213 +" e2__ = nth_ 2 rm_; \
83.214 +\ (x2__::real) = argument_in (lhs e2__); \
83.215 +\ (M2__::bool) = ((Substitute [v_ = x2__]) @@ \
83.216 +\ (Substitute [e2__])) M2__; \
83.217 +\ (c_1_2__::bool list) = \
83.218 +\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \
83.219 +\ [booll_ [M1__, M2__], reall [c,c_2]]); \
83.220 +\ M__ = Take M__; \
83.221 +\ M__ = ((Substitute c_1_2__) @@ \
83.222 +\ (Try (Rewrite_Set_Inst [(bdv_1, c),(bdv_2, c_2)]\
83.223 +\ simplify_System False)) @@ \
83.224 +\ (Rewrite Moment_Neigung False) @@ \
83.225 +\ (Rewrite make_fun_explicit False)) M__; "^
83.226 +(*----------------------- and the same once more ------------------------*)
83.227 +" (N__:: bool) = \
83.228 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.229 +\ [diff,integration,named]) \
83.230 +\ [real_ (rhs M__), real_ v_, real_real_ y']); \
83.231 +\ (B__:: bool) = \
83.232 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.233 +\ [diff,integration,named]) \
83.234 +\ [real_ (rhs N__), real_ v_, real_real_ y]); \
83.235 +\ e1__ = nth_ 1 rb_; \
83.236 +\ (x1__::real) = argument_in (lhs e1__); \
83.237 +\ (B1__::bool) = (Substitute [v_ = x1__]) B__; \
83.238 +\ B1__ = (Substitute [e1__]) B1__ ; \
83.239 +\ B2__ = Take B__; \
83.240 +\ e2__ = nth_ 2 rb_; \
83.241 +\ (x2__::real) = argument_in (lhs e2__); \
83.242 +\ (B2__::bool) = ((Substitute [v_ = x2__]) @@ \
83.243 +\ (Substitute [e2__])) B2__; \
83.244 +\ (c_1_2__::bool list) = \
83.245 +\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \
83.246 +\ [booll_ [B1__, B2__], reall [c,c_2]]); \
83.247 +\ B__ = Take B__; \
83.248 +\ B__ = ((Substitute c_1_2__) @@ \
83.249 +\ (Rewrite_Set_Inst [(bdv, x)] make_ratpoly_in False)) B__ \
83.250 +\ in B__)"
83.251 +));
83.252 +
83.253 +store_met
83.254 + (prep_met Biegelinie.thy "met_biege_2" [] e_metID
83.255 + (["IntegrierenUndKonstanteBestimmen2"],
83.256 + [("#Given" ,["Traegerlaenge l_", "Streckenlast q__",
83.257 + "FunktionsVariable v_"]),
83.258 + (*("#Where",["0 < l_"]), ...wait for < and handling Arbfix*)
83.259 + ("#Find" ,["Biegelinie b_"]),
83.260 + ("#Relate",["Randbedingungen rb_"])
83.261 + ],
83.262 + {rew_ord'="tless_true",
83.263 + rls' = append_rls "erls_IntegrierenUndK.." e_rls
83.264 + [Calc ("Atools.ident",eval_ident "#ident_"),
83.265 + Thm ("not_true",num_str not_true),
83.266 + Thm ("not_false",num_str not_false)],
83.267 + calc = [],
83.268 + srls = append_rls "erls_IntegrierenUndK.." e_rls
83.269 + [Calc("Tools.rhs", eval_rhs"eval_rhs_"),
83.270 + Calc ("Atools.ident",eval_ident "#ident_"),
83.271 + Thm ("last_thmI",num_str last_thmI),
83.272 + Thm ("if_True",num_str if_True),
83.273 + Thm ("if_False",num_str if_False)
83.274 + ],
83.275 + prls = Erls, crls = Atools_erls, nrls = Erls},
83.276 +"Script Biegelinie2Script \
83.277 +\(l_::real) (q__::real) (v_::real) (b_::real=>real) (rb_::bool list) = \
83.278 +\ (let \
83.279 +\ (funs_:: bool list) = \
83.280 +\ (SubProblem (Biegelinie_,[vonBelastungZu,Biegelinien], \
83.281 +\ [Biegelinien,ausBelastung]) \
83.282 +\ [real_ q__, real_ v_]); \
83.283 +\ (equs_::bool list) = \
83.284 +\ (SubProblem (Biegelinie_,[setzeRandbedingungen,Biegelinien],\
83.285 +\ [Biegelinien,setzeRandbedingungenEin]) \
83.286 +\ [booll_ funs_, booll_ rb_]); \
83.287 +\ (cons_::bool list) = \
83.288 +\ (SubProblem (Biegelinie_,[linear,system],[no_met]) \
83.289 +\ [booll_ equs_, reall [c,c_2,c_3,c_4]]); \
83.290 +\ B_ = Take (lastI funs_); \
83.291 +\ B_ = ((Substitute cons_) @@ \
83.292 +\ (Rewrite_Set_Inst [(bdv, v_)] make_ratpoly_in False)) B_ \
83.293 +\ in B_)"
83.294 +));
83.295 +
83.296 +store_met
83.297 + (prep_met Biegelinie.thy "met_biege_intconst_2" [] e_metID
83.298 + (["IntegrierenUndKonstanteBestimmen","2xIntegrieren"],
83.299 + [],
83.300 + {rew_ord'="tless_true", rls'=Erls, calc = [],
83.301 + srls = e_rls,
83.302 + prls=e_rls,
83.303 + crls = Atools_erls, nrls = e_rls},
83.304 +"empty_script"
83.305 +));
83.306 +
83.307 +store_met
83.308 + (prep_met Biegelinie.thy "met_biege_intconst_4" [] e_metID
83.309 + (["IntegrierenUndKonstanteBestimmen","4x4System"],
83.310 + [],
83.311 + {rew_ord'="tless_true", rls'=Erls, calc = [],
83.312 + srls = e_rls,
83.313 + prls=e_rls,
83.314 + crls = Atools_erls, nrls = e_rls},
83.315 +"empty_script"
83.316 +));
83.317 +
83.318 +store_met
83.319 + (prep_met Biegelinie.thy "met_biege_intconst_1" [] e_metID
83.320 + (["IntegrierenUndKonstanteBestimmen","1xIntegrieren"],
83.321 + [],
83.322 + {rew_ord'="tless_true", rls'=Erls, calc = [],
83.323 + srls = e_rls,
83.324 + prls=e_rls,
83.325 + crls = Atools_erls, nrls = e_rls},
83.326 +"empty_script"
83.327 +));
83.328 +
83.329 +store_met
83.330 + (prep_met Biegelinie.thy "met_biege2" [] e_metID
83.331 + (["Biegelinien"],
83.332 + [],
83.333 + {rew_ord'="tless_true", rls'=Erls, calc = [],
83.334 + srls = e_rls,
83.335 + prls=e_rls,
83.336 + crls = Atools_erls, nrls = e_rls},
83.337 +"empty_script"
83.338 +));
83.339 +
83.340 +store_met
83.341 + (prep_met Biegelinie.thy "met_biege_ausbelast" [] e_metID
83.342 + (["Biegelinien","ausBelastung"],
83.343 + [("#Given" ,["Streckenlast q__","FunktionsVariable v_"]),
83.344 + ("#Find" ,["Funktionen funs_"])],
83.345 + {rew_ord'="tless_true",
83.346 + rls' = append_rls "erls_ausBelastung" e_rls
83.347 + [Calc ("Atools.ident",eval_ident "#ident_"),
83.348 + Thm ("not_true",num_str not_true),
83.349 + Thm ("not_false",num_str not_false)],
83.350 + calc = [],
83.351 + srls = append_rls "srls_ausBelastung" e_rls
83.352 + [Calc("Tools.rhs", eval_rhs"eval_rhs_")],
83.353 + prls = e_rls, crls = Atools_erls, nrls = e_rls},
83.354 +"Script Belastung2BiegelScript (q__::real) (v_::real) = \
83.355 +\ (let q___ = Take (q_ v_ = q__); \
83.356 +\ q___ = ((Rewrite sym_real_minus_eq_cancel True) @@ \
83.357 +\ (Rewrite Belastung_Querkraft True)) q___; \
83.358 +\ (Q__:: bool) = \
83.359 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.360 +\ [diff,integration,named]) \
83.361 +\ [real_ (rhs q___), real_ v_, real_real_ Q]); \
83.362 +\ M__ = Rewrite Querkraft_Moment True Q__; \
83.363 +\ (M__::bool) = \
83.364 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.365 +\ [diff,integration,named]) \
83.366 +\ [real_ (rhs M__), real_ v_, real_real_ M_b]); \
83.367 +\ N__ = ((Rewrite Moment_Neigung False) @@ \
83.368 +\ (Rewrite make_fun_explicit False)) M__; \
83.369 +\ (N__:: bool) = \
83.370 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.371 +\ [diff,integration,named]) \
83.372 +\ [real_ (rhs N__), real_ v_, real_real_ y']); \
83.373 +\ (B__:: bool) = \
83.374 +\ (SubProblem (Biegelinie_,[named,integrate,function], \
83.375 +\ [diff,integration,named]) \
83.376 +\ [real_ (rhs N__), real_ v_, real_real_ y]) \
83.377 +\ in [Q__, M__, N__, B__])"
83.378 +));
83.379 +
83.380 +store_met
83.381 + (prep_met Biegelinie.thy "met_biege_setzrand" [] e_metID
83.382 + (["Biegelinien","setzeRandbedingungenEin"],
83.383 + [("#Given" ,["Funktionen funs_","Randbedingungen rb_"]),
83.384 + ("#Find" ,["Gleichungen equs___"])],
83.385 + {rew_ord'="tless_true", rls'=Erls, calc = [],
83.386 + srls = srls2,
83.387 + prls=e_rls,
83.388 + crls = Atools_erls, nrls = e_rls},
83.389 +"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \
83.390 +\ (let b1_ = nth_ 1 rb_; \
83.391 +\ fs_ = filter_sameFunId (lhs b1_) funs_; \
83.392 +\ (e1_::bool) = \
83.393 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.394 +\ [Equation,fromFunction]) \
83.395 +\ [bool_ (hd fs_), bool_ b1_]); \
83.396 +\ b2_ = nth_ 2 rb_; \
83.397 +\ fs_ = filter_sameFunId (lhs b2_) funs_; \
83.398 +\ (e2_::bool) = \
83.399 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.400 +\ [Equation,fromFunction]) \
83.401 +\ [bool_ (hd fs_), bool_ b2_]); \
83.402 +\ b3_ = nth_ 3 rb_; \
83.403 +\ fs_ = filter_sameFunId (lhs b3_) funs_; \
83.404 +\ (e3_::bool) = \
83.405 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.406 +\ [Equation,fromFunction]) \
83.407 +\ [bool_ (hd fs_), bool_ b3_]); \
83.408 +\ b4_ = nth_ 4 rb_; \
83.409 +\ fs_ = filter_sameFunId (lhs b4_) funs_; \
83.410 +\ (e4_::bool) = \
83.411 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.412 +\ [Equation,fromFunction]) \
83.413 +\ [bool_ (hd fs_), bool_ b4_]) \
83.414 +\ in [e1_,e2_,e3_,e4_])"
83.415 +(* filter requires more than 1 sec !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
83.416 +"Script SetzeRandbedScript (funs_::bool list) (rb_::bool list) = \
83.417 +\ (let b1_ = nth_ 1 rb_; \
83.418 +\ fs_ = filter (sameFunId (lhs b1_)) funs_; \
83.419 +\ (e1_::bool) = \
83.420 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.421 +\ [Equation,fromFunction]) \
83.422 +\ [bool_ (hd fs_), bool_ b1_]); \
83.423 +\ b2_ = nth_ 2 rb_; \
83.424 +\ fs_ = filter (sameFunId (lhs b2_)) funs_; \
83.425 +\ (e2_::bool) = \
83.426 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.427 +\ [Equation,fromFunction]) \
83.428 +\ [bool_ (hd fs_), bool_ b2_]); \
83.429 +\ b3_ = nth_ 3 rb_; \
83.430 +\ fs_ = filter (sameFunId (lhs b3_)) funs_; \
83.431 +\ (e3_::bool) = \
83.432 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.433 +\ [Equation,fromFunction]) \
83.434 +\ [bool_ (hd fs_), bool_ b3_]); \
83.435 +\ b4_ = nth_ 4 rb_; \
83.436 +\ fs_ = filter (sameFunId (lhs b4_)) funs_; \
83.437 +\ (e4_::bool) = \
83.438 +\ (SubProblem (Biegelinie_,[makeFunctionTo,equation],\
83.439 +\ [Equation,fromFunction]) \
83.440 +\ [bool_ (hd fs_), bool_ b4_]) \
83.441 +\ in [e1_,e2_,e3_,e4_])"*)
83.442 +));
83.443 +
83.444 +store_met
83.445 + (prep_met Biegelinie.thy "met_equ_fromfun" [] e_metID
83.446 + (["Equation","fromFunction"],
83.447 + [("#Given" ,["functionEq fun_","substitution sub_"]),
83.448 + ("#Find" ,["equality equ___"])],
83.449 + {rew_ord'="tless_true", rls'=Erls, calc = [],
83.450 + srls = append_rls "srls_in_EquationfromFunc" e_rls
83.451 + [Calc("Tools.lhs", eval_lhs"eval_lhs_"),
83.452 + Calc("Atools.argument'_in",
83.453 + eval_argument_in
83.454 + "Atools.argument'_in")],
83.455 + prls=e_rls,
83.456 + crls = Atools_erls, nrls = e_rls},
83.457 +(*(M_b x = c_2 + c * x + -1 * q_0 / 2 * x ^^^ 2) (M_b L = 0) -->
83.458 + 0 = c_2 + c * L + -1 * q_0 / 2 * L ^^^ 2*)
83.459 +"Script Function2Equality (fun_::bool) (sub_::bool) =\
83.460 +\ (let fun_ = Take fun_; \
83.461 +\ bdv_ = argument_in (lhs fun_); \
83.462 +\ val_ = argument_in (lhs sub_); \
83.463 +\ equ_ = (Substitute [bdv_ = val_]) fun_; \
83.464 +\ equ_ = (Substitute [sub_]) fun_ \
83.465 +\ in (Rewrite_Set norm_Rational False) equ_) "
83.466 +));
83.467 +
83.468 +
83.469 +
83.470 +(* use"Knowledge/Biegelinie.ML";
83.471 + *)
83.472 \ No newline at end of file
84.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
84.2 +++ b/src/Tools/isac/Knowledge/Biegelinie.thy Wed Aug 25 16:20:07 2010 +0200
84.3 @@ -0,0 +1,82 @@
84.4 +(* chapter 'Biegelinie' from the textbook:
84.5 + Timischl, Kaiser. Ingenieur-Mathematik 3. Wien 1999. p.268-271.
84.6 + author: Walther Neuper
84.7 + 050826,
84.8 + (c) due to copyright terms
84.9 +
84.10 +remove_thy"Biegelinie";
84.11 +use_thy"Knowledge/Biegelinie";
84.12 +use_thy_only"Knowledge/Biegelinie";
84.13 +
84.14 +remove_thy"Biegelinie";
84.15 +use_thy"Knowledge/Isac";
84.16 +*)
84.17 +
84.18 +Biegelinie = Integrate + Equation + EqSystem +
84.19 +
84.20 +consts
84.21 +
84.22 + q_ :: real => real ("q'_") (* Streckenlast *)
84.23 + Q :: real => real (* Querkraft *)
84.24 + Q' :: real => real (* Ableitung der Querkraft *)
84.25 + M'_b :: real => real ("M'_b") (* Biegemoment *)
84.26 + M'_b' :: real => real ("M'_b'") (* Ableitung des Biegemoments *)
84.27 + y'' :: real => real (* 2.Ableitung der Biegeline *)
84.28 + y' :: real => real (* Neigung der Biegeline *)
84.29 +(*y :: real => real (* Biegeline *)*)
84.30 + EI :: real (* Biegesteifigkeit *)
84.31 +
84.32 + (*new Descriptions in the related problems*)
84.33 + Traegerlaenge :: real => una
84.34 + Streckenlast :: real => una
84.35 + BiegemomentVerlauf :: bool => una
84.36 + Biegelinie :: (real => real) => una
84.37 + Randbedingungen :: bool list => una
84.38 + RandbedingungenBiegung :: bool list => una
84.39 + RandbedingungenNeigung :: bool list => una
84.40 + RandbedingungenMoment :: bool list => una
84.41 + RandbedingungenQuerkraft :: bool list => una
84.42 + FunktionsVariable :: real => una
84.43 + Funktionen :: bool list => una
84.44 + Gleichungen :: bool list => una
84.45 +
84.46 + (*Script-names*)
84.47 + Biegelinie2Script :: "[real,real,real,real=>real,bool list,
84.48 + bool] => bool"
84.49 + ("((Script Biegelinie2Script (_ _ _ _ _ =))// (_))" 9)
84.50 + BiegelinieScript :: "[real,real,real,real=>real,bool list,bool list,
84.51 + bool] => bool"
84.52 + ("((Script BiegelinieScript (_ _ _ _ _ _ =))// (_))" 9)
84.53 + Biege2xIntegrierenScript :: "[real,real,real,bool,real=>real,bool list,
84.54 + bool] => bool"
84.55 + ("((Script Biege2xIntegrierenScript (_ _ _ _ _ _ =))// (_))" 9)
84.56 + Biege4x4SystemScript :: "[real,real,real,real=>real,bool list,
84.57 + bool] => bool"
84.58 + ("((Script Biege4x4SystemScript (_ _ _ _ _ =))// (_))" 9)
84.59 + Biege1xIntegrierenScript ::
84.60 + "[real,real,real,real=>real,bool list,bool list,bool list,
84.61 + bool] => bool"
84.62 + ("((Script Biege1xIntegrierenScript (_ _ _ _ _ _ _ =))// (_))" 9)
84.63 + Belastung2BiegelScript :: "[real,real,
84.64 + bool list] => bool list"
84.65 + ("((Script Belastung2BiegelScript (_ _ =))// (_))" 9)
84.66 + SetzeRandbedScript :: "[bool list,bool list,
84.67 + bool list] => bool list"
84.68 + ("((Script SetzeRandbedScript (_ _ =))// (_))" 9)
84.69 +
84.70 +rules
84.71 +
84.72 + Querkraft_Belastung "Q' x = -q_ x"
84.73 + Belastung_Querkraft "-q_ x = Q' x"
84.74 +
84.75 + Moment_Querkraft "M_b' x = Q x"
84.76 + Querkraft_Moment "Q x = M_b' x"
84.77 +
84.78 + Neigung_Moment "y'' x = -M_b x/ EI"
84.79 + Moment_Neigung "M_b x = -EI * y'' x"
84.80 +
84.81 + (*according to rls 'simplify_Integral': .. = 1/a * .. instead .. = ../ a*)
84.82 + make_fun_explicit "Not (a =!= 0) ==> (a * (f x) = b) = (f x = 1/a * b)"
84.83 +
84.84 +end
84.85 +
85.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
85.2 +++ b/src/Tools/isac/Knowledge/Calculus.thy Wed Aug 25 16:20:07 2010 +0200
85.3 @@ -0,0 +1,4 @@
85.4 +
85.5 +Calculus = Real +
85.6 +
85.7 +end
85.8 \ No newline at end of file
86.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
86.2 +++ b/src/Tools/isac/Knowledge/Descript.thy Wed Aug 25 16:20:07 2010 +0200
86.3 @@ -0,0 +1,52 @@
86.4 +(* Title: descriptions for items in model-patterns of problems and in method's
86.5 + guards
86.6 + Author: Walther Neuper 000301
86.7 + (c) due to copyright terms
86.8 + + see WN, Reactive User-Guidance ... Vers. Oct.2000 p.48 ff
86.9 +
86.10 +remove_thy"Descript";
86.11 +use_thy"Knowledge/Descript";
86.12 +use_thy_only"Knowledge/Descript";
86.13 +
86.14 +remove_thy"Typefix";
86.15 +use_thy"Knowledge/Isac";
86.16 +*)
86.17 +
86.18 +theory Descript imports "../ProgLang/Script" begin
86.19 +
86.20 +consts
86.21 +
86.22 + someList :: "'a list => unl" (*not for elementwise input, eg. inssort*)
86.23 +
86.24 + additionalRels :: "bool list => una"
86.25 + boundVariable :: "real => una"
86.26 +(*derivative :: 'a => toreal 28.11.00*)
86.27 + derivative :: "real => una"
86.28 + equalities :: "bool list => tobooll" (*WN071228 see fixedValues*)
86.29 + equality :: "bool => una"
86.30 + errorBound :: "bool => nam"
86.31 +
86.32 + fixedValues :: "bool list => nam"
86.33 + functionEq :: "bool => una" (*6.5.03: functionTerm -> functionEq*)
86.34 + antiDerivative :: "bool => una"
86.35 + functionOf :: "real => una"
86.36 +(*functionTerm :: 'a => toreal 28.11.00*)
86.37 + functionTerm :: "real => una" (*6.5.03: functionTerm -> functionEq*)
86.38 + interval :: "real set => una"
86.39 + maxArgument :: "bool => toreal"
86.40 + maximum :: "real => toreal"
86.41 +
86.42 + relations :: "bool list => una"
86.43 + solutions :: "bool list => toreall"
86.44 +(*solution :: bool => toreal WN0509 bool list=> toreall --->EqSystem*)
86.45 + solveFor :: "real => una"
86.46 + differentiateFor:: "real => una"
86.47 + unknown :: "'a => unknow"
86.48 + valuesFor :: "real list => toreall"
86.49 +
86.50 + realTestGiven :: "real => una"
86.51 + realTestFind :: "real => una"
86.52 + boolTestGiven :: "bool => una"
86.53 + boolTestFind :: "bool => una"
86.54 +
86.55 +end
86.56 \ No newline at end of file
87.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
87.2 +++ b/src/Tools/isac/Knowledge/Diff.ML Wed Aug 25 16:20:07 2010 +0200
87.3 @@ -0,0 +1,370 @@
87.4 +(* tools for differentiation
87.5 + WN.11.99
87.6 +
87.7 +use"Knowledge/Diff.ML";
87.8 +use"Diff.ML";
87.9 + *)
87.10 +
87.11 +
87.12 +(** interface isabelle -- isac **)
87.13 +
87.14 +theory' := overwritel (!theory', [("Diff.thy",Diff.thy)]);
87.15 +
87.16 +
87.17 +(** eval functions **)
87.18 +
87.19 +fun primed (Const (id, T)) = Const (id ^ "'", T)
87.20 + | primed (Free (id, T)) = Free (id ^ "'", T)
87.21 + | primed t = raise error ("primed called with arg = '"^ term2str t ^"'");
87.22 +
87.23 +(*("primed", ("Diff.primed", eval_primed "#primed"))*)
87.24 +fun eval_primed _ _ (p as (Const ("Diff.primed",_) $ t)) _ =
87.25 + SOME ((term2str p) ^ " = " ^ term2str (primed t),
87.26 + Trueprop $ (mk_equality (p, primed t)))
87.27 + | eval_primed _ _ _ _ = NONE;
87.28 +
87.29 +calclist':= overwritel (!calclist',
87.30 + [("primed", ("Diff.primed", eval_primed "#primed"))
87.31 + ]);
87.32 +
87.33 +
87.34 +(** rulesets **)
87.35 +
87.36 +(*.converts a term such that differentiation works optimally.*)
87.37 +val diff_conv =
87.38 + Rls {id="diff_conv",
87.39 + preconds = [],
87.40 + rew_ord = ("termlessI",termlessI),
87.41 + erls = append_rls "erls_diff_conv" e_rls
87.42 + [Calc ("Atools.occurs'_in", eval_occurs_in ""),
87.43 + Thm ("not_true",num_str not_true),
87.44 + Thm ("not_false",num_str not_false),
87.45 + Calc ("op <",eval_equ "#less_"),
87.46 + Thm ("and_true",num_str and_true),
87.47 + Thm ("and_false",num_str and_false)
87.48 + ],
87.49 + srls = Erls, calc = [],
87.50 + rules = [Thm ("frac_conv", num_str frac_conv),
87.51 + Thm ("sqrt_conv_bdv", num_str sqrt_conv_bdv),
87.52 + Thm ("sqrt_conv_bdv_n", num_str sqrt_conv_bdv_n),
87.53 + Thm ("sqrt_conv", num_str sqrt_conv),
87.54 + Thm ("root_conv", num_str root_conv),
87.55 + Thm ("realpow_pow_bdv", num_str realpow_pow_bdv),
87.56 + Calc ("op *", eval_binop "#mult_"),
87.57 + Thm ("rat_mult",num_str rat_mult),
87.58 + (*a / b * (c / d) = a * c / (b * d)*)
87.59 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
87.60 + (*?x * (?y / ?z) = ?x * ?y / ?z*)
87.61 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq)
87.62 + (*?y / ?z * ?x = ?y * ?x / ?z*)
87.63 + (*
87.64 + Thm ("", num_str ),*)
87.65 + ],
87.66 + scr = EmptyScr};
87.67 +
87.68 +(*.beautifies a term after differentiation.*)
87.69 +val diff_sym_conv =
87.70 + Rls {id="diff_sym_conv",
87.71 + preconds = [],
87.72 + rew_ord = ("termlessI",termlessI),
87.73 + erls = append_rls "erls_diff_sym_conv" e_rls
87.74 + [Calc ("op <",eval_equ "#less_")
87.75 + ],
87.76 + srls = Erls, calc = [],
87.77 + rules = [Thm ("frac_sym_conv", num_str frac_sym_conv),
87.78 + Thm ("sqrt_sym_conv", num_str sqrt_sym_conv),
87.79 + Thm ("root_sym_conv", num_str root_sym_conv),
87.80 + Thm ("sym_real_mult_minus1",
87.81 + num_str (real_mult_minus1 RS sym)),
87.82 + (*- ?z = "-1 * ?z"*)
87.83 + Thm ("rat_mult",num_str rat_mult),
87.84 + (*a / b * (c / d) = a * c / (b * d)*)
87.85 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
87.86 + (*?x * (?y / ?z) = ?x * ?y / ?z*)
87.87 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
87.88 + (*?y / ?z * ?x = ?y * ?x / ?z*)
87.89 + Calc ("op *", eval_binop "#mult_")
87.90 + ],
87.91 + scr = EmptyScr};
87.92 +
87.93 +(*..*)
87.94 +val srls_diff =
87.95 + Rls {id="srls_differentiate..",
87.96 + preconds = [],
87.97 + rew_ord = ("termlessI",termlessI),
87.98 + erls = e_rls,
87.99 + srls = Erls, calc = [],
87.100 + rules = [Calc("Tools.lhs", eval_lhs "eval_lhs_"),
87.101 + Calc("Tools.rhs", eval_rhs "eval_rhs_"),
87.102 + Calc("Diff.primed", eval_primed "Diff.primed")
87.103 + ],
87.104 + scr = EmptyScr};
87.105 +
87.106 +(*..*)
87.107 +val erls_diff =
87.108 + append_rls "erls_differentiate.." e_rls
87.109 + [Thm ("not_true",num_str not_true),
87.110 + Thm ("not_false",num_str not_false),
87.111 +
87.112 + Calc ("Atools.ident",eval_ident "#ident_"),
87.113 + Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"),
87.114 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
87.115 + Calc ("Atools.is'_const",eval_const "#is_const_")
87.116 + ];
87.117 +
87.118 +(*.rules for differentiation, _no_ simplification.*)
87.119 +val diff_rules =
87.120 + Rls {id="diff_rules", preconds = [], rew_ord = ("termlessI",termlessI),
87.121 + erls = erls_diff, srls = Erls, calc = [],
87.122 + rules = [Thm ("diff_sum",num_str diff_sum),
87.123 + Thm ("diff_dif",num_str diff_dif),
87.124 + Thm ("diff_prod_const",num_str diff_prod_const),
87.125 + Thm ("diff_prod",num_str diff_prod),
87.126 + Thm ("diff_quot",num_str diff_quot),
87.127 + Thm ("diff_sin",num_str diff_sin),
87.128 + Thm ("diff_sin_chain",num_str diff_sin_chain),
87.129 + Thm ("diff_cos",num_str diff_cos),
87.130 + Thm ("diff_cos_chain",num_str diff_cos_chain),
87.131 + Thm ("diff_pow",num_str diff_pow),
87.132 + Thm ("diff_pow_chain",num_str diff_pow_chain),
87.133 + Thm ("diff_ln",num_str diff_ln),
87.134 + Thm ("diff_ln_chain",num_str diff_ln_chain),
87.135 + Thm ("diff_exp",num_str diff_exp),
87.136 + Thm ("diff_exp_chain",num_str diff_exp_chain),
87.137 +(*
87.138 + Thm ("diff_sqrt",num_str diff_sqrt),
87.139 + Thm ("diff_sqrt_chain",num_str diff_sqrt_chain),
87.140 +*)
87.141 + Thm ("diff_const",num_str diff_const),
87.142 + Thm ("diff_var",num_str diff_var)
87.143 + ],
87.144 + scr = EmptyScr};
87.145 +
87.146 +(*.normalisation for checking user-input.*)
87.147 +val norm_diff =
87.148 + Rls {id="diff_rls", preconds = [], rew_ord = ("termlessI",termlessI),
87.149 + erls = Erls, srls = Erls, calc = [],
87.150 + rules = [Rls_ diff_rules,
87.151 + Rls_ norm_Poly
87.152 + ],
87.153 + scr = EmptyScr};
87.154 +ruleset' :=
87.155 +overwritelthy thy (!ruleset',
87.156 + [("diff_rules", prep_rls norm_diff),
87.157 + ("norm_diff", prep_rls norm_diff),
87.158 + ("diff_conv", prep_rls diff_conv),
87.159 + ("diff_sym_conv", prep_rls diff_sym_conv)
87.160 + ]);
87.161 +
87.162 +
87.163 +(** problem types **)
87.164 +
87.165 +store_pbt
87.166 + (prep_pbt Diff.thy "pbl_fun" [] e_pblID
87.167 + (["function"], [], e_rls, NONE, []));
87.168 +
87.169 +store_pbt
87.170 + (prep_pbt Diff.thy "pbl_fun_deriv" [] e_pblID
87.171 + (["derivative_of","function"],
87.172 + [("#Given" ,["functionTerm f_","differentiateFor v_"]),
87.173 + ("#Find" ,["derivative f_'_"])
87.174 + ],
87.175 + append_rls "e_rls" e_rls [],
87.176 + SOME "Diff (f_, v_)", [["diff","differentiate_on_R"],
87.177 + ["diff","after_simplification"]]));
87.178 +
87.179 +(*here "named" is used differently from Integration"*)
87.180 +store_pbt
87.181 + (prep_pbt Diff.thy "pbl_fun_deriv_nam" [] e_pblID
87.182 + (["named","derivative_of","function"],
87.183 + [("#Given" ,["functionEq f_","differentiateFor v_"]),
87.184 + ("#Find" ,["derivativeEq f_'_"])
87.185 + ],
87.186 + append_rls "e_rls" e_rls [],
87.187 + SOME "Differentiate (f_, v_)", [["diff","differentiate_equality"]]));
87.188 +
87.189 +
87.190 +(** methods **)
87.191 +
87.192 +store_met
87.193 + (prep_met Diff.thy "met_diff" [] e_metID
87.194 + (["diff"], [],
87.195 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
87.196 + crls = Atools_erls, nrls = norm_diff}, "empty_script"));
87.197 +
87.198 +store_met
87.199 + (prep_met Diff.thy "met_diff_onR" [] e_metID
87.200 + (["diff","differentiate_on_R"],
87.201 + [("#Given" ,["functionTerm f_","differentiateFor v_"]),
87.202 + ("#Find" ,["derivative f_'_"])
87.203 + ],
87.204 + {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls,
87.205 + prls=e_rls, crls = Atools_erls, nrls = norm_diff},
87.206 +"Script DiffScr (f_::real) (v_::real) = \
87.207 +\ (let f'_ = Take (d_d v_ f_) \
87.208 +\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \
87.209 +\ (Repeat \
87.210 +\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
87.211 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
87.212 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
87.213 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
87.214 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
87.215 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
87.216 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
87.217 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
87.218 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
87.219 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
87.220 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
87.221 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
87.222 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
87.223 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
87.224 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
87.225 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
87.226 +\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \
87.227 +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)"
87.228 +));
87.229 +
87.230 +store_met
87.231 + (prep_met Diff.thy "met_diff_simpl" [] e_metID
87.232 + (["diff","diff_simpl"],
87.233 + [("#Given" ,["functionTerm f_","differentiateFor v_"]),
87.234 + ("#Find" ,["derivative f_'_"])
87.235 + ],
87.236 + {rew_ord'="tless_true", rls' = erls_diff, calc = [], srls = e_rls,
87.237 + prls=e_rls, crls = Atools_erls, nrls = norm_diff},
87.238 +"Script DiffScr (f_::real) (v_::real) = \
87.239 +\ (let f'_ = Take (d_d v_ f_) \
87.240 +\ in (( \
87.241 +\ (Repeat \
87.242 +\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
87.243 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
87.244 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
87.245 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
87.246 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
87.247 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
87.248 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
87.249 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
87.250 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
87.251 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
87.252 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
87.253 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
87.254 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
87.255 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
87.256 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
87.257 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
87.258 +\ (Repeat (Rewrite_Set make_polynomial False)))) \
87.259 +\ )) f'_)"
87.260 + ));
87.261 +
87.262 +(*-----------------------------------------------------------------
87.263 + "Script DiffScr (f_::real) (v_::real) = \
87.264 + \(Repeat \
87.265 + \ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
87.266 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
87.267 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
87.268 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
87.269 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
87.270 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
87.271 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
87.272 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
87.273 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
87.274 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
87.275 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
87.276 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
87.277 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
87.278 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
87.279 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
87.280 + \ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
87.281 + \ (Repeat (Rewrite_Set make_polynomial False)))) \
87.282 + \ (f_::real)"
87.283 +*)
87.284 +
87.285 +store_met
87.286 + (prep_met Diff.thy "met_diff_equ" [] e_metID
87.287 + (["diff","differentiate_equality"],
87.288 + [("#Given" ,["functionEq f_","differentiateFor v_"]),
87.289 + ("#Find" ,["derivativeEq f_'_"])
87.290 + ],
87.291 + {rew_ord'="tless_true", rls' = erls_diff, calc = [],
87.292 + srls = srls_diff, prls=e_rls, crls=Atools_erls, nrls = norm_diff},
87.293 +"Script DiffEqScr (f_::bool) (v_::real) = \
87.294 +\ (let f'_ = Take ((primed (lhs f_)) = d_d v_ (rhs f_)) \
87.295 +\ in (((Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \
87.296 +\ (Repeat \
87.297 +\ ((Repeat (Rewrite_Inst [(bdv,v_)] diff_sum False)) Or \
87.298 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_dif False)) Or \
87.299 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod_const False)) Or \
87.300 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_prod False)) Or \
87.301 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_quot True )) Or \
87.302 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin False)) Or \
87.303 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_sin_chain False)) Or \
87.304 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos False)) Or \
87.305 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_cos_chain False)) Or \
87.306 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow False)) Or \
87.307 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_pow_chain False)) Or \
87.308 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln False)) Or \
87.309 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_ln_chain False)) Or \
87.310 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp False)) Or \
87.311 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_exp_chain False)) Or \
87.312 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_const False)) Or \
87.313 +\ (Repeat (Rewrite_Inst [(bdv,v_)] diff_var False)) Or \
87.314 +\ (Repeat (Rewrite_Set make_polynomial False)))) @@ \
87.315 +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)))) f'_)"
87.316 +));
87.317 +
87.318 +
87.319 +store_met
87.320 + (prep_met Diff.thy "met_diff_after_simp" [] e_metID
87.321 + (["diff","after_simplification"],
87.322 + [("#Given" ,["functionTerm f_","differentiateFor v_"]),
87.323 + ("#Find" ,["derivative f_'_"])
87.324 + ],
87.325 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls, prls=e_rls,
87.326 + crls=Atools_erls, nrls = norm_Rational},
87.327 +"Script DiffScr (f_::real) (v_::real) = \
87.328 +\ (let f'_ = Take (d_d v_ f_) \
87.329 +\ in ((Try (Rewrite_Set norm_Rational False)) @@ \
87.330 +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_conv False)) @@ \
87.331 +\ (Try (Rewrite_Set_Inst [(bdv,v_)] norm_diff False)) @@ \
87.332 +\ (Try (Rewrite_Set_Inst [(bdv,v_)] diff_sym_conv False)) @@ \
87.333 +\ (Try (Rewrite_Set norm_Rational False))) f'_)"
87.334 +));
87.335 +
87.336 +
87.337 +(** CAS-commands **)
87.338 +
87.339 +(*.handle cas-input like "Diff (a * x^3 + b, x)".*)
87.340 +(* val (t, pairl) = strip_comb (str2term "Diff (a * x^3 + b, x)");
87.341 + val [Const ("Pair", _) $ t $ bdv] = pairl;
87.342 + *)
87.343 +fun argl2dtss [Const ("Pair", _) $ t $ bdv] =
87.344 + [((term_of o the o (parse thy)) "functionTerm", [t]),
87.345 + ((term_of o the o (parse thy)) "differentiateFor", [bdv]),
87.346 + ((term_of o the o (parse thy)) "derivative",
87.347 + [(term_of o the o (parse thy)) "f_'_"])
87.348 + ]
87.349 + | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss";
87.350 +castab :=
87.351 +overwritel (!castab,
87.352 + [((term_of o the o (parse thy)) "Diff",
87.353 + (("Isac.thy", ["derivative_of","function"], ["no_met"]),
87.354 + argl2dtss))
87.355 + ]);
87.356 +
87.357 +(*.handle cas-input like "Differentiate (A = s * (a - s), s)".*)
87.358 +(* val (t, pairl) = strip_comb (str2term "Differentiate (A = s * (a - s), s)");
87.359 + val [Const ("Pair", _) $ t $ bdv] = pairl;
87.360 + *)
87.361 +fun argl2dtss [Const ("Pair", _) $ t $ bdv] =
87.362 + [((term_of o the o (parse thy)) "functionEq", [t]),
87.363 + ((term_of o the o (parse thy)) "differentiateFor", [bdv]),
87.364 + ((term_of o the o (parse thy)) "derivativeEq",
87.365 + [(term_of o the o (parse thy)) "f_'_::bool"])
87.366 + ]
87.367 + | argl2dtss _ = raise error "Diff.ML: wrong argument for argl2dtss";
87.368 +castab :=
87.369 +overwritel (!castab,
87.370 + [((term_of o the o (parse thy)) "Differentiate",
87.371 + (("Isac.thy", ["named","derivative_of","function"], ["no_met"]),
87.372 + argl2dtss))
87.373 + ]);
88.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
88.2 +++ b/src/Tools/isac/Knowledge/Diff.thy Wed Aug 25 16:20:07 2010 +0200
88.3 @@ -0,0 +1,97 @@
88.4 +(* differentiation over the reals
88.5 + author: Walther Neuper
88.6 + 000516
88.7 +
88.8 +remove_thy"Diff";
88.9 +use_thy_only"Knowledge/Diff";
88.10 +use_thy"Knowledge/Isac";
88.11 + *)
88.12 +
88.13 +Diff = Calculus + Trig + LogExp + Rational + Root + Poly + Atools +
88.14 +
88.15 +consts
88.16 +
88.17 + d_d :: "[real, real]=> real"
88.18 + sin, cos :: "real => real"
88.19 +(*
88.20 + log, ln :: "real => real"
88.21 + nlog :: "[real, real] => real"
88.22 + exp :: "real => real" ("E'_ ^^^ _" 80)
88.23 +*)
88.24 + (*descriptions in the related problems*)
88.25 + derivativeEq :: bool => una
88.26 +
88.27 + (*predicates*)
88.28 + primed :: "'a => 'a" (*"primed A" -> "A'"*)
88.29 +
88.30 + (*the CAS-commands, eg. "Diff (2*x^^^3, x)",
88.31 + "Differentiate (A = s * (a - s), s)"*)
88.32 + Diff :: "[real * real] => real"
88.33 + Differentiate :: "[bool * real] => bool"
88.34 +
88.35 + (*subproblem and script-name*)
88.36 + differentiate :: "[ID * (ID list) * ID, real,real] => real"
88.37 + ("(differentiate (_)/ (_ _ ))" 9)
88.38 + DiffScr :: "[real,real, real] => real"
88.39 + ("((Script DiffScr (_ _ =))// (_))" 9)
88.40 + DiffEqScr :: "[bool,real, bool] => bool"
88.41 + ("((Script DiffEqScr (_ _ =))// (_))" 9)
88.42 +
88.43 +
88.44 +rules (*stated as axioms, todo: prove as theorems
88.45 + 'bdv' is a constant on the meta-level *)
88.46 + diff_const "[| Not (bdv occurs_in a) |] ==> d_d bdv a = 0"
88.47 + diff_var "d_d bdv bdv = 1"
88.48 + diff_prod_const"[| Not (bdv occurs_in u) |] ==> \
88.49 + \d_d bdv (u * v) = u * d_d bdv v"
88.50 +
88.51 + diff_sum "d_d bdv (u + v) = d_d bdv u + d_d bdv v"
88.52 + diff_dif "d_d bdv (u - v) = d_d bdv u - d_d bdv v"
88.53 + diff_prod "d_d bdv (u * v) = d_d bdv u * v + u * d_d bdv v"
88.54 + diff_quot "Not (v = 0) ==> (d_d bdv (u / v) = \
88.55 + \(d_d bdv u * v - u * d_d bdv v) / v ^^^ 2)"
88.56 +
88.57 + diff_sin "d_d bdv (sin bdv) = cos bdv"
88.58 + diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u"
88.59 + diff_cos "d_d bdv (cos bdv) = - sin bdv"
88.60 + diff_cos_chain "d_d bdv (cos u) = - sin u * d_d bdv u"
88.61 + diff_pow "d_d bdv (bdv ^^^ n) = n * (bdv ^^^ (n - 1))"
88.62 + diff_pow_chain "d_d bdv (u ^^^ n) = n * (u ^^^ (n - 1)) * d_d bdv u"
88.63 + diff_ln "d_d bdv (ln bdv) = 1 / bdv"
88.64 + diff_ln_chain "d_d bdv (ln u) = d_d bdv u / u"
88.65 + diff_exp "d_d bdv (exp bdv) = exp bdv"
88.66 + diff_exp_chain "d_d bdv (exp u) = exp u * d_d x u"
88.67 +(*
88.68 + diff_sqrt "d_d bdv (sqrt bdv) = 1 / (2 * sqrt bdv)"
88.69 + diff_sqrt_chain"d_d bdv (sqrt u) = d_d bdv u / (2 * sqrt u)"
88.70 +*)
88.71 + (*...*)
88.72 +
88.73 + frac_conv "[| bdv occurs_in b; 0 < n |] ==> \
88.74 + \ a / (b ^^^ n) = a * b ^^^ (-n)"
88.75 + frac_sym_conv "n < 0 ==> a * b ^^^ n = a / b ^^^ (-n)"
88.76 +
88.77 + sqrt_conv_bdv "sqrt bdv = bdv ^^^ (1 / 2)"
88.78 + sqrt_conv_bdv_n "sqrt (bdv ^^^ n) = bdv ^^^ (n / 2)"
88.79 + sqrt_conv "bdv occurs_in u ==> sqrt u = u ^^^ (1 / 2)"
88.80 + sqrt_sym_conv "u ^^^ (a / 2) = sqrt (u ^^^ a)"
88.81 +
88.82 + root_conv "bdv occurs_in u ==> nroot n u = u ^^^ (1 / n)"
88.83 + root_sym_conv "u ^^^ (a / b) = nroot b (u ^^^ a)"
88.84 +
88.85 + realpow_pow_bdv "(bdv ^^^ b) ^^^ c = bdv ^^^ (b * c)"
88.86 +
88.87 +end
88.88 +
88.89 +(* a variant of the derivatives defintion:
88.90 +
88.91 + d_d :: "(real => real) => (real => real)"
88.92 +
88.93 + advantages:
88.94 +(1) no variable 'bdv' on the meta-level required
88.95 +(2) chain_rule "d_d (%x. (u (v x))) = (%x. (d_d u)) (v x) * d_d v"
88.96 +(3) and no specialized chain-rules required like
88.97 + diff_sin_chain "d_d bdv (sin u) = cos u * d_d bdv u"
88.98 +
88.99 + disadvantage: d_d (%x. 1 + x^2) = ... differs from high-school notation
88.100 +*)
89.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
89.2 +++ b/src/Tools/isac/Knowledge/DiffApp-oldpbl.sml Wed Aug 25 16:20:07 2010 +0200
89.3 @@ -0,0 +1,369 @@
89.4 +(*8.01: aufgehoben wegen alter preconds, postconds*)
89.5 +
89.6 +(* rectangle with maximal area, inscribed in a circle of fixed radius
89.7 +
89.8 +problem-types and methods solving the respective problem-type
89.9 +
89.10 +(1) names of the problem-types and methods and their hierarchy
89.11 + as subproblems.
89.12 + names of problem-types are string lists (diss 5.3.), not shown
89.13 + here with exception of ["equation","univariate"] in order to
89.14 + indicate, that this particular problem needs refinement to a
89.15 + more specific type of equation solvable by tan-square, etc.
89.16 +
89.17 +problem-types methods
89.18 +------------------------------- ----------------------
89.19 +maximum maximum-by-differentiation
89.20 + maximum-by-experimentation
89.21 + make-fun make-explicit-and-substitute
89.22 + introduce-a-new-variable
89.23 + max-of-fun-on-interval max-of-fun-on-interval
89.24 + derivative differentiate
89.25 + ["equation","univariate"] tan-square
89.26 +
89.27 + find-values find-values
89.28 +
89.29 +(2) specification of the problem-types
89.30 +*)
89.31 +
89.32 +(* maximum *)
89.33 +(* ------- *)
89.34 +(* problem-type *)
89.35 +{given = ["fixed_values (cs::bool list)"],
89.36 + where_= ["foldl (op &) True (map is_equality cs)",
89.37 + "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"],
89.38 + find=["maximum m","values_for (ms::real list)"],
89.39 + with_=["Ex_frees ((foldl (op &) True (r#RS)) & \
89.40 + \ (ALL m'. (subst (m,m') (foldl (op &) True (r#RS)) \
89.41 + \ --> m' <= m)))"],
89.42 + relate=["max_relation r","additional_relations RS"]};
89.43 +(* ^^^ is exponenation *)
89.44 +
89.45 +(* the functions Ex_frees, Rhs provide for the instantiation below *)
89.46 +
89.47 +(* (1) instantiation of maximum, + variant in "values_for" *)
89.48 +{given = ["fixed_values (R = #7)"],
89.49 + where_= ["is_equality (R = #7)",
89.50 + "Not (R <= #0)"],
89.51 + find =["maximum A","values_for [a,b]"],
89.52 + with_ =["EX A. A = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \
89.53 + \ (ALL A'. A' = a*b & (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2 \
89.54 + \ --> A' <= A)))"],
89.55 + relate=["max_relation (A = a*b)",
89.56 + "additional_relations [(a//#2)^^^#2 +(b//#2)^^^#2 =R^^^#2]"]};
89.57 +(* R,a,b are bound by given, find *)
89.58 +
89.59 +(* (2) instantiation of maximum *)
89.60 +{given = ["fixed_values (R = #7)"],
89.61 + where_= ["is_equality (R = #7)",
89.62 + "Not (R <= #0)"],
89.63 + find =["maximum A","values_for [A]"],
89.64 + with_ =["EX a b alpha. A = a*b & \
89.65 + \ a = #2*R*sin alpha & b =#2*R*cos alpha &\
89.66 + \ (ALL A'. A' = a*b & a = #2*R*sin alpha & b =#2*R*cos alpha \
89.67 + \ --> A' <= A)))"],
89.68 + relate=["max_relation (A = a*b)",
89.69 + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]};
89.70 +(* R,A are bound by given, find *)
89.71 +
89.72 +
89.73 +(* make-fun *)
89.74 +(* -------- *)
89.75 +(* problem-type *)
89.76 +{given = ["equality (lhs = rhs)","bound_variable v","equalities es"],
89.77 + where_= [],
89.78 + find = ["function_term lhs_"],
89.79 + with_ = [(*???*)],
89.80 + relate= [(*???*)]};
89.81 +(*the _ in lhs is used to transfer the lhs-identifier of equality*)
89.82 +
89.83 +(* (1) instantiation for make-explicit-and-substitute *)
89.84 +{given = ["equality A = a * b","bound_variable a",
89.85 + "equalities [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"],
89.86 + where_= [],
89.87 + find = ["function_term A_"(*=(a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))*)],
89.88 + with_ = [],
89.89 + relate= []};
89.90 +
89.91 +(* (2) instantiation for introduce-a-new-variable *)
89.92 +{given = ["equality A = a * b","bound_variable alpha",
89.93 + "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
89.94 + where_= [],
89.95 + find = ["function_term A_"(*=(#2*R*sin alpha *#2*R*cos alpha)*)],
89.96 + with_ = [],
89.97 + relate= []};
89.98 +
89.99 +
89.100 +(* max-of-fun-on-interval *)
89.101 +(* ---------------------- *)
89.102 +(* problem-type *)
89.103 +{given = ["function_term t","bound_variable v",
89.104 + "domain {x::real. lower_bound <= x & x <= upper_bound}"],
89.105 + where_= [],
89.106 + find = ["maximums ms"],
89.107 + with_ = ["ALL m. m : ms --> \
89.108 + \ (ALL x::real. lower_bound <= x & x <= upper_bound \
89.109 + \ --> (%v. t) x <= m)"],
89.110 + relate= []}: string ppc;
89.111 +(* ':' is 'element', '::' is a type constraint *)
89.112 +
89.113 +(* (1) variant of instantiation *)
89.114 +{given = ["function_term (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))",
89.115 + "bound_variable a",
89.116 + "domain {x::real. #0 <= x & x <= #2*R}"],
89.117 + where_= [],
89.118 + find = ["maximums AM"],
89.119 + with_ = ["ALL am. am : AM --> \
89.120 + \ (ALL x::real. #0 <= x & x <= #2*R \
89.121 + \ --> (%a. (a * #2 * sqrt(R^^^#2 - (a//#2)^^^#2))) x <= am)"],
89.122 + relate= []};
89.123 +
89.124 +(* (2) variant of instantiation *)
89.125 +{given = ["function_term (#2*R*sin alpha * #2*R*cos alpha)",
89.126 + "bound_variable alpha",
89.127 + "domain {x::real. #0 <= x & x <= pi//#2}"],
89.128 + where_= [],
89.129 + find = ["maximums AM"],
89.130 + with_ = ["ALL am. am : AM --> \
89.131 + \ (ALL x::real. #0 <= x & x <= pi//#2 \
89.132 + \ --> (%alpha. (#2*R*sin alpha * #2*R*cos alpha)) x <= am)"],
89.133 + relate= []};
89.134 +
89.135 +
89.136 +(* derivative *)
89.137 +(* ---------- *)
89.138 +(* problem-type *)
89.139 +{given = ["function_term t","bound_variable bdv"],
89.140 + where_= [],
89.141 + find = ["derivative t'"],
89.142 + with_ = ["t' is_derivative_of (%bdv. t)"],
89.143 + relate= []};
89.144 +(*the ' in t' is used to transfer the identifier from function_term*)
89.145 +
89.146 +
89.147 +(* ["equation","univariate"] *)
89.148 +(* ------------------------- *)
89.149 +(* problem-type *)
89.150 +{given = ["equality (lhs = rhs)",
89.151 + "bound_variable v","error_bound eps"],
89.152 + where_= [],
89.153 + find = ["solutions S"],
89.154 + with_ = ["ALL s. s : S --> || (%v. lhs) s - (%v. rhs) s || <= eps"],
89.155 + relate= []};
89.156 +
89.157 +
89.158 +(* find-values *)
89.159 +(* ----------- *)
89.160 +(* problem-type *)
89.161 +{given = ["max_relation r","additional_relations RS"],
89.162 + where_= [],
89.163 + find = ["values_for VS"],
89.164 + with_ = [(*???*)],
89.165 + relate= []};
89.166 +
89.167 +(* (1) variant of instantiation *)
89.168 +{given = ["max_relation (A = a*b)",
89.169 + "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]"],
89.170 + where_= [],
89.171 + find = ["values_for [a,b]"],
89.172 + with_ = [],
89.173 + relate= []};
89.174 +
89.175 +(* (2) variant of instantiation *)
89.176 +{given = ["max_relation (A = a*b)",],
89.177 + where_= [],
89.178 + find = ["values_for [A]",
89.179 + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
89.180 + with_ = [],
89.181 + relate= []};
89.182 +
89.183 +(*
89.184 +(3) data-transfer between the the hidden formalization,
89.185 + the root-problem and the sub-problems;
89.186 +
89.187 +maximum -> #given.make-fun
89.188 +-------------------
89.189 +maximum.#relate "max_relation r" -> "equality (lhs = rhs)"
89.190 +formalization "bound_variable v" -> "bound_variable v"
89.191 +maximum.#relate "additional_relations RS"-> "equalities es"
89.192 +
89.193 +
89.194 +maximum + make-fun -> #given.max-of-fun-on-interval
89.195 +--------------------------------------------
89.196 +make-fun.#find "function_term lhs_" -> "function_term t"
89.197 +make-fun.#given "bound_variable v" -> "bound_variable v"
89.198 +formalization -> "domain {x::real. ...}"
89.199 +
89.200 +
89.201 +max-of-fun-on-interval -> #given.derivative
89.202 +------------------------------------
89.203 +make-fun.#find "function_term lhs_" -> "function_term t"
89.204 +make-fun.#given "bound_variable v" -> "bound_variable bdv"
89.205 +
89.206 +
89.207 +max-of-fun-on-interval + derivative ->
89.208 + #given.["equation","univariate"]
89.209 +----------------------------------------------------------------
89.210 +derivative.#find "derivative t'" -> "equality (lhs = rhs)"
89.211 + (* t'= #0 *)
89.212 +make-fun.#given "bound_variable v" -> "bound_variable v"
89.213 +formalization -> "error_bound eps"
89.214 +
89.215 +
89.216 +maximum + make-fun + max-of-fun-on-interval -> #given.find-values
89.217 +----------------------------------------------------------
89.218 +maximum.#relate "max_relation r" -> "max_relation r"
89.219 +maximum.#relate "additional_relations RS"-> "additional_relations RS"
89.220 +*)
89.221 +
89.222 +
89.223 +
89.224 +
89.225 +(* vvv--- geht nicht wegen fun-types
89.226 +parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')";
89.227 +parse thy "if maxmin = is_max then (m' <= m) else (m <= m')";
89.228 +parse thy "if a=b then a else b";
89.229 +parse thy "maxmin = is_max";
89.230 +parse thy "maxmin =!= is_max";
89.231 + ^^^--- geht nicht wegen fun-types *)
89.232 +
89.233 +"pbltyp --- maximum ---";
89.234 +val pbltyp = {given=["fixed_values (cs::bool list)"],
89.235 + where_=["foldl (op &) True (map is_equality cs)",
89.236 + "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"],
89.237 + find=["maximum m","values_for (ms::real list)"],
89.238 + with_=["Ex_frees ((foldl (op &) True (r#rs)) & \
89.239 + \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \
89.240 + \ --> m' <= m)))"],
89.241 + relate=["max_relation r","additional_relations rs"]}:string ppc;
89.242 +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
89.243 +"coil";
89.244 +val org = ["fixed_values [R=(R::real)]",
89.245 + "bound_variable a", "bound_variable b", "bound_variable alpha",
89.246 + "domain {x::real. #0 <= x & x <= #2*R}",
89.247 + "domain {x::real. #0 <= x & x <= #2*R}",
89.248 + "domain {x::real. #0 <= x & x <= pi}",
89.249 + "maximum A",
89.250 + "max_relation A=#2*a*b - a^^^#2",
89.251 + "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
89.252 + "additional_relations [(a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
89.253 + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"];
89.254 +val chkorg = map (the o (parse thy)) org;
89.255 +val pbl = {given=["fixed_values [R=(R::real)]"],where_=[],
89.256 + find=["maximum A","values_for [a,b]"],
89.257 + with_=["EX alpha. A=#2*a*b - a^^^#2 & \
89.258 + \ a=#2*R*sin alpha & b=#2*R*cos alpha & \
89.259 + \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha & b=#2*R*cos alpha \
89.260 + \ --> A' <= A)"],
89.261 + relate=["max_relation (A=#2*a*b - a^^^#2)",
89.262 + "additional_relations [a=#2*R*sin alpha, b=#2*R*cos alpha]"]
89.263 + }: string ppc;
89.264 +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
89.265 +
89.266 +"met --- maximum_by_differentiation ---";
89.267 +val met = {given=["fixed_values (cs::bool list)","bound_variable v",
89.268 + "domain {x::real. lower_bound <= x & x <= upper_bound}",
89.269 + "approximation apx"],
89.270 + where_=[],
89.271 + find=["maximum m","values_for (ms::real list)",
89.272 + "function_term t","max_argument mx"],
89.273 + with_=["Ex_frees ((foldl (op &) True (rs::bool list)) & \
89.274 + \ (ALL m'. (subst (m,m') (foldl (op &) True rs) \
89.275 + \ --> m' <= m))) & \
89.276 + \m = (%v. t) mx & \
89.277 + \( ALL x. lower_bound <= x & x <= upper_bound \
89.278 + \ --> (%v. t) x <= m)"],
89.279 + relate=["rs::bool list"]}: string ppc;
89.280 +val chkpbl = ((map (the o (parse thy))) o ppc2list) met;
89.281 +
89.282 +
89.283 +"pbltyp --- make_fun ---";
89.284 +(* subproblem [(hd #relate root, equality),
89.285 + (bound_variable formalization, bound_variable),
89.286 + (tl #relate root, equalities)] *)
89.287 +val pbltyp = {given=["equality e","bound_variable v", "equalities es"],
89.288 + where_=[],
89.289 + find=["function_term t"],with_=[(*???*)],
89.290 + relate=[(*???*)]}: string ppc;
89.291 +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
89.292 +"coil";
89.293 +val pbl = {given=["equality (A=#2*a*b - a^^^#2)","bound_variable alpha",
89.294 + "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
89.295 + where_=[],
89.296 + find=["function_term t"],
89.297 + with_=[],relate=[]}: string ppc;
89.298 +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
89.299 +
89.300 +"met --- make_explicit_and_substitute ---";
89.301 +val met = {given=["equality e","bound_variable v", "equalities es"],
89.302 + where_=[],
89.303 + find=["function_term t"],with_=[(*???*)],
89.304 + relate=[(*???*)]}: string ppc;
89.305 +val chkmet = ((map (the o (parse thy))) o ppc2list) met;
89.306 +"met --- introduce_a_new_variable ---";
89.307 +val met = {given=["equality e","bound_variable v", "substitutions es"],
89.308 + where_=[],
89.309 + find=["function_term t"],with_=[(*???*)],
89.310 + relate=[(*???*)]}: string ppc;
89.311 +val chkmet = ((map (the o (parse thy))) o ppc2list) met;
89.312 +
89.313 +
89.314 +"pbltyp --- max_of_fun_on_interval ---";
89.315 +val pbltyp = {given=["function_term t","bound_variable v",
89.316 + "domain {x::real. lower_bound <= x & x <= upper_bound}"],
89.317 + where_=[],
89.318 + find=["maximums ms"],
89.319 + with_=["ALL m. m : ms --> \
89.320 + \ (ALL x::real. lower_bound <= x & x <= upper_bound \
89.321 + \ --> (%v. t) x <= m)"],
89.322 + relate=[]}: string ppc;
89.323 +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
89.324 +"coil";
89.325 +val pbl = {given=["function_term #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \
89.326 + \ (#2*R*sin alpha)^^^#2","bound_variable alpha",
89.327 + "domain {x::real. #0 <= x & x <= pi}"],where_=[],
89.328 + find=["maximums [#1234]"],with_=[],relate=[]}: string ppc;
89.329 +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
89.330 +
89.331 +
89.332 +(* pbltyp --- max_of_fun --- *)
89.333 +(*
89.334 +{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc;
89.335 +val (SOME ct) = parse thy ;
89.336 +atomty thy (term_of ct);
89.337 +*)
89.338 +
89.339 +
89.340 +
89.341 +
89.342 +
89.343 +
89.344 +
89.345 +
89.346 +(* --- 14.1.00 --- *)
89.347 +"p.114";
89.348 +val org = {given=["[u=(#12::real)]"],where_=[],
89.349 + find=["[a,(b::real)]"],with_=[],
89.350 + relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc;
89.351 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
89.352 +"p.116";
89.353 +val org = {given=["[c=#10, h=(#4::real)]"],where_=[],
89.354 + find=["[x,(y::real)]"],with_=[],
89.355 + relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc;
89.356 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
89.357 +"p.117";
89.358 +val org = {given=["[r=#5]"],where_=[],
89.359 + find=["[x,(y::real)]"],with_=[],
89.360 + relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc;
89.361 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
89.362 +"#241";
89.363 +val org = {given=["[s=(#10::real)]"],where_=[],
89.364 + find=["[p::real]"],with_=[],
89.365 + relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc;
89.366 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
89.367 +
89.368 +(*
89.369 +{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc;
89.370 +val (SOME ct) = parse thy ;
89.371 +atomty thy (term_of ct);
89.372 +*)
90.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
90.2 +++ b/src/Tools/isac/Knowledge/DiffApp-oldscr.sml Wed Aug 25 16:20:07 2010 +0200
90.3 @@ -0,0 +1,96 @@
90.4 +(*8.01: alte Scripts f"ur Extremwertaufgabe gesammelt*)
90.5 +
90.6 +(* Das erste Script aus dem Maximum-Beispiel.
90.7 + parse erzeugt aus dem string 's' den
90.8 + 'cterm 's' im Isabelle-Format (pretty-printing !)*)
90.9 +
90.10 +ML> ...
90.11 +ML> val c = (the o (parse thy)) s;
90.12 +val c =
90.13 + "Script1 Maximum_value fix_ m_ rs_ v_ itv_ err_ =
90.14 + let e_ = (hd o filter (Testvar m_)) rs_;
90.15 + t_ =
90.16 + if #1 < Length rs_
90.17 + then make_fun (R, [make, function], no_met) m_ v_ rs_
90.18 + else (Lhs o hd) rs_;
90.19 + mx_ =
90.20 + max_on_interval (R, [on_interval, max_of, function],
90.21 + maximum_on_interval) t_ v_ itv_
90.22 + in find_vals (R, [find_values, tool], find_values)
90.23 + mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm
90.24 +
90.25 +ML> set show_types;
90.26 +ML> c;
90.27 +val c =
90.28 + "Script1 Maximum_value fix_::bool list m_::real rs_::bool list v_::real itv_::real set err_::bool =
90.29 + let e_::bool = (hd o filter (Testvar m_)) rs_;
90.30 + t_::real =
90.31 + if (#1::real) < Length rs_
90.32 + then make_fun (R::ID, [make::ID, function::ID], no_met::ID) m_ v_ rs_
90.33 + else (Lhs o hd) rs_;
90.34 + mx_::real =
90.35 + max_on_interval (R, [on_interval::ID, max_of::ID, function],
90.36 + maximum_on_interval::ID) t_ v_ itv_
90.37 + in find_vals (R, [find_values::ID, tool::ID], find_values)
90.38 + mx_ t_ v_ m_ dropWhile (op = e_) rs_" : cterm
90.39 +
90.40 +
90.41 +
90.42 +(* Die ersten 3 Scripts aus dem Maximum-Beispiel.
90.43 + parse erzeugt aus dem string 's' den
90.44 + 'cterm 's' im Isabelle-Format (pretty-printing !)*)
90.45 +
90.46 +ML> ...
90.47 +ML> val c = (the o (parse thy)) s;
90.48 +val c =
90.49 + "Script maximum =
90.50 + Input [Bool fix_, Real m_, BoolList rs_, Real v_, RealSet itv_, Bool err_]
90.51 + Local [Bool e_, Real t_, Real mx_, RealList vs_]
90.52 + Tacs [SEQU
90.53 + [let e_ = (hd o filter (Testvar m_)) rs_
90.54 + in if #1 < Length rs_
90.55 + then Subproblem Spec (R, [make, function], no_met)
90.56 + InOut [In m_, In v_, In rs_, Out t_]
90.57 + else t_ := (Lhs o hd) rs_ ;
90.58 + Subproblem Spec (R, [on_interval, max_of, function],
90.59 + maximum_on_interval)
90.60 + InOut [In t_, In v_, In itv_, In err_, Out mx_] ;
90.61 + Subproblem Spec (R, [find_values, tool], find_values)
90.62 + InOut [In mx_, In t_, In v_, In m_, In (dropWhile (op = e_) rs_),
90.63 + Out vs_]]]
90.64 + Return []" : cterm
90.65 +
90.66 +ML> ...
90.67 +ML> val c = (the o (parse thy)) s;
90.68 +val c =
90.69 + "Script make_fun_by_new_variable =
90.70 + Input [Real f_, Real v_, BoolList eqs_]
90.71 + Local [Bool h_, BoolList es_, RealList vs_, Real v1_, Real v2_, Bool e1,
90.72 + Bool e2_, BoolList s_1, BoolList s_2]
90.73 + Tacs [SEQU
90.74 + [let h_ = (hd o filter (Testvar m_)) eqs_; es_ = eqs_ -- [h_];
90.75 + vs_ = Var h_ -- [f_]; v1_ = Nth #1 vs_; v2_ = Nth #2 vs_;
90.76 + e1_ = (hd o filter (Testvar v1_)) es_;
90.77 + e2_ = (hd o filter (Testvar v2_)) es_
90.78 + in Subproblem Spec (R, [univar, equation], no_met)
90.79 + InOut [In e1_, In v1_, Out s_1] ;
90.80 + Subproblem Spec (R, [univar, equation], no_met)
90.81 + InOut [In e2_, In v2_, Out s_2]],
90.82 + Take (Bool h_) ;
90.83 + Substitute [(v_1, (Rhs o hd) s_1), (v_2, (Rhs o hd) s_2)]]
90.84 + Return [Currform]" : cterm
90.85 +
90.86 +ML> ...
90.87 +ML> val c = (the o (parse thy)) s;
90.88 +val c =
90.89 + "Script make_fun_explicit =
90.90 + Input [Real f_, Real v_, BoolList eqs_]
90.91 + Local [Bool h_, Bool eq_, RealList vs_, Real v1_, BoolList ss_]
90.92 + Tacs [SEQU
90.93 + [let h_ = (hd o filter (Testvar m_)) eqs_; eq_ = hd (eqs_ -- [h_]);
90.94 + vs_ = Var h_ -- [f_]; v1_ = hd (vs_ -- [v_])
90.95 + in Subproblem Spec (R, [univar, equation], no_met)
90.96 + InOut [In eq_, In v1_, Out ss_]],
90.97 + Take (Bool h_) ; Substitute [(v1_, (Rhs o hd) ss_)]]
90.98 + Return [Currform]" : cterm
90.99 +ML>
91.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
91.2 +++ b/src/Tools/isac/Knowledge/DiffApp-scrpbl.sml Wed Aug 25 16:20:07 2010 +0200
91.3 @@ -0,0 +1,429 @@
91.4 +(* use"test-coil-kernel.sml";
91.5 + W.N.22.11.99
91.6 +
91.7 +*)
91.8 +
91.9 +(* vvv--- geht nicht wegen fun-types
91.10 +parse thy "case maxmin of is_max => (m' <= m) | is_min => (m <= m')";
91.11 +parse thy "if maxmin = is_max then (m' <= m) else (m <= m')";
91.12 +parse thy "if a=b then a else b";
91.13 +parse thy "maxmin = is_max";
91.14 +parse thy "maxmin =!= is_max";
91.15 + ^^^--- geht nicht wegen fun-types *)
91.16 +
91.17 +"pbltyp --- maximum ---";
91.18 +val pbltyp = {given=["fixedValues (cs::bool list)"],
91.19 + where_=[(*"foldl (op &) True (map is_equality cs)",
91.20 + "foldl (op &) True (map (Not o ((op <=) #0) o Rhs) cs)"*)],
91.21 + find=["maximum m","values_for (ms::real list)"],
91.22 + with_=[(*"Ex_frees ((foldl (op &) True (r#rs)) & \
91.23 + \ (ALL m'. (subst (m,m') (foldl (op &) True (r#rs)) \
91.24 + \ --> m' <= m)))"*)],
91.25 + relate=["max_relation r","additionalRels rs"]}:string ppc;
91.26 +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
91.27 +"coil";
91.28 +val org = ["fixedValues [R=(R::real)]",
91.29 + "boundVariable a","boundVariable b","boundVariable alpha",
91.30 + "domain {x::real. #0 <= x & x <= #2*R}",
91.31 + "domain {x::real. #0 <= x & x <= #2*R}",
91.32 + "domain {x::real. #0 <= x & x <= pi}",
91.33 + "errorBound (eps = #1//#1000)",
91.34 + "maximum A",
91.35 + (*"max_relation A=#2*a*b - a^^^#2",*)
91.36 + "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
91.37 + "relations [A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]",
91.38 + "relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"];
91.39 +val chkorg = map (the o (parse thy)) org;
91.40 +val pbl = {given=["fixedValues [R=(R::real)]"],where_=[],
91.41 + find=["maximum A","values_for [a,b]"],
91.42 + with_=[(* incompat.w. parse, ok with parseold
91.43 + "EX alpha. A=#2*a*b - a^^^#2 & \
91.44 + \ a=#2*R*sin alpha & b=#2*R*cos alpha & \
91.45 + \ (ALL A'. A'=#2*a*b - a^^^#2 & a=#2*R*sin alpha \
91.46 + \ & b=#2*R*cos alpha \
91.47 + \ --> A' <= A)"*)],
91.48 + relate=["relations [A=#2*a*b - a^^^#2, a=#2*R*sin alpha, b=#2*R*cos alpha]"]
91.49 + }: string ppc;
91.50 +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
91.51 +
91.52 +"met --- maximum_by_differentiation ---";
91.53 +val met = {given=["fixedValues (cs::bool list)","boundVariable v",
91.54 + "domain {x::real. lower_bound <= x & x<=upper_bound}",
91.55 + "errorBound epsilon"],
91.56 + where_=[],
91.57 + find=["maximum m","valuesFor (ms::bool list)",
91.58 + "function_term t","max_argument mx"],
91.59 + with_=[(* incompat.w. parse, ok with parseold
91.60 + "Ex_frees ((foldl (op &) True (mr#ars)) & \
91.61 + \ (ALL m'. (subst (m,m') (foldl (op &) True (mr#ars))\
91.62 + \ --> m' <= m))) & \
91.63 + \m = (%v. t) mx & \
91.64 + \( ALL x. lower_bound <= x & x <= upper_bound \
91.65 + \ --> (%v. t) x <= m)"*)],
91.66 + relate=["max_relation mr",
91.67 + "additionalRels ars"]}: string ppc;
91.68 +val chkpbl = ((map (the o (parse thy))) o ppc2list) met;
91.69 +
91.70 +"data --- maximum_by_differentiation ---";
91.71 +val met = {given=["fixedValues [R=(R::real)]","boundVariable alpha",
91.72 + "domain {x::real. #0 <= x & x <= pi//#2}",
91.73 + "errorBound (eps = #1//#1000)"],
91.74 + where_=[],
91.75 + find=["maximum A","valuesFor [a=Undef]",
91.76 + "function_term t","max_argument mx"],
91.77 + with_=[(* incompat.w. parse, ok with parseold
91.78 + "EX b alpha. A = #2*a*b - a^^^#2 & \
91.79 + \ a = #2*R*sin alpha & \
91.80 + \ b = #2*R*cos alpha & \
91.81 + \ (ALL A'. A'= #2*a*b - a^^^#2 & \
91.82 + \ a = #2*R*sin alpha & \
91.83 + \ b = #2*R*cos alpha --> A' <= A) & \
91.84 + \ A = (%alpha. t) mx & \
91.85 + \ (ALL x. #0 <= x & x <= pi --> \
91.86 + \ (%alpha. t) x <= A)"*)],
91.87 + relate=["max_relation mr",
91.88 + "additionalRels ars"]}: string ppc;
91.89 +val chkpbl = ((map (the o (parse thy))) o ppc2list) met;
91.90 +
91.91 +val (SOME ct) = parseold thy "EX b. (EX alpha. A = #2*a*b - a^^^#2)";
91.92 +
91.93 +"pbltyp --- make_fun ---";
91.94 +(* subproblem [(hd #relate root, equality),
91.95 + (boundVariable formalization, boundVariable),
91.96 + (tl #relate root, equalities)] *)
91.97 +val pbltyp = {given=["equality e","boundVariable v", "equalities es"],
91.98 + where_=[],
91.99 + find=["functionTerm t"],with_=[(*???*)],
91.100 + relate=[(*???*)]}: string ppc;
91.101 +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
91.102 +"coil";
91.103 +val pbl = {given=["equality (A=#2*a*b - a^^^#2)","boundVariable alpha",
91.104 + "equalities [a=#2*R*sin alpha, b=#2*R*cos alpha]"],
91.105 + where_=[],
91.106 + find=["functionTerm t"],
91.107 + with_=[],relate=[]}: string ppc;
91.108 +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
91.109 +
91.110 +"met --- make_explicit_and_substitute ---";
91.111 +val met = {given=["equality e","boundVariable v", "equalities es"],
91.112 + where_=[],
91.113 + find=["functionTerm t"],with_=[(*???*)],
91.114 + relate=[(*???*)]}: string ppc;
91.115 +val chkmet = ((map (the o (parse thy))) o ppc2list) met;
91.116 +"met --- introduce_a_new_variable ---";
91.117 +val met = {given=["equality e","boundVariable v", "substitutions es"],
91.118 + where_=[],
91.119 + find=["functionTerm t"],with_=[(*???*)],
91.120 + relate=[(*???*)]}: string ppc;
91.121 +val chkmet = ((map (the o (parse thy))) o ppc2list) met;
91.122 +
91.123 +
91.124 +"pbltyp --- max_of_fun_on_interval ---";
91.125 +val pbltyp = {given=["functionTerm t","boundVariable v",
91.126 + "domain {x::real. lower_bound <= x & x <= upper_bound}"],
91.127 + where_=[],
91.128 + find=["maximums ms"],
91.129 + with_=[(* incompat.w. parse, ok with parseold
91.130 + "ALL m. m : ms --> \
91.131 + \ (ALL x::real. lower_bound <= x & x <= upper_bound \
91.132 + \ --> (%v. t) x <= m)"*)],
91.133 + relate=[]}: string ppc;
91.134 +val chkpbltyp = ((map (the o (parse thy))) o ppc2list) pbltyp;
91.135 +"coil";
91.136 +val pbl = {given=["functionTerm (f = #2*(#2*R*sin alpha)*(#2*R*cos alpha) - \
91.137 + \ (#2*R*sin alpha)^^^#2)","boundVariable alpha",
91.138 + "domain {x::real. #0 <= x & x <= pi}"],where_=[],
91.139 + find=["maximums [#1234]"],with_=[],relate=[]}: string ppc;
91.140 +val chkpbl = ((map (the o (parse thy))) o ppc2list) pbl;
91.141 +
91.142 +
91.143 +(* pbltyp --- max_of_fun --- *)
91.144 +(*
91.145 +{given=[],where_=[],find=[],with_=[],relate=[]}: string ppc;
91.146 +val (SOME ct) = parse thy ;
91.147 +atomty (term_of ct);
91.148 +*)
91.149 +
91.150 +
91.151 +(* --- 14.1.00 ev. nicht ganz up to date bzg. oberem --- *)
91.152 +"p.114";
91.153 +val org = {given=["[u=(#12::real)]"],where_=[],
91.154 + find=["[a,(b::real)]"],with_=[],
91.155 + relate=["[is_max A=a*(b::real), #2*a+#2*b=(u::real)]"]}: string ppc;
91.156 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
91.157 +"p.116";
91.158 +val org = {given=["[c=#10, h=(#4::real)]"],where_=[],
91.159 + find=["[x,(y::real)]"],with_=[],
91.160 + relate=["[A=x*(y::real), c//h=x//(h-(y::real))]"]}: string ppc;
91.161 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
91.162 +"p.117";
91.163 +val org = {given=["[r=#5]"],where_=[],
91.164 + find=["[x,(y::real)]"],with_=[],
91.165 + relate=["[is_max #0=pi*x^^^#2 + pi*x*(r::real)]"]}: string ppc;
91.166 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
91.167 +"#241";
91.168 +val org = {given=["[s=(#10::real)]"],where_=[],
91.169 + find=["[p::real]"],with_=[],
91.170 + relate=["[is_max p=n*m, s=n+(m::real)]"]}: string ppc;
91.171 +val chkorg = ((map (the o (parse thy))) o ppc2list) org;
91.172 +
91.173 +
91.174 +
91.175 +(* -------------- coil-kernel -------------- vor 19.1.00 *)
91.176 +(* --- subproblem: make-function-by-subst ~~~~~~~~~~~ *)
91.177 +(* --- subproblem: max-of-function *)
91.178 +(* --- subproblem: derivative *)
91.179 +(* --- subproblem: tan-quadrat-equation *)
91.180 +"-------------- coil-kernel --------------";
91.181 +val origin = ["A=#2*a*b - a^^^#2",
91.182 + "a::real","b::real","{x. #0<x & x<R//#2}",
91.183 + "{(a//#2)^^^#2 + (b//#2)^^^#2 = (R//#2)^^^#2}",
91.184 + "alpha::real","{alpha::real. #0<alpha & alpha<pi//#2}",
91.185 + "{a//#2 = R*(sin alpha), b//#2 = R*(cos alpha)}",
91.186 + "{R::real}"];
91.187 +(* --- for a isa-users-mail --- FIXME
91.188 +Goal "{x. x < a} = ?z";
91.189 +{x::'a. x < a} = ?z
91.190 +Goal "{x. x < #3} = {a}";
91.191 +{x::'a. x < (#3::'a)} = {a}
91.192 +Goal "{x. #3 < x} = ?z";
91.193 +Collect (op < (#3::'a)) = ?z
91.194 +---------------------------- *)
91.195 +
91.196 +val formals = map (the o (parse thy)) origin;
91.197 +
91.198 +val given = ["formula_for_max (lhs=rhs)","boundVariable bdv",
91.199 + "interval {x. low < x & x < high}",
91.200 + "additional_conds ac","constants cs"];
91.201 +val where_ = ["lhs is_const","bdv is_const","low is_const","high is_const",
91.202 + "||| Vars equ ||| = ||| VarsSet ac ||| - ||| ac ||| + #1"];
91.203 +val find = ["f::real => real","maxs::real set"];
91.204 +val with_ = [(* incompat.w. parse, ok with parseold
91.205 + "maxs = {m. low < m & m < high & \
91.206 + \ (m is_local_max_of (%bdv. f))}"*)];
91.207 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
91.208 +val givens = map (the o (parse thy)) given;
91.209 +
91.210 +"------- 1.1 -------";
91.211 +(* 5.3.00
91.212 +val formals = map (the o (parse thy)) ["A=#2*a*b - a^^^#2",
91.213 + "a::real","{x. #0<x & x<R//#2}",
91.214 + "{(a//#2)^^^#2 + (b//#2)^^^#2 = (R//#2)^^^#2}",
91.215 + "{R::real}"];
91.216 +val tag__forms = chktyps thy (formals, givens);
91.217 +map ((atomty) o term_of) tag__forms;
91.218 +
91.219 +val formals = map (the o (parse thy)) ["A=#2*a*b - a^^^#2",
91.220 + "alpha::real","{alpha. #0<alpha & alpha<pi//#2}",
91.221 + "{a//#2 = R*(sin alpha), b//#2 = R*(cos alpha)}",
91.222 + "{R::real}"];
91.223 +val tag__forms = chktyps thy (formals, givens);
91.224 +map ((atomty) o term_of) tag__forms;
91.225 +*)
91.226 +
91.227 +" --- subproblem: make-function-by-subst --- ";
91.228 +val origin = ["A=#2*a*b - a^^^#2",
91.229 + "{a//#2 = R*(sin alpha), b//#2 = R*(cos alpha)}",
91.230 + "{R::real}"];
91.231 +val formals = map (the o (parse thy)) origin;
91.232 +
91.233 +val given = ["equation (lhs=rhs)","substitutions ss",
91.234 + "constants cs"];
91.235 +val where_ = [];
91.236 +val find = ["t::real"];
91.237 +val with_ = ["||| Vars t ||| = #1"];
91.238 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
91.239 +val givens = map (the o (parse thy)) given;
91.240 +(* 5.3.00
91.241 +val tag__forms = chktyps thy (formals, givens);
91.242 +map ((atomty) o term_of) tag__forms;
91.243 +*)
91.244 +" --- subproblem: max-of-function --- ";
91.245 +val origin = ["A = #2*(#2*R*(sin alpha))*(#2*R*(sin alpha)) - \
91.246 + \ (#2*R*(sin alpha))^^^#2",
91.247 + "{alpha. #0<alpha & alpha<pi//#2}",
91.248 + "{R::real}"];
91.249 +val formals = map (the o (parse thy)) origin;
91.250 +
91.251 +val given = ["equation (lhs=rhs)",
91.252 + "interval {x. low < x & x < high}",
91.253 + "constants cs"];
91.254 +val where_ = ["lhs is_const","low is_const","high is_const"];
91.255 +val find = ["t::real"];
91.256 +val with_ = ["||| Vars t ||| = #1"];
91.257 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
91.258 +val givens = map (the o (parse thy)) given;
91.259 +(* 5.3.00
91.260 +val tag__forms = chktyps thy (formals, givens);
91.261 +map ((atomty) o term_of) tag__forms;
91.262 +*)
91.263 +" --- subproblem: derivative --- ";
91.264 +val origin = ["x^^^#3-y^^^#3+#-3*x+#12*y+#10","x::real"];
91.265 +val formals = map (the o (parse thy)) origin;
91.266 +
91.267 +val given = ["functionTerm t",
91.268 + "boundVariable bdv"];
91.269 +val where_ = ["bdv is_const"];
91.270 +val find = ["t'::real"];
91.271 +val with_ = ["t' is_derivative_of (%bdv. t)"];
91.272 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
91.273 +val givens = map (the o (parse thy)) given;
91.274 +(*
91.275 +val tag__forms = chktyps thy (formals, givens);
91.276 +map ((atomty) o term_of) tag__forms;
91.277 +*)
91.278 +" --- subproblem: tan-quadrat-equation --- ";
91.279 +val origin = ["#8*R^^^#2*(cos alpha)^^^#2 + #-8*R^^^#2* \
91.280 + \ (cos alpha)*(sin alpha) + #8*R^^^#2*(sin alpha)^^^#2 = #0",
91.281 + "alpha::real","#1//#1000"];
91.282 +val formals = map (the o (parse thy)) origin;
91.283 +
91.284 +val given = ["equation (a*(cos bdv)^^^#2 + b*(cos bdv)*(sin bdv) + \
91.285 + \ c*(sin bdv) = #0)",
91.286 + "boundVariable bdv","errorBound epsilon"];
91.287 +val where_ = ["bdv is_const","epsilon is_const_expr"];
91.288 +val find = ["L::real set"];
91.289 +val with_ = ["L = {x. || (%bdv. a*(cos bdv)^^^#2 + b*(cos bdv)*(sin bdv) + \
91.290 + \ c*(sin bdv)) x || < epsilon}"];
91.291 +(* 5.3.00
91.292 +val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
91.293 +val givens = map (the o (parse thy)) given;
91.294 +val tag__forms = chktyps thy (formals, givens);
91.295 +map ((atomty) o term_of) tag__forms;
91.296 +*)
91.297 +(* use"test-coil-kernel.sml";
91.298 + *)
91.299 +
91.300 +
91.301 +" #################################################### ";
91.302 +" test specify ";
91.303 +" #################################################### ";
91.304 +
91.305 +
91.306 +val cts =
91.307 +["fixedValues [R=(R::real)]",
91.308 + "boundVariable a", "boundVariable b",
91.309 + "boundVariable alpha",
91.310 + "domain {x::real. #0 <= x & x <= #2*R}",
91.311 + "domain {x::real. #0 <= x & x <= #2*R}",
91.312 + "domain {x::real. #0 <= x & x <= pi//#2}",
91.313 + "errorBound (eps = #1//#1000)",
91.314 + "maximum A","valuesFor [a=Undef]",
91.315 + (*"functionTerm t","max_argument mx",
91.316 + "max_relation (A=#2*a*b - a^^^#2)", *)
91.317 + "additionalRels [A=#2*a*b - a^^^#2,(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
91.318 + "additionalRels [A=#2*a*b - a^^^#2,(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
91.319 + "additionalRels [A=#2*a*b - a^^^#2,a=#2*R*sin alpha, b=#2*R*cos alpha]"];
91.320 +val (dI',pI',mI')=
91.321 + ("DiffAppl.thy",["Script.thy","maximum_of","function"],e_metID);
91.322 +val c = []:cid;
91.323 +
91.324 +(*
91.325 +val pbl = {given=["fixedValues [R=(R::real)]","boundVariable alpha",
91.326 + "domain {x::real. #0 <= x & x <= pi//#2}",
91.327 + "errorBound (eps = #1//#1000)"],
91.328 + where_=[],
91.329 + find=["maximum A","valuesFor [a=Undef]"(*,
91.330 + "functionTerm t","max_argument mx"*)],
91.331 + with_=[],
91.332 + relate=["max_relation (A=#2*a*b - a^^^#2)",
91.333 + "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
91.334 + "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
91.335 + "additionalRels [a=#2*R*sin alpha, b=#2*R*cos alpha]"]
91.336 + }: string ppc;
91.337 +*)
91.338 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
91.339 + specify (Init_Proof (cts,(dI',pI',mI'))) e_pos' [] EmptyPtree;
91.340 +
91.341 +val ct = "fixedValues [R=(R::real)]";
91.342 +(*l(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify(Add_Given ct) p c pt*)
91.343 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.344 +
91.345 +val ct = "boundVariable a";
91.346 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.347 +val ct = "boundVariable alpha";
91.348 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.349 +
91.350 +val ct = "domain {x::real. #0 <= x & x <= pi//#2}";
91.351 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.352 +
91.353 +val ct = "errorBound (eps = (#1::real) // #1000)";
91.354 +val ct = "maximum A";
91.355 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.356 +
91.357 +val ct = "valuesFor [a=Undef]";
91.358 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.359 +
91.360 +val ct = "max_relation ()";
91.361 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.362 +
91.363 +val ct = "relations [A=#2*a*b - a^^^#2,(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]";
91.364 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.365 +
91.366 +(* ... nxt = Specify_Domain ...
91.367 +val ct = "additionalRels [b=#2*R*cos alpha]";
91.368 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
91.369 + specify(Add_Relation ct) p c pt;
91.370 +(*
91.371 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.372 +*)
91.373 +val ct = "additionalRels [a=#2*R*sin alpha]";
91.374 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
91.375 + specify(Add_Relation ct) p c pt;
91.376 +(*
91.377 +val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.378 +*)
91.379 +*)
91.380 +(* --- tricky case (termlist interleaving variants):
91.381 +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
91.382 + specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree;
91.383 +
91.384 +> val ct = "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2, b=#2*R*cos alpha]";
91.385 +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.386 +*)
91.387 +
91.388 +(* --- incomplete input ---
91.389 +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) =
91.390 + specify (Init_Proof (cts,(dI,pI,mI))) [] [] EmptyPtree;
91.391 +
91.392 +> val ct = "[R=(R::real)]";
91.393 +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.394 +
91.395 +> val ct = "R=(R::real)";
91.396 +> val(p,_,Form'(PpcKF(_,_,ppc)),nxt,_,pt) = specify nxt p c pt;
91.397 +
91.398 +> val ct = "(R::real)";
91.399 +> specify nxt p c pt;
91.400 +*)
91.401 +
91.402 +
91.403 +" #################################################### ";
91.404 +" test do_ specify ";
91.405 +" #################################################### ";
91.406 +
91.407 +
91.408 +val cts = ["fixedValues [R=(R::real)]",
91.409 + "boundVariable a", "boundVariable b",
91.410 + "boundVariable alpha",
91.411 + "domain {x::real. #0 <= x & x <= #2*R}",
91.412 + "domain {x::real. #0 <= x & x <= #2*R}",
91.413 + "domain {x::real. #0 <= x & x <= pi//#2}",
91.414 + "errorBound (eps=#1//#1000)",
91.415 + "maximum A","valuesFor [a=Undef]",
91.416 + (*"functionTerm t","max_argument mx", *)
91.417 + "max_relation (A=#2*a*b - a^^^#2)",
91.418 + "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
91.419 + "additionalRels [(a//#2)^^^#2 + (b//#2)^^^#2 =R^^^#2]",
91.420 + "additionalRels [a=#2*R*sin alpha, b=#2*R*cos alpha]"];
91.421 +val (dI',pI',mI')=
91.422 + ("DiffAppl.thy",["DiffAppl.thy","test_maximum"],e_metID);
91.423 +val p = e_pos'; val c = [];
91.424 +
91.425 +val (mI,m) = ("Init_Proof",Init_Proof (cts, (dI',pI',mI')));
91.426 +val (pst as (sc,pt,cl):pstate) = (EmptyScr, e_ptree, []);
91.427 +val (p,_,f,nxt,_,(_,pt,_)) = do_ (mI,m) p c pst;
91.428 +(*val nxt = ("Add_Given",Add_Given "fixedValues [R = R]")*)
91.429 +
91.430 +val (p,_,Form' (PpcKF (_,_,ppc)),nxt,_,(_,pt,_)) =
91.431 + do_ nxt p c (EmptyScr,pt,[]);
91.432 +(*val nxt = ("Add_Given",Add_Given "boundVariable a") *)
92.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
92.2 +++ b/src/Tools/isac/Knowledge/DiffApp.ML Wed Aug 25 16:20:07 2010 +0200
92.3 @@ -0,0 +1,221 @@
92.4 +(* tools for applications of differetiation
92.5 + use"DiffApp.ML";
92.6 + use"Knowledge/DiffApp.ML";
92.7 + use"../Knowledge/DiffApp.ML";
92.8 +
92.9 +
92.10 +WN.6.5.03: old decisions in this file partially are being changed
92.11 + in a quick-and-dirty way to make scripts run: Maximum_value,
92.12 + Make_fun_by_new_variable, Make_fun_by_explicit.
92.13 +found to be reconsidered:
92.14 +- descriptions (Descript.thy)
92.15 +- penv: really need term list; or just rerun the whole example with num/var
92.16 +- mk_arg, itms2args ... env in script different from penv ?
92.17 +- L = SubProblem eq ... show some vars on the worksheet ? (other means for
92.18 + referencing are labels (no on worksheet))
92.19 +
92.20 +WN.6.5.03 quick-and-dirty: mk_arg, itms2args just make most convenient env
92.21 + from penv as is.
92.22 + *)
92.23 +
92.24 +
92.25 +(** interface isabelle -- isac **)
92.26 +
92.27 +theory' := overwritel (!theory', [("DiffApp.thy",DiffApp.thy)]);
92.28 +
92.29 +val eval_rls = prep_rls(
92.30 + Rls {id="eval_rls",preconds = [], rew_ord = ("termlessI",termlessI),
92.31 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
92.32 + rules = [Thm ("refl",num_str refl),
92.33 + Thm ("le_refl",num_str le_refl),
92.34 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
92.35 + Thm ("not_true",num_str not_true),
92.36 + Thm ("not_false",num_str not_false),
92.37 + Thm ("and_true",and_true),
92.38 + Thm ("and_false",and_false),
92.39 + Thm ("or_true",or_true),
92.40 + Thm ("or_false",or_false),
92.41 + Thm ("and_commute",num_str and_commute),
92.42 + Thm ("or_commute",num_str or_commute),
92.43 +
92.44 + Calc ("op <",eval_equ "#less_"),
92.45 + Calc ("op <=",eval_equ "#less_equal_"),
92.46 +
92.47 + Calc ("Atools.ident",eval_ident "#ident_"),
92.48 + Calc ("Atools.is'_const",eval_const "#is_const_"),
92.49 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
92.50 + Calc ("Tools.matches",eval_matches "")
92.51 + ],
92.52 + scr = Script ((term_of o the o (parse thy))
92.53 + "empty_script")
92.54 + }:rls);
92.55 +ruleset' := overwritelthy thy
92.56 + (!ruleset',
92.57 + [("eval_rls",Atools_erls)(*FIXXXME:del with rls.rls'*)
92.58 + ]);
92.59 +
92.60 +
92.61 +(** problem types **)
92.62 +
92.63 +store_pbt
92.64 + (prep_pbt DiffApp.thy "pbl_fun_max" [] e_pblID
92.65 + (["maximum_of","function"],
92.66 + [("#Given" ,["fixedValues fix_"]),
92.67 + ("#Find" ,["maximum m_","valuesFor vs_"]),
92.68 + ("#Relate",["relations rs_"])
92.69 + ],
92.70 + e_rls, NONE, []));
92.71 +
92.72 +store_pbt
92.73 + (prep_pbt DiffApp.thy "pbl_fun_make" [] e_pblID
92.74 + (["make","function"]:pblID,
92.75 + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
92.76 + ("#Find" ,["functionEq f_1_"])
92.77 + ],
92.78 + e_rls, NONE, []));
92.79 +store_pbt
92.80 + (prep_pbt DiffApp.thy "pbl_fun_max_expl" [] e_pblID
92.81 + (["by_explicit","make","function"]:pblID,
92.82 + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
92.83 + ("#Find" ,["functionEq f_1_"])
92.84 + ],
92.85 + e_rls, NONE, [["DiffApp","make_fun_by_explicit"]]));
92.86 +store_pbt
92.87 + (prep_pbt DiffApp.thy "pbl_fun_max_newvar" [] e_pblID
92.88 + (["by_new_variable","make","function"]:pblID,
92.89 + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
92.90 + (*WN.12.5.03: precond for distinction still missing*)
92.91 + ("#Find" ,["functionEq f_1_"])
92.92 + ],
92.93 + e_rls, NONE, [["DiffApp","make_fun_by_new_variable"]]));
92.94 +
92.95 +store_pbt
92.96 + (prep_pbt DiffApp.thy "pbl_fun_max_interv" [] e_pblID
92.97 + (["on_interval","maximum_of","function"]:pblID,
92.98 + [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"]),
92.99 + (*WN.12.5.03: precond for distinction still missing*)
92.100 + ("#Find" ,["maxArgument v_0_"])
92.101 + ],
92.102 + e_rls, NONE, []));
92.103 +
92.104 +store_pbt
92.105 + (prep_pbt DiffApp.thy "pbl_tool" [] e_pblID
92.106 + (["tool"]:pblID,
92.107 + [],
92.108 + e_rls, NONE, []));
92.109 +
92.110 +store_pbt
92.111 + (prep_pbt DiffApp.thy "pbl_tool_findvals" [] e_pblID
92.112 + (["find_values","tool"]:pblID,
92.113 + [("#Given" ,["maxArgument ma_","functionEq f_","boundVariable v_"]),
92.114 + ("#Find" ,["valuesFor vls_"]),
92.115 + ("#Relate",["additionalRels rs_"])
92.116 + ],
92.117 + e_rls, NONE, []));
92.118 +
92.119 +
92.120 +(** methods, scripts not yet implemented **)
92.121 +
92.122 +store_met
92.123 + (prep_met Diff.thy "met_diffapp" [] e_metID
92.124 + (["DiffApp"],
92.125 + [],
92.126 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
92.127 + crls = Atools_erls, nrls=norm_Rational
92.128 + (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
92.129 +store_met
92.130 + (prep_met DiffApp.thy "met_diffapp_max" [] e_metID
92.131 + (["DiffApp","max_by_calculus"]:metID,
92.132 + [("#Given" ,["fixedValues fix_","maximum m_","relations rs_",
92.133 + "boundVariable v_","interval itv_","errorBound err_"]),
92.134 + ("#Find" ,["valuesFor vs_"]),
92.135 + ("#Relate",[])
92.136 + ],
92.137 + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls,
92.138 + crls = eval_rls, nrls=norm_Rational
92.139 + (*, asm_rls=[],asm_thm=[]*)},
92.140 + "Script Maximum_value(fix_::bool list)(m_::real) (rs_::bool list)\
92.141 + \ (v_::real) (itv_::real set) (err_::bool) = \
92.142 + \ (let e_ = (hd o (filterVar m_)) rs_; \
92.143 + \ t_ = (if 1 < length_ rs_ \
92.144 + \ then (SubProblem (DiffApp_,[make,function],[no_met])\
92.145 + \ [real_ m_, real_ v_, bool_list_ rs_])\
92.146 + \ else (hd rs_)); \
92.147 + \ (mx_::real) = SubProblem(DiffApp_,[on_interval,maximum_of,function],\
92.148 + \ [DiffApp,max_on_interval_by_calculus])\
92.149 + \ [bool_ t_, real_ v_, real_set_ itv_]\
92.150 + \ in ((SubProblem (DiffApp_,[find_values,tool],[Isac,find_values]) \
92.151 + \ [real_ mx_, real_ (Rhs t_), real_ v_, real_ m_, \
92.152 + \ bool_list_ (dropWhile (ident e_) rs_)])::bool list))"
92.153 + ));
92.154 +store_met
92.155 + (prep_met DiffApp.thy "met_diffapp_funnew" [] e_metID
92.156 + (["DiffApp","make_fun_by_new_variable"]:metID,
92.157 + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
92.158 + ("#Find" ,["functionEq f_1_"])
92.159 + ],
92.160 + {rew_ord'="tless_true",rls'=eval_rls,srls=list_rls,prls=e_rls,
92.161 + calc=[], crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)},
92.162 + "Script Make_fun_by_new_variable (f_::real) (v_::real) \
92.163 + \ (eqs_::bool list) = \
92.164 + \(let h_ = (hd o (filterVar f_)) eqs_; \
92.165 + \ es_ = dropWhile (ident h_) eqs_; \
92.166 + \ vs_ = dropWhile (ident f_) (Vars h_); \
92.167 + \ v_1 = nth_ 1 vs_; \
92.168 + \ v_2 = nth_ 2 vs_; \
92.169 + \ e_1 = (hd o (filterVar v_1)) es_; \
92.170 + \ e_2 = (hd o (filterVar v_2)) es_; \
92.171 + \ (s_1::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\
92.172 + \ [bool_ e_1, real_ v_1]);\
92.173 + \ (s_2::bool list) = (SubProblem (DiffApp_,[univariate,equation],[no_met])\
92.174 + \ [bool_ e_2, real_ v_2])\
92.175 + \in Substitute [(v_1 = (rhs o hd) s_1),(v_2 = (rhs o hd) s_2)] h_)"
92.176 +));
92.177 +store_met
92.178 +(prep_met DiffApp.thy "met_diffapp_funexp" [] e_metID
92.179 +(["DiffApp","make_fun_by_explicit"]:metID,
92.180 + [("#Given" ,["functionOf f_","boundVariable v_","equalities eqs_"]),
92.181 + ("#Find" ,["functionEq f_1_"])
92.182 + ],
92.183 + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls=list_rls,prls=e_rls,
92.184 + crls = eval_rls, nrls=norm_Rational
92.185 + (*, asm_rls=[],asm_thm=[]*)},
92.186 + "Script Make_fun_by_explicit (f_::real) (v_::real) \
92.187 + \ (eqs_::bool list) = \
92.188 + \ (let h_ = (hd o (filterVar f_)) eqs_; \
92.189 + \ e_1 = hd (dropWhile (ident h_) eqs_); \
92.190 + \ vs_ = dropWhile (ident f_) (Vars h_); \
92.191 + \ v_1 = hd (dropWhile (ident v_) vs_); \
92.192 + \ (s_1::bool list)=(SubProblem(DiffApp_,[univariate,equation],[no_met])\
92.193 + \ [bool_ e_1, real_ v_1])\
92.194 + \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)"
92.195 + ));
92.196 +store_met
92.197 + (prep_met DiffApp.thy "met_diffapp_max_oninterval" [] e_metID
92.198 + (["DiffApp","max_on_interval_by_calculus"]:metID,
92.199 + [("#Given" ,["functionEq t_","boundVariable v_","interval itv_"(*,
92.200 + "errorBound err_"*)]),
92.201 + ("#Find" ,["maxArgument v_0_"])
92.202 + ],
92.203 + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls,
92.204 + crls = eval_rls, nrls=norm_Rational
92.205 + (*, asm_rls=[],asm_thm=[]*)},
92.206 + "empty_script"
92.207 + ));
92.208 +store_met
92.209 + (prep_met DiffApp.thy "met_diffapp_findvals" [] e_metID
92.210 + (["DiffApp","find_values"]:metID,
92.211 + [],
92.212 + {rew_ord'="tless_true",rls'=eval_rls,calc=[],srls = e_rls,prls=e_rls,
92.213 + crls = eval_rls, nrls=norm_Rational(*,
92.214 + asm_rls=[],asm_thm=[]*)},
92.215 + "empty_script"));
92.216 +
92.217 +val list_rls = append_rls "list_rls" list_rls
92.218 + [Thm ("filterVar_Const", num_str filterVar_Const),
92.219 + Thm ("filterVar_Nil", num_str filterVar_Nil)
92.220 + ];
92.221 +ruleset' := overwritelthy thy (!ruleset',
92.222 + [("list_rls",list_rls)
92.223 + ]);
92.224 +
93.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
93.2 +++ b/src/Tools/isac/Knowledge/DiffApp.sml Wed Aug 25 16:20:07 2010 +0200
93.3 @@ -0,0 +1,105 @@
93.4 +(* = DiffAppl.ML
93.5 + +++ outcommented tests
93.6 +*)
93.7 +
93.8 +
93.9 +theory' := overwritel (!theory', [("DiffAppl.thy",DiffAppl.thy)]);
93.10 +
93.11 +(*
93.12 +> get_pbt ["DiffAppl.thy","maximum_of","function"];
93.13 +> get_met ("Script.thy","max_on_interval_by_calculus");
93.14 +> !pbltypes;
93.15 + *)
93.16 +pbltypes:= overwritel (!pbltypes,
93.17 +[
93.18 + prep_pbt DiffAppl.thy
93.19 + (["DiffAppl.thy","maximum_of","function"],
93.20 + [("#Given" ,"fixedValues fix_"),
93.21 + ("#Find" ,"maximum m_"),
93.22 + ("#Find" ,"valuesFor vs_"),
93.23 + ("#Relate","relations rs_") (*,
93.24 + ("#where" ,"foldl (op&) True (map (Not o ((op<=) #0) o Rhs) fix_)"),
93.25 + ("#with" ,"Ex_frees ((foldl (op &) True rs_) & \
93.26 + \ (ALL m'. (subst (m_,m') (foldl (op &) True rs_) \
93.27 + \ --> m' <= m_)))") *)
93.28 + ]),
93.29 +
93.30 + prep_pbt DiffAppl.thy
93.31 + (["DiffAppl.thy","make","function"]:pblID,
93.32 + [("#Given" ,"functionOf f_"),
93.33 + ("#Given" ,"boundVariable v_"),
93.34 + ("#Given" ,"equalities eqs_"),
93.35 + ("#Find" ,"functionTerm f_0_")
93.36 + ]),
93.37 +
93.38 + prep_pbt DiffAppl.thy
93.39 + (["DiffAppl.thy","on_interval","maximum_of","function"]:pblID,
93.40 + [("#Given" ,"functionTerm t_"),
93.41 + ("#Given" ,"boundVariable v_"),
93.42 + ("#Given" ,"interval itv_"),
93.43 + ("#Find" ,"maxArgument v_0_")
93.44 + ]),
93.45 +
93.46 + prep_pbt DiffAppl.thy
93.47 + (["DiffAppl.thy","find_values","tool"]:pblID,
93.48 + [("#Given" ,"maxArgument ma_"),
93.49 + ("#Given" ,"functionTerm f_"),
93.50 + ("#Given" ,"boundVariable v_"),
93.51 + ("#Find" ,"valuesFor vls_"),
93.52 + ("#Relate","additionalRels rs_")
93.53 + ])
93.54 +]);
93.55 +
93.56 +
93.57 +methods:= overwritel (!methods,
93.58 +[
93.59 + (("DiffAppl.thy","max_by_calculus"):metID,
93.60 + {ppc = prep_met DiffAppl.thy
93.61 + [("#Given" ,"fixedValues fix_"),
93.62 + ("#Given" ,"boundVariable v_"),
93.63 + ("#Given" ,"interval itv_"),
93.64 + ("#Given" ,"errorBound err_"),
93.65 + ("#Find" ,"maximum m_"),
93.66 + ("#Find" ,"valuesFor vs_"),
93.67 + ("#Relate","relations rs_")
93.68 + ],
93.69 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
93.70 + scr=EmptyScr} : met),
93.71 +
93.72 + (("DiffAppl.thy","make_fun_by_new_variable"):metID,
93.73 + {ppc = prep_met DiffAppl.thy
93.74 + [("#Given" ,"functionOf f_"),
93.75 + ("#Given" ,"boundVariable v_"),
93.76 + ("#Given" ,"equalities eqs_"),
93.77 + ("#Find" ,"functionTerm f_0_")
93.78 + ],
93.79 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
93.80 + scr=EmptyScr} : met),
93.81 +
93.82 + (("DiffAppl.thy","make_fun_by_explicit"):metID,
93.83 + {ppc = prep_met DiffAppl.thy
93.84 + [("#Given" ,"functionOf f_"),
93.85 + ("#Given" ,"boundVariable v_"),
93.86 + ("#Given" ,"equalities eqs_"),
93.87 + ("#Find" ,"functionTerm f_0_")
93.88 + ],
93.89 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
93.90 + scr=EmptyScr} : met),
93.91 +
93.92 + (("DiffAppl.thy","max_on_interval_by_calculus"):metID,
93.93 + {ppc = prep_met DiffAppl.thy
93.94 + [("#Given" ,"functionTerm t_"),
93.95 + ("#Given" ,"boundVariable v_"),
93.96 + ("#Given" ,"interval itv_"),
93.97 + ("#Given" ,"errorBound err_"),
93.98 + ("#Find" ,"maxArgument v_0_")
93.99 + ],
93.100 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
93.101 + scr=EmptyScr} : met),
93.102 +
93.103 + (("DiffAppl.thy","find_values"):metID,
93.104 + {ppc = prep_met DiffAppl.thy
93.105 + [],
93.106 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
93.107 + scr=EmptyScr} : met)
93.108 +]);
94.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
94.2 +++ b/src/Tools/isac/Knowledge/DiffApp.thy Wed Aug 25 16:20:07 2010 +0200
94.3 @@ -0,0 +1,40 @@
94.4 +(* application of differential calculus
94.5 + use_thy_only"../Knowledge/DiffApp";
94.6 + use_thy_only"DiffApp";
94.7 +
94.8 +
94.9 +*)
94.10 +
94.11 +
94.12 +DiffApp = Diff +
94.13 +
94.14 +consts
94.15 +
94.16 + Maximum'_value
94.17 + :: "[bool list,real,bool list,real,real set,bool,\
94.18 + \ bool list] => bool list"
94.19 + ("((Script Maximum'_value (_ _ _ _ _ _ =))// (_))" 9)
94.20 +
94.21 + Make'_fun'_by'_new'_variable
94.22 + :: "[real,real,bool list, \
94.23 + \ bool] => bool"
94.24 + ("((Script Make'_fun'_by'_new'_variable (_ _ _ =))// \
94.25 + \(_))" 9)
94.26 + Make'_fun'_by'_explicit
94.27 + :: "[real,real,bool list, \
94.28 + \ bool] => bool"
94.29 + ("((Script Make'_fun'_by'_explicit (_ _ _ =))// \
94.30 + \(_))" 9)
94.31 +
94.32 + dummy :: real
94.33 +
94.34 +(*for script Maximum_value*)
94.35 + filterVar :: "[real, 'a list] => 'a list"
94.36 +
94.37 +(*primrec*)rules
94.38 + filterVar_Nil "filterVar v [] = []"
94.39 + filterVar_Const "filterVar v (x#xs) = \
94.40 + \(if (v mem (Vars x)) then x#(filterVar v xs) \
94.41 + \ else filterVar v xs) "
94.42 +
94.43 +end
94.44 \ No newline at end of file
95.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
95.2 +++ b/src/Tools/isac/Knowledge/EqSystem.ML Wed Aug 25 16:20:07 2010 +0200
95.3 @@ -0,0 +1,673 @@
95.4 +(* tools for systems of equations over the reals
95.5 + author: Walther Neuper 050905, 08:51
95.6 + (c) due to copyright terms
95.7 +
95.8 +use"Knowledge/EqSystem.ML";
95.9 +use"EqSystem.ML";
95.10 +
95.11 +remove_thy"EqSystem";
95.12 +use_thy"Knowledge/Isac";
95.13 +*)
95.14 +
95.15 +(** interface isabelle -- isac **)
95.16 +
95.17 +theory' := overwritel (!theory', [("EqSystem.thy",EqSystem.thy)]);
95.18 +
95.19 +(** eval functions **)
95.20 +
95.21 +(*certain variables of a given list occur _all_ in a term
95.22 + args: all: ..variables, which are under consideration (eg. the bound vars)
95.23 + vs: variables which must be in t,
95.24 + and none of the others in all must be in t
95.25 + t: the term under consideration
95.26 + *)
95.27 +fun occur_exactly_in vs all t =
95.28 + let fun occurs_in' a b = occurs_in b a
95.29 + in foldl and_ (true, map (occurs_in' t) vs)
95.30 + andalso not (foldl or_ (false, map (occurs_in' t) (all \\ vs)))
95.31 + end;
95.32 +
95.33 +(*("occur_exactly_in", ("EqSystem.occur'_exactly'_in",
95.34 + eval_occur_exactly_in "#eval_occur_exactly_in_"))*)
95.35 +fun eval_occur_exactly_in _ "EqSystem.occur'_exactly'_in"
95.36 + (p as (Const ("EqSystem.occur'_exactly'_in",_)
95.37 + $ vs $ all $ t)) _ =
95.38 + if occur_exactly_in (isalist2list vs) (isalist2list all) t
95.39 + then SOME ((term2str p) ^ " = True",
95.40 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
95.41 + else SOME ((term2str p) ^ " = False",
95.42 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
95.43 + | eval_occur_exactly_in _ _ _ _ = NONE;
95.44 +
95.45 +calclist':=
95.46 +overwritel (!calclist',
95.47 + [("occur_exactly_in",
95.48 + ("EqSystem.occur'_exactly'_in",
95.49 + eval_occur_exactly_in "#eval_occur_exactly_in_"))
95.50 + ]);
95.51 +
95.52 +
95.53 +(** rewrite order 'ord_simplify_System' **)
95.54 +
95.55 +(* order wrt. several linear (i.e. without exponents) variables "c","c_2",..
95.56 + which leaves the monomials containing c, c_2,... at the end of an Integral
95.57 + and puts the c, c_2,... rightmost within a monomial.
95.58 +
95.59 + WN050906 this is a quick and dirty adaption of ord_make_polynomial_in,
95.60 + which was most adequate, because it uses size_of_term*)
95.61 +(**)
95.62 +local (*. for simplify_System .*)
95.63 +(**)
95.64 +open Term; (* for type order = EQUAL | LESS | GREATER *)
95.65 +
95.66 +fun pr_ord EQUAL = "EQUAL"
95.67 + | pr_ord LESS = "LESS"
95.68 + | pr_ord GREATER = "GREATER";
95.69 +
95.70 +fun dest_hd' (Const (a, T)) = (((a, 0), T), 0)
95.71 + | dest_hd' (Free (ccc, T)) =
95.72 + (case explode ccc of
95.73 + "c"::[] => ((("|||||||||||||||||||||", 0), T), 1)(*greatest string WN*)
95.74 + | "c"::"_"::_ => ((("|||||||||||||||||||||", 0), T), 1)
95.75 + | _ => (((ccc, 0), T), 1))
95.76 + | dest_hd' (Var v) = (v, 2)
95.77 + | dest_hd' (Bound i) = ((("", i), dummyT), 3)
95.78 + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
95.79 +
95.80 +fun size_of_term' (Free (ccc, _)) =
95.81 + (case explode ccc of (*WN0510 hack for the bound variables*)
95.82 + "c"::[] => 1000
95.83 + | "c"::"_"::is => 1000 * ((str2int o implode) is)
95.84 + | _ => 1)
95.85 + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
95.86 + | size_of_term' (f$t) = size_of_term' f + size_of_term' t
95.87 + | size_of_term' _ = 1;
95.88 +
95.89 +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
95.90 + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
95.91 + | term_ord' pr thy (t, u) =
95.92 + (if pr then
95.93 + let
95.94 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
95.95 + val _=writeln("t= f@ts= \""^
95.96 + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
95.97 + (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\"");
95.98 + val _=writeln("u= g@us= \""^
95.99 + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
95.100 + (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\"");
95.101 + val _=writeln("size_of_term(t,u)= ("^
95.102 + (string_of_int(size_of_term' t))^", "^
95.103 + (string_of_int(size_of_term' u))^")");
95.104 + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
95.105 + val _=writeln("terms_ord(ts,us) = "^
95.106 + ((pr_ord o terms_ord str false)(ts,us)));
95.107 + val _=writeln("-------");
95.108 + in () end
95.109 + else ();
95.110 + case int_ord (size_of_term' t, size_of_term' u) of
95.111 + EQUAL =>
95.112 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
95.113 + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
95.114 + | ord => ord)
95.115 + end
95.116 + | ord => ord)
95.117 +and hd_ord (f, g) = (* ~ term.ML *)
95.118 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f,
95.119 + dest_hd' g)
95.120 +and terms_ord str pr (ts, us) =
95.121 + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
95.122 +(**)
95.123 +in
95.124 +(**)
95.125 +(*WN0510 for preliminary use in eval_order_system, see case-study mat-eng.tex
95.126 +fun ord_simplify_System_rev (pr:bool) thy subst tu =
95.127 + (term_ord' pr thy (Library.swap tu) = LESS);*)
95.128 +
95.129 +(*for the rls's*)
95.130 +fun ord_simplify_System (pr:bool) thy subst tu =
95.131 + (term_ord' pr thy tu = LESS);
95.132 +(**)
95.133 +end;
95.134 +(**)
95.135 +rew_ord' := overwritel (!rew_ord',
95.136 +[("ord_simplify_System", ord_simplify_System false thy)
95.137 + ]);
95.138 +
95.139 +
95.140 +(** rulesets **)
95.141 +
95.142 +(*.adapted from 'order_add_mult_in' by just replacing the rew_ord.*)
95.143 +val order_add_mult_System =
95.144 + Rls{id = "order_add_mult_System", preconds = [],
95.145 + rew_ord = ("ord_simplify_System",
95.146 + ord_simplify_System false Integrate.thy),
95.147 + erls = e_rls,srls = Erls, calc = [],
95.148 + rules = [Thm ("real_mult_commute",num_str real_mult_commute),
95.149 + (* z * w = w * z *)
95.150 + Thm ("real_mult_left_commute",num_str real_mult_left_commute),
95.151 + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
95.152 + Thm ("real_mult_assoc",num_str real_mult_assoc),
95.153 + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
95.154 + Thm ("real_add_commute",num_str real_add_commute),
95.155 + (*z + w = w + z*)
95.156 + Thm ("real_add_left_commute",num_str real_add_left_commute),
95.157 + (*x + (y + z) = y + (x + z)*)
95.158 + Thm ("real_add_assoc",num_str real_add_assoc)
95.159 + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
95.160 + ],
95.161 + scr = EmptyScr}:rls;
95.162 +
95.163 +(*.adapted from 'norm_Rational' by
95.164 + #1 using 'ord_simplify_System' in 'order_add_mult_System'
95.165 + #2 NOT using common_nominator_p .*)
95.166 +val norm_System_noadd_fractions =
95.167 + Rls {id = "norm_System_noadd_fractions", preconds = [],
95.168 + rew_ord = ("dummy_ord",dummy_ord),
95.169 + erls = norm_rat_erls, srls = Erls, calc = [],
95.170 + rules = [(*sequence given by operator precedence*)
95.171 + Rls_ discard_minus,
95.172 + Rls_ powers,
95.173 + Rls_ rat_mult_divide,
95.174 + Rls_ expand,
95.175 + Rls_ reduce_0_1_2,
95.176 + Rls_ (*order_add_mult #1*) order_add_mult_System,
95.177 + Rls_ collect_numerals,
95.178 + (*Rls_ add_fractions_p, #2*)
95.179 + Rls_ cancel_p
95.180 + ],
95.181 + scr = Script ((term_of o the o (parse thy))
95.182 + "empty_script")
95.183 + }:rls;
95.184 +(*.adapted from 'norm_Rational' by
95.185 + *1* using 'ord_simplify_System' in 'order_add_mult_System'.*)
95.186 +val norm_System =
95.187 + Rls {id = "norm_System", preconds = [],
95.188 + rew_ord = ("dummy_ord",dummy_ord),
95.189 + erls = norm_rat_erls, srls = Erls, calc = [],
95.190 + rules = [(*sequence given by operator precedence*)
95.191 + Rls_ discard_minus,
95.192 + Rls_ powers,
95.193 + Rls_ rat_mult_divide,
95.194 + Rls_ expand,
95.195 + Rls_ reduce_0_1_2,
95.196 + Rls_ (*order_add_mult *1*) order_add_mult_System,
95.197 + Rls_ collect_numerals,
95.198 + Rls_ add_fractions_p,
95.199 + Rls_ cancel_p
95.200 + ],
95.201 + scr = Script ((term_of o the o (parse thy))
95.202 + "empty_script")
95.203 + }:rls;
95.204 +
95.205 +(*.simplify an equational system BEFORE solving it such that parentheses are
95.206 + ( ((u0*v0)*w0) + ( ((u1*v1)*w1) * c + ... +((u4*v4)*w4) * c_4 ) )
95.207 +ATTENTION: works ONLY for bound variables c, c_1, c_2, c_3, c_4 :ATTENTION
95.208 + This is a copy from 'make_ratpoly_in' with respective reductions:
95.209 + *0* expand the term, ie. distribute * and / over +
95.210 + *1* ord_simplify_System instead of termlessI
95.211 + *2* no add_fractions_p (= common_nominator_p_rls !)
95.212 + *3* discard_parentheses only for (.*(.*.))
95.213 + analoguous to simplify_Integral .*)
95.214 +val simplify_System_parenthesized =
95.215 + Seq {id = "simplify_System_parenthesized", preconds = []:term list,
95.216 + rew_ord = ("dummy_ord", dummy_ord),
95.217 + erls = Atools_erls, srls = Erls, calc = [],
95.218 + rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib),
95.219 + (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*)
95.220 + Thm ("real_add_divide_distrib",num_str real_add_divide_distrib),
95.221 + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)
95.222 + (*^^^^^ *0* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*)
95.223 + Rls_ norm_Rational_noadd_fractions(**2**),
95.224 + Rls_ (*order_add_mult_in*) norm_System_noadd_fractions (**1**),
95.225 + Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym))
95.226 + (*Rls_ discard_parentheses *3**),
95.227 + Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*)
95.228 + Rls_ separate_bdv2,
95.229 + Calc ("HOL.divide" ,eval_cancel "#divide_")
95.230 + ],
95.231 + scr = EmptyScr}:rls;
95.232 +
95.233 +(*.simplify an equational system AFTER solving it;
95.234 + This is a copy of 'make_ratpoly_in' with the differences
95.235 + *1* ord_simplify_System instead of termlessI .*)
95.236 +(*TODO.WN051031 ^^^^^^^^^^ should be in EACH rls contained *)
95.237 +val simplify_System =
95.238 + Seq {id = "simplify_System", preconds = []:term list,
95.239 + rew_ord = ("dummy_ord", dummy_ord),
95.240 + erls = Atools_erls, srls = Erls, calc = [],
95.241 + rules = [Rls_ norm_Rational,
95.242 + Rls_ (*order_add_mult_in*) norm_System (**1**),
95.243 + Rls_ discard_parentheses,
95.244 + Rls_ collect_bdv, (*from make_polynomial_in WN051031 welldone?*)
95.245 + Rls_ separate_bdv2,
95.246 + Calc ("HOL.divide" ,eval_cancel "#divide_")
95.247 + ],
95.248 + scr = EmptyScr}:rls;
95.249 +(*
95.250 +val simplify_System =
95.251 + append_rls "simplify_System" simplify_System_parenthesized
95.252 + [Thm ("sym_real_add_assoc", num_str (real_add_assoc RS sym))];
95.253 +*)
95.254 +
95.255 +val isolate_bdvs =
95.256 + Rls {id="isolate_bdvs", preconds = [],
95.257 + rew_ord = ("e_rew_ord", e_rew_ord),
95.258 + erls = append_rls "erls_isolate_bdvs" e_rls
95.259 + [(Calc ("EqSystem.occur'_exactly'_in",
95.260 + eval_occur_exactly_in
95.261 + "#eval_occur_exactly_in_"))
95.262 + ],
95.263 + srls = Erls, calc = [],
95.264 + rules = [Thm ("commute_0_equality",
95.265 + num_str commute_0_equality),
95.266 + Thm ("separate_bdvs_add", num_str separate_bdvs_add),
95.267 + Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)],
95.268 + scr = EmptyScr};
95.269 +val isolate_bdvs_4x4 =
95.270 + Rls {id="isolate_bdvs_4x4", preconds = [],
95.271 + rew_ord = ("e_rew_ord", e_rew_ord),
95.272 + erls = append_rls
95.273 + "erls_isolate_bdvs_4x4" e_rls
95.274 + [Calc ("EqSystem.occur'_exactly'_in",
95.275 + eval_occur_exactly_in "#eval_occur_exactly_in_"),
95.276 + Calc ("Atools.ident",eval_ident "#ident_"),
95.277 + Calc ("Atools.some'_occur'_in",
95.278 + eval_some_occur_in "#some_occur_in_"),
95.279 + Thm ("not_true",num_str not_true),
95.280 + Thm ("not_false",num_str not_false)
95.281 + ],
95.282 + srls = Erls, calc = [],
95.283 + rules = [Thm ("commute_0_equality",
95.284 + num_str commute_0_equality),
95.285 + Thm ("separate_bdvs0", num_str separate_bdvs0),
95.286 + Thm ("separate_bdvs_add1", num_str separate_bdvs_add1),
95.287 + Thm ("separate_bdvs_add1", num_str separate_bdvs_add2),
95.288 + Thm ("separate_bdvs_mult", num_str separate_bdvs_mult)],
95.289 + scr = EmptyScr};
95.290 +
95.291 +(*.order the equations in a system such, that a triangular system (if any)
95.292 + appears as [..c_4 = .., ..., ..., ..c_1 + ..c_2 + ..c_3 ..c_4 = ..].*)
95.293 +val order_system =
95.294 + Rls {id="order_system", preconds = [],
95.295 + rew_ord = ("ord_simplify_System",
95.296 + ord_simplify_System false thy),
95.297 + erls = Erls, srls = Erls, calc = [],
95.298 + rules = [Thm ("order_system_NxN", num_str order_system_NxN)
95.299 + ],
95.300 + scr = EmptyScr};
95.301 +
95.302 +val prls_triangular =
95.303 + Rls {id="prls_triangular", preconds = [],
95.304 + rew_ord = ("e_rew_ord", e_rew_ord),
95.305 + erls = Rls {id="erls_prls_triangular", preconds = [],
95.306 + rew_ord = ("e_rew_ord", e_rew_ord),
95.307 + erls = Erls, srls = Erls, calc = [],
95.308 + rules = [(*for precond nth_Cons_ ...*)
95.309 + Calc ("op <",eval_equ "#less_"),
95.310 + Calc ("op +", eval_binop "#add_")
95.311 + (*immediately repeated rewrite pushes
95.312 + '+' into precondition !*)
95.313 + ],
95.314 + scr = EmptyScr},
95.315 + srls = Erls, calc = [],
95.316 + rules = [Thm ("nth_Cons_",num_str nth_Cons_),
95.317 + Calc ("op +", eval_binop "#add_"),
95.318 + Thm ("nth_Nil_",num_str nth_Nil_),
95.319 + Thm ("tl_Cons",num_str tl_Cons),
95.320 + Thm ("tl_Nil",num_str tl_Nil),
95.321 + Calc ("EqSystem.occur'_exactly'_in",
95.322 + eval_occur_exactly_in
95.323 + "#eval_occur_exactly_in_")
95.324 + ],
95.325 + scr = EmptyScr};
95.326 +
95.327 +(*WN060914 quickly created for 4x4;
95.328 + more similarity to prls_triangular desirable*)
95.329 +val prls_triangular4 =
95.330 + Rls {id="prls_triangular4", preconds = [],
95.331 + rew_ord = ("e_rew_ord", e_rew_ord),
95.332 + erls = Rls {id="erls_prls_triangular4", preconds = [],
95.333 + rew_ord = ("e_rew_ord", e_rew_ord),
95.334 + erls = Erls, srls = Erls, calc = [],
95.335 + rules = [(*for precond nth_Cons_ ...*)
95.336 + Calc ("op <",eval_equ "#less_"),
95.337 + Calc ("op +", eval_binop "#add_")
95.338 + (*immediately repeated rewrite pushes
95.339 + '+' into precondition !*)
95.340 + ],
95.341 + scr = EmptyScr},
95.342 + srls = Erls, calc = [],
95.343 + rules = [Thm ("nth_Cons_",num_str nth_Cons_),
95.344 + Calc ("op +", eval_binop "#add_"),
95.345 + Thm ("nth_Nil_",num_str nth_Nil_),
95.346 + Thm ("tl_Cons",num_str tl_Cons),
95.347 + Thm ("tl_Nil",num_str tl_Nil),
95.348 + Calc ("EqSystem.occur'_exactly'_in",
95.349 + eval_occur_exactly_in
95.350 + "#eval_occur_exactly_in_")
95.351 + ],
95.352 + scr = EmptyScr};
95.353 +
95.354 +ruleset' :=
95.355 +overwritelthy thy
95.356 + (!ruleset',
95.357 +[("simplify_System_parenthesized", prep_rls simplify_System_parenthesized),
95.358 + ("simplify_System", prep_rls simplify_System),
95.359 + ("isolate_bdvs", prep_rls isolate_bdvs),
95.360 + ("isolate_bdvs_4x4", prep_rls isolate_bdvs_4x4),
95.361 + ("order_system", prep_rls order_system),
95.362 + ("order_add_mult_System", prep_rls order_add_mult_System),
95.363 + ("norm_System_noadd_fractions", prep_rls norm_System_noadd_fractions),
95.364 + ("norm_System", prep_rls norm_System)
95.365 + ]);
95.366 +
95.367 +
95.368 +(** problems **)
95.369 +
95.370 +store_pbt
95.371 + (prep_pbt EqSystem.thy "pbl_equsys" [] e_pblID
95.372 + (["system"],
95.373 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.374 + ("#Find" ,["solution ss___"](*___ is copy-named*))
95.375 + ],
95.376 + append_rls "e_rls" e_rls [(*for preds in where_*)],
95.377 + SOME "solveSystem es_ vs_",
95.378 + []));
95.379 +store_pbt
95.380 + (prep_pbt EqSystem.thy "pbl_equsys_lin" [] e_pblID
95.381 + (["linear", "system"],
95.382 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.383 + (*TODO.WN050929 check linearity*)
95.384 + ("#Find" ,["solution ss___"])
95.385 + ],
95.386 + append_rls "e_rls" e_rls [(*for preds in where_*)],
95.387 + SOME "solveSystem es_ vs_",
95.388 + []));
95.389 +store_pbt
95.390 + (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2" [] e_pblID
95.391 + (["2x2", "linear", "system"],
95.392 + (*~~~~~~~~~~~~~~~~~~~~~~~~~*)
95.393 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.394 + ("#Where" ,["length_ (es_:: bool list) = 2", "length_ vs_ = 2"]),
95.395 + ("#Find" ,["solution ss___"])
95.396 + ],
95.397 + append_rls "prls_2x2_linear_system" e_rls
95.398 + [Thm ("length_Cons_",num_str length_Cons_),
95.399 + Thm ("length_Nil_",num_str length_Nil_),
95.400 + Calc ("op +", eval_binop "#add_"),
95.401 + Calc ("op =",eval_equal "#equal_")
95.402 + ],
95.403 + SOME "solveSystem es_ vs_",
95.404 + []));
95.405 +store_pbt
95.406 + (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_tri" [] e_pblID
95.407 + (["triangular", "2x2", "linear", "system"],
95.408 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.409 + ("#Where" ,
95.410 + ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))",
95.411 + " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]),
95.412 + ("#Find" ,["solution ss___"])
95.413 + ],
95.414 + prls_triangular,
95.415 + SOME "solveSystem es_ vs_",
95.416 + [["EqSystem","top_down_substitution","2x2"]]));
95.417 +store_pbt
95.418 + (prep_pbt EqSystem.thy "pbl_equsys_lin_2x2_norm" [] e_pblID
95.419 + (["normalize", "2x2", "linear", "system"],
95.420 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.421 + ("#Find" ,["solution ss___"])
95.422 + ],
95.423 + append_rls "e_rls" e_rls [(*for preds in where_*)],
95.424 + SOME "solveSystem es_ vs_",
95.425 + [["EqSystem","normalize","2x2"]]));
95.426 +store_pbt
95.427 + (prep_pbt EqSystem.thy "pbl_equsys_lin_3x3" [] e_pblID
95.428 + (["3x3", "linear", "system"],
95.429 + (*~~~~~~~~~~~~~~~~~~~~~~~~~*)
95.430 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.431 + ("#Where" ,["length_ (es_:: bool list) = 3", "length_ vs_ = 3"]),
95.432 + ("#Find" ,["solution ss___"])
95.433 + ],
95.434 + append_rls "prls_3x3_linear_system" e_rls
95.435 + [Thm ("length_Cons_",num_str length_Cons_),
95.436 + Thm ("length_Nil_",num_str length_Nil_),
95.437 + Calc ("op +", eval_binop "#add_"),
95.438 + Calc ("op =",eval_equal "#equal_")
95.439 + ],
95.440 + SOME "solveSystem es_ vs_",
95.441 + []));
95.442 +store_pbt
95.443 + (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4" [] e_pblID
95.444 + (["4x4", "linear", "system"],
95.445 + (*~~~~~~~~~~~~~~~~~~~~~~~~~*)
95.446 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.447 + ("#Where" ,["length_ (es_:: bool list) = 4", "length_ vs_ = 4"]),
95.448 + ("#Find" ,["solution ss___"])
95.449 + ],
95.450 + append_rls "prls_4x4_linear_system" e_rls
95.451 + [Thm ("length_Cons_",num_str length_Cons_),
95.452 + Thm ("length_Nil_",num_str length_Nil_),
95.453 + Calc ("op +", eval_binop "#add_"),
95.454 + Calc ("op =",eval_equal "#equal_")
95.455 + ],
95.456 + SOME "solveSystem es_ vs_",
95.457 + []));
95.458 +store_pbt
95.459 + (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_tri" [] e_pblID
95.460 + (["triangular", "4x4", "linear", "system"],
95.461 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.462 + ("#Where" , (*accepts missing variables up to diagional form*)
95.463 + ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))",
95.464 + "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))",
95.465 + "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))",
95.466 + "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))"
95.467 + ]),
95.468 + ("#Find" ,["solution ss___"])
95.469 + ],
95.470 + append_rls "prls_tri_4x4_lin_sys" prls_triangular
95.471 + [Calc ("Atools.occurs'_in",eval_occurs_in "")],
95.472 + SOME "solveSystem es_ vs_",
95.473 + [["EqSystem","top_down_substitution","4x4"]]));
95.474 +
95.475 +store_pbt
95.476 + (prep_pbt EqSystem.thy "pbl_equsys_lin_4x4_norm" [] e_pblID
95.477 + (["normalize", "4x4", "linear", "system"],
95.478 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.479 + (*length_ is checked 1 level above*)
95.480 + ("#Find" ,["solution ss___"])
95.481 + ],
95.482 + append_rls "e_rls" e_rls [(*for preds in where_*)],
95.483 + SOME "solveSystem es_ vs_",
95.484 + [["EqSystem","normalize","4x4"]]));
95.485 +
95.486 +
95.487 +(* show_ptyps();
95.488 + *)
95.489 +
95.490 +(** methods **)
95.491 +
95.492 +store_met
95.493 + (prep_met EqSystem.thy "met_eqsys" [] e_metID
95.494 + (["EqSystem"],
95.495 + [],
95.496 + {rew_ord'="tless_true", rls' = Erls, calc = [],
95.497 + srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
95.498 + "empty_script"
95.499 + ));
95.500 +store_met
95.501 + (prep_met EqSystem.thy "met_eqsys_topdown" [] e_metID
95.502 + (["EqSystem","top_down_substitution"],
95.503 + [],
95.504 + {rew_ord'="tless_true", rls' = Erls, calc = [],
95.505 + srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
95.506 + "empty_script"
95.507 + ));
95.508 +store_met
95.509 + (prep_met EqSystem.thy "met_eqsys_topdown_2x2" [] e_metID
95.510 + (["EqSystem","top_down_substitution","2x2"],
95.511 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.512 + ("#Where" ,
95.513 + ["(tl vs_) from_ vs_ occur_exactly_in (nth_ 1 (es_::bool list))",
95.514 + " vs_ from_ vs_ occur_exactly_in (nth_ 2 (es_::bool list))"]),
95.515 + ("#Find" ,["solution ss___"])
95.516 + ],
95.517 + {rew_ord'="ord_simplify_System", rls' = Erls, calc = [],
95.518 + srls = append_rls "srls_top_down_2x2" e_rls
95.519 + [Thm ("hd_thm",num_str hd_thm),
95.520 + Thm ("tl_Cons",num_str tl_Cons),
95.521 + Thm ("tl_Nil",num_str tl_Nil)
95.522 + ],
95.523 + prls = prls_triangular, crls = Erls, nrls = Erls},
95.524 +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
95.525 +\ (let e1__ = Take (hd es_); \
95.526 +\ e1__ = ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.527 +\ isolate_bdvs False)) @@ \
95.528 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.529 +\ simplify_System False))) e1__; \
95.530 +\ e2__ = Take (hd (tl es_)); \
95.531 +\ e2__ = ((Substitute [e1__]) @@ \
95.532 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.533 +\ simplify_System_parenthesized False)) @@ \
95.534 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.535 +\ isolate_bdvs False)) @@ \
95.536 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.537 +\ simplify_System False))) e2__; \
95.538 +\ es__ = Take [e1__, e2__] \
95.539 +\ in (Try (Rewrite_Set order_system False)) es__)"
95.540 +(*---------------------------------------------------------------------------
95.541 + this script does NOT separate the equations as abolve,
95.542 + but it does not yet work due to preliminary script-interpreter,
95.543 + see eqsystem.sml 'script [EqSystem,top_down_substitution,2x2] Vers.2'
95.544 +
95.545 +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
95.546 +\ (let es__ = Take es_; \
95.547 +\ e1__ = hd es__; \
95.548 +\ e2__ = hd (tl es__); \
95.549 +\ es__ = [e1__, Substitute [e1__] e2__] \
95.550 +\ in ((Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.551 +\ simplify_System_parenthesized False)) @@ \
95.552 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))] \
95.553 +\ isolate_bdvs False)) @@ \
95.554 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.555 +\ simplify_System False))) es__)"
95.556 +---------------------------------------------------------------------------*)
95.557 + ));
95.558 +store_met
95.559 + (prep_met EqSystem.thy "met_eqsys_norm" [] e_metID
95.560 + (["EqSystem","normalize"],
95.561 + [],
95.562 + {rew_ord'="tless_true", rls' = Erls, calc = [],
95.563 + srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
95.564 + "empty_script"
95.565 + ));
95.566 +store_met
95.567 + (prep_met EqSystem.thy "met_eqsys_norm_2x2" [] e_metID
95.568 + (["EqSystem","normalize","2x2"],
95.569 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.570 + ("#Find" ,["solution ss___"])],
95.571 + {rew_ord'="tless_true", rls' = Erls, calc = [],
95.572 + srls = append_rls "srls_normalize_2x2" e_rls
95.573 + [Thm ("hd_thm",num_str hd_thm),
95.574 + Thm ("tl_Cons",num_str tl_Cons),
95.575 + Thm ("tl_Nil",num_str tl_Nil)
95.576 + ],
95.577 + prls = Erls, crls = Erls, nrls = Erls},
95.578 +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
95.579 +\ (let es__ = ((Try (Rewrite_Set norm_Rational False)) @@ \
95.580 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.581 +\ simplify_System_parenthesized False)) @@ \
95.582 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.583 +\ isolate_bdvs False)) @@ \
95.584 +\ (Try (Rewrite_Set_Inst [(bdv_1, hd vs_),(bdv_2, hd (tl vs_))]\
95.585 +\ simplify_System_parenthesized False)) @@ \
95.586 +\ (Try (Rewrite_Set order_system False))) es_ \
95.587 +\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \
95.588 +\ [bool_list_ es__, real_list_ vs_]))"
95.589 + ));
95.590 +
95.591 +(*this is for nth_ only*)
95.592 +val srls = Rls {id="srls_normalize_4x4",
95.593 + preconds = [],
95.594 + rew_ord = ("termlessI",termlessI),
95.595 + erls = append_rls "erls_in_srls_IntegrierenUnd.." e_rls
95.596 + [(*for asm in nth_Cons_ ...*)
95.597 + Calc ("op <",eval_equ "#less_"),
95.598 + (*2nd nth_Cons_ pushes n+-1 into asms*)
95.599 + Calc("op +", eval_binop "#add_")
95.600 + ],
95.601 + srls = Erls, calc = [],
95.602 + rules = [Thm ("nth_Cons_",num_str nth_Cons_),
95.603 + Calc("op +", eval_binop "#add_"),
95.604 + Thm ("nth_Nil_",num_str nth_Nil_)],
95.605 + scr = EmptyScr};
95.606 +store_met
95.607 + (prep_met EqSystem.thy "met_eqsys_norm_4x4" [] e_metID
95.608 + (["EqSystem","normalize","4x4"],
95.609 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.610 + ("#Find" ,["solution ss___"])],
95.611 + {rew_ord'="tless_true", rls' = Erls, calc = [],
95.612 + srls = append_rls "srls_normalize_4x4" srls
95.613 + [Thm ("hd_thm",num_str hd_thm),
95.614 + Thm ("tl_Cons",num_str tl_Cons),
95.615 + Thm ("tl_Nil",num_str tl_Nil)
95.616 + ],
95.617 + prls = Erls, crls = Erls, nrls = Erls},
95.618 +(*GOON met ["EqSystem","normalize","4x4"] @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
95.619 +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
95.620 +\ (let es__ = \
95.621 +\ ((Try (Rewrite_Set norm_Rational False)) @@ \
95.622 +\ (Repeat (Rewrite commute_0_equality False)) @@ \
95.623 +\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \
95.624 +\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \
95.625 +\ simplify_System_parenthesized False)) @@ \
95.626 +\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \
95.627 +\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \
95.628 +\ isolate_bdvs_4x4 False)) @@ \
95.629 +\ (Try (Rewrite_Set_Inst [(bdv_1, nth_ 1 vs_),(bdv_2, nth_ 2 vs_ ), \
95.630 +\ (bdv_3, nth_ 3 vs_),(bdv_3, nth_ 4 vs_ )] \
95.631 +\ simplify_System_parenthesized False)) @@ \
95.632 +\ (Try (Rewrite_Set order_system False))) es_ \
95.633 +\ in (SubProblem (EqSystem_,[linear,system],[no_met]) \
95.634 +\ [bool_list_ es__, real_list_ vs_]))"
95.635 +));
95.636 +store_met
95.637 +(prep_met EqSystem.thy "met_eqsys_topdown_4x4" [] e_metID
95.638 + (["EqSystem","top_down_substitution","4x4"],
95.639 + [("#Given" ,["equalities es_", "solveForVars vs_"]),
95.640 + ("#Where" , (*accepts missing variables up to diagonal form*)
95.641 + ["(nth_ 1 (vs_::real list)) occurs_in (nth_ 1 (es_::bool list))",
95.642 + "(nth_ 2 (vs_::real list)) occurs_in (nth_ 2 (es_::bool list))",
95.643 + "(nth_ 3 (vs_::real list)) occurs_in (nth_ 3 (es_::bool list))",
95.644 + "(nth_ 4 (vs_::real list)) occurs_in (nth_ 4 (es_::bool list))"
95.645 + ]),
95.646 + ("#Find" ,["solution ss___"])
95.647 + ],
95.648 + {rew_ord'="ord_simplify_System", rls' = Erls, calc = [],
95.649 + srls = append_rls "srls_top_down_4x4" srls [],
95.650 + prls = append_rls "prls_tri_4x4_lin_sys" prls_triangular
95.651 + [Calc ("Atools.occurs'_in",eval_occurs_in "")],
95.652 + crls = Erls, nrls = Erls},
95.653 +(*FIXXXXME.WN060916: this script works ONLY for exp 7.79 @@@@@@@@@@@@@@@@@@@@*)
95.654 +"Script SolveSystemScript (es_::bool list) (vs_::real list) = \
95.655 +\ (let e1_ = nth_ 1 es_; \
95.656 +\ e2_ = Take (nth_ 2 es_); \
95.657 +\ e2_ = ((Substitute [e1_]) @@ \
95.658 +\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\
95.659 +\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\
95.660 +\ simplify_System_parenthesized False)) @@ \
95.661 +\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\
95.662 +\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\
95.663 +\ isolate_bdvs False)) @@ \
95.664 +\ (Try (Rewrite_Set_Inst [(bdv_1,nth_ 1 vs_),(bdv_2,nth_ 2 vs_),\
95.665 +\ (bdv_3,nth_ 3 vs_),(bdv_4,nth_ 4 vs_)]\
95.666 +\ norm_Rational False))) e2_ \
95.667 +\ in [e1_, e2_, nth_ 3 es_, nth_ 4 es_])"
95.668 +));
95.669 +
95.670 +(* show_mets();
95.671 + *)
95.672 +
95.673 +(*
95.674 +use"Knowledge/EqSystem.ML";
95.675 +use"EqSystem.ML";
95.676 +*)
96.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
96.2 +++ b/src/Tools/isac/Knowledge/EqSystem.thy Wed Aug 25 16:20:07 2010 +0200
96.3 @@ -0,0 +1,72 @@
96.4 +(* equational systems, minimal -- for use in Biegelinie
96.5 + author: Walther Neuper
96.6 + 050826,
96.7 + (c) due to copyright terms
96.8 +
96.9 +remove_thy"EqSystem";
96.10 +use_thy"Knowledge/EqSystem";
96.11 +
96.12 +use_thy_only"Knowledge/EqSystem";
96.13 +
96.14 +remove_thy"Typefix";
96.15 +use_thy"Knowledge/Isac";
96.16 +*)
96.17 +
96.18 +EqSystem = Rational + Root +
96.19 +
96.20 +consts
96.21 +
96.22 + occur'_exactly'_in ::
96.23 + "[real list, real list, 'a] => bool" ("_ from'_ _ occur'_exactly'_in _")
96.24 +
96.25 + (*descriptions in the related problems*)
96.26 + solveForVars :: real list => toreall
96.27 + solution :: bool list => toreall
96.28 +
96.29 + (*the CAS-command, eg. "solveSystem [x+y=1,y=2] [x,y]"*)
96.30 + solveSystem :: "[bool list, real list] => bool list"
96.31 +
96.32 + (*Script-names*)
96.33 + SolveSystemScript :: "[bool list, real list, bool list] \
96.34 + \=> bool list"
96.35 + ("((Script SolveSystemScript (_ _ =))// (_))" 9)
96.36 +
96.37 +rules
96.38 +(*stated as axioms, todo: prove as theorems
96.39 + 'bdv' is a constant handled on the meta-level
96.40 + specifically as a 'bound variable' *)
96.41 +
96.42 + commute_0_equality "(0 = a) = (a = 0)"
96.43 +
96.44 + (*WN0510 see simliar rules 'isolate_' 'separate_' (by RL)
96.45 + [bdv_1,bdv_2,bdv_3,bdv_4] work also for 2 and 3 bdvs, ugly !*)
96.46 + separate_bdvs_add
96.47 + "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a |]\
96.48 + \ ==> (a + b = c) = (b = c + -1*a)"
96.49 + separate_bdvs0
96.50 + "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in b; Not (b=!=0) |]\
96.51 + \ ==> (a = b) = (a + -1*b = 0)"
96.52 + separate_bdvs_add1
96.53 + "[| some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in c |]\
96.54 + \ ==> (a = b + c) = (a + -1*c = b)"
96.55 + separate_bdvs_add2
96.56 + "[| Not (some_of [bdv_1,bdv_2,bdv_3,bdv_4] occur_in a) |]\
96.57 + \ ==> (a + b = c) = (b = -1*a + c)"
96.58 +
96.59 +
96.60 +
96.61 + separate_bdvs_mult
96.62 + "[| [] from_ [bdv_1,bdv_2,bdv_3,bdv_4] occur_exactly_in a; Not (a=!=0) |]\
96.63 + \ ==>(a * b = c) = (b = c / a)"
96.64 +
96.65 + (*requires rew_ord for termination, eg. ord_simplify_Integral;
96.66 + works for lists of any length, interestingly !?!*)
96.67 + order_system_NxN "[a,b] = [b,a]"
96.68 +
96.69 +(*
96.70 +remove_thy"EqSystem";
96.71 +use_thy_only"Knowledge/EqSystem";
96.72 +use_thy"Knowledge/EqSystem";
96.73 +use"Knowledge/EqSystem.ML";
96.74 + *)
96.75 +end
96.76 \ No newline at end of file
97.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
97.2 +++ b/src/Tools/isac/Knowledge/Equation.ML Wed Aug 25 16:20:07 2010 +0200
97.3 @@ -0,0 +1,85 @@
97.4 +(*.(c) by Richard Lang, 2003 .*)
97.5 +(* defines equation and univariate-equation
97.6 + created by: rlang
97.7 + date: 02.09
97.8 + changed by: rlang
97.9 + last change by: rlang
97.10 + date: 02.11.29
97.11 +*)
97.12 +
97.13 +(* use_thy_only"Knowledge/Equation";
97.14 + use_thy"Knowledge/Equation";
97.15 + use"Knowledge/Equation.ML";
97.16 + use"Equation.ML";
97.17 + *)
97.18 +
97.19 +theory' := overwritel (!theory', [("Equation.thy",Equation.thy)]);
97.20 +
97.21 +val univariate_equation_prls =
97.22 + append_rls "univariate_equation_prls" e_rls
97.23 + [Calc ("Tools.matches",eval_matches "")];
97.24 +ruleset' :=
97.25 +overwritelthy thy (!ruleset',
97.26 + [("univariate_equation_prls",
97.27 + prep_rls univariate_equation_prls)]);
97.28 +
97.29 +
97.30 +store_pbt
97.31 + (prep_pbt Equation.thy "pbl_equ" [] e_pblID
97.32 + (["equation"],
97.33 + [("#Given" ,["equality e_","solveFor v_"]),
97.34 + ("#Where" ,["matches (?a = ?b) e_"]),
97.35 + ("#Find" ,["solutions v_i_"])
97.36 + ],
97.37 + append_rls "equation_prls" e_rls
97.38 + [Calc ("Tools.matches",eval_matches "")],
97.39 + SOME "solve (e_::bool, v_)",
97.40 + []));
97.41 +
97.42 +store_pbt
97.43 + (prep_pbt Equation.thy "pbl_equ_univ" [] e_pblID
97.44 + (["univariate","equation"],
97.45 + [("#Given" ,["equality e_","solveFor v_"]),
97.46 + ("#Where" ,["matches (?a = ?b) e_"]),
97.47 + ("#Find" ,["solutions v_i_"])
97.48 + ],
97.49 + univariate_equation_prls,SOME "solve (e_::bool, v_)",[]));
97.50 +
97.51 +
97.52 +(*.function for handling the cas-input "solve (x+1=2, x)":
97.53 + make a model which is already in ptree-internal format.*)
97.54 +(* val (h,argl) = strip_comb (str2term "solve (x+1=2, x)");
97.55 + val (h,argl) = strip_comb ((term_of o the o (parse thy))
97.56 + "solveTest (x+1=2, x)");
97.57 + *)
97.58 +fun argl2dtss [Const ("Pair", _) $ eq $ bdv] =
97.59 + [((term_of o the o (parse thy)) "equality", [eq]),
97.60 + ((term_of o the o (parse thy)) "solveFor", [bdv]),
97.61 + ((term_of o the o (parse thy)) "solutions",
97.62 + [(term_of o the o (parse thy)) "L"])
97.63 + ]
97.64 + | argl2dtss _ = raise error "Equation.ML: wrong argument for argl2dtss";
97.65 +
97.66 +castab :=
97.67 +overwritel (!castab,
97.68 + [((term_of o the o (parse thy)) "solveTest",
97.69 + (("Test.thy", ["univariate","equation","test"], ["no_met"]),
97.70 + argl2dtss)),
97.71 + ((term_of o the o (parse thy)) "solve",
97.72 + (("Isac.thy", ["univariate","equation"], ["no_met"]),
97.73 + argl2dtss))
97.74 + ]);
97.75 +
97.76 +
97.77 +
97.78 +store_met
97.79 + (prep_met Equation.thy "met_equ" [] e_metID
97.80 + (["Equation"],
97.81 + [],
97.82 + {rew_ord'="tless_true", rls'=Erls, calc = [],
97.83 + srls = e_rls,
97.84 + prls=e_rls,
97.85 + crls = Atools_erls, nrls = e_rls},
97.86 +"empty_script"
97.87 +));
97.88 +
98.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
98.2 +++ b/src/Tools/isac/Knowledge/Equation.thy Wed Aug 25 16:20:07 2010 +0200
98.3 @@ -0,0 +1,29 @@
98.4 +(* equations and functions; functions NOT as lambda-terms
98.5 + author: Walther Neuper 2005, 2006
98.6 + (c) due to copyright terms
98.7 +
98.8 +remove_thy"Equation";
98.9 +use_thy"Knowledge/Equation";
98.10 +use_thy_only"Knowledge/Equation";
98.11 +
98.12 +remove_thy"Equation";
98.13 +use_thy"Knowledge/Isac";
98.14 +*)
98.15 +
98.16 +Equation = Atools +
98.17 +
98.18 +consts
98.19 +
98.20 + (*descriptions in the related problems TODOshift here from Descriptions.thy*)
98.21 + substitution :: bool => una
98.22 +
98.23 + (*the CAS-commands*)
98.24 + solve :: "[bool * 'a] => bool list" (* solve (x+1=2, x) *)
98.25 + solveTest :: "[bool * 'a] => bool list" (* for test collection *)
98.26 +
98.27 + (*Script-names*)
98.28 + Function2Equality :: "[bool, bool, bool] \
98.29 + \=> bool"
98.30 + ("((Script Function2Equality (_ _ =))// (_))" 9)
98.31 +
98.32 +end
98.33 \ No newline at end of file
99.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
99.2 +++ b/src/Tools/isac/Knowledge/InsSort.ML Wed Aug 25 16:20:07 2010 +0200
99.3 @@ -0,0 +1,77 @@
99.4 +(* 6.8.02 change to Isabelle2002 caused error -- thy excluded !
99.5 +
99.6 +Proving equations for primrec function(s) "InsSort.foldr" ...
99.7 +GC #1.17.30.54.345.21479: (10 ms)
99.8 +*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list"
99.9 +*** imposes additional sort constraints on the declared type of the constant
99.10 +*** The error(s) above occurred in definition "InsSort.ins.ins_list_def"
99.11 +*)
99.12 +
99.13 +(* tools for insertion sort
99.14 + use"Knowledge/InsSort.ML";
99.15 +*)
99.16 +
99.17 +(** interface isabelle -- isac **)
99.18 +
99.19 +theory' := (!theory') @ [("InsSort.thy",InsSort.thy)];
99.20 +
99.21 +(** rule set **)
99.22 +
99.23 +val ins_sort = prep_rls(
99.24 + Rls{preconds = [], rew_ord = ("tless_true",tless_true),
99.25 + rules = [Thm ("foldr_base",(*num_str*) foldr_base),
99.26 + Thm ("foldr_rec",foldr_rec),
99.27 + Thm ("ins_base",ins_base),
99.28 + Thm ("ins_rec",ins_rec),
99.29 + Thm ("sort_def",sort_def),
99.30 +
99.31 + Calc ("op <",eval_equ "#less_"),
99.32 + Thm ("if_True", if_True),
99.33 + Thm ("if_False", if_False)
99.34 + ],
99.35 + scr = Script ((term_of o the o (parse thy))
99.36 + "empty_script")
99.37 + }:rls);
99.38 +
99.39 +(** problem type **)
99.40 +
99.41 +store_pbt
99.42 + (prep_pbt InsSort.thy
99.43 + (["functional"]:pblID,
99.44 + [("#Given" ,["unsorted u_"]),
99.45 + ("#Find" ,["sorted s_"])
99.46 + ],
99.47 + []));
99.48 +
99.49 +store_pbt
99.50 + (prep_pbt InsSort.thy
99.51 + (["inssort","functional"]:pblID,
99.52 + [("#Given" ,["unsorted u_"]),
99.53 + ("#Find" ,["sorted s_"])
99.54 + ],
99.55 + []));
99.56 +
99.57 +(** method,
99.58 + todo: implementation needs extra object-level lists **)
99.59 +
99.60 +store_met
99.61 + (prep_met Diff.thy
99.62 + (["InsSort"],
99.63 + [],
99.64 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
99.65 + crls = Atools_rls, nrls=norm_Rational
99.66 + (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
99.67 +store_met
99.68 + (prep_met InsSort.thy (*test-version for [#1,#3,#2] only: see *.sml*)
99.69 + (["InsSort""sort"]:metID,
99.70 + [("#Given" ,["unsorted u_"]),
99.71 + ("#Find" ,["sorted s_"])
99.72 + ],
99.73 + {rew_ord'="tless_true",rls'=eval_rls,calc = [], srls = e_rls, prls=e_rls,
99.74 + crls = eval_rls, nrls=norm_Rational(*,asm_rls=[],asm_thm=[]*)},
99.75 + "Script Sort (u_::'a list) = (Rewrite_Set ins_sort False) u_"
99.76 + ));
99.77 +
99.78 +ruleset' := overwritelthy thy (!ruleset',
99.79 + [(*("ins_sort",ins_sort) overwrites a Isa fun!!*)
99.80 + ]:(string * rls) list);
100.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
100.2 +++ b/src/Tools/isac/Knowledge/InsSort.sml Wed Aug 25 16:20:07 2010 +0200
100.3 @@ -0,0 +1,395 @@
100.4 +
100.5 +
100.6 +(*-------------------------from InsSort.thy 8.3.01----------------------*)
100.7 +(*List.thy:
100.8 + foldl :: [['b,'a] => 'b, 'b, 'a list] => 'b
100.9 +primrec
100.10 + foldl_Nil "foldl f a [] = a"
100.11 + foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs"
100.12 +
100.13 +above in sml:
100.14 +fun foldr f [] a = a
100.15 + | foldr f (x::xs) a = foldr f xs (f a x);
100.16 +(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*)
100.17 +fun ins [] a = [a]
100.18 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.19 +fun sort xs = foldr ins xs [];
100.20 +*)
100.21 +(*-------------------------from InsSort.thy 8.3.01----------------------*)
100.22 +
100.23 +
100.24 +(*-------------------------from InsSort.ML 8.3.01----------------------*)
100.25 +
100.26 +theory' := (!theory') @ [("InsSort.thy",InsSort.thy)];
100.27 +
100.28 +val ins_sort =
100.29 + Rls{preconds = [], rew_ord = ("tless_true",tless_true),
100.30 + rules = [Thm ("foldr_base",(*num_str*) foldr_base),
100.31 + Thm ("foldr_rec",foldr_rec),
100.32 + Thm ("ins_base",ins_base),
100.33 + Thm ("ins_rec",ins_rec),
100.34 + Thm ("sort_def",sort_def),
100.35 +
100.36 + Calc ("op <",eval_equ "#less_"),
100.37 + Thm ("if_True", if_True),
100.38 + Thm ("if_False", if_False)
100.39 + ],
100.40 + scr = Script ((term_of o the o (parse thy))
100.41 + "empty_script")
100.42 + }:rls;
100.43 +
100.44 +
100.45 +
100.46 +
100.47 +(*
100.48 +> get_pbt ["Script.thy","squareroot","univariate","equation"];
100.49 +> get_met ("Script.thy","max_on_interval_by_calculus");
100.50 +*)
100.51 +pbltypes:= (!pbltypes) @
100.52 +[
100.53 + prep_pbt InsSort.thy
100.54 + (["InsSort.thy","inssort"]:pblID,
100.55 + [("#Given" ,"unsorted u_"),
100.56 + ("#Find" ,"sorted s_")
100.57 + ])
100.58 +];
100.59 +
100.60 +methods:= (!methods) @
100.61 +[
100.62 +(*, -------17.6.00,
100.63 + (("InsSort.thy","inssort"):metID,
100.64 + {ppc = prep_met
100.65 + [("#Given" ,"unsorted u_"),
100.66 + ("#Find" ,"sorted s_")
100.67 + ],
100.68 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
100.69 + scr=Script (((inst_abs (assoc_thm "InsSort.thy"))
100.70 + o term_of o the o (parse thy)) (*for [#1,#3,#2] only*)
100.71 + "Script Ins_sort (u_::'a list) = \
100.72 + \ (let u_ = Rewrite sort_def False u_; \
100.73 + \ u_ = Rewrite foldr_rec False u_; \
100.74 + \ u_ = Rewrite ins_base False u_; \
100.75 + \ u_ = Rewrite foldr_rec False u_; \
100.76 + \ u_ = Rewrite ins_rec False u_; \
100.77 + \ u_ = Calculate le u_; \
100.78 + \ u_ = Rewrite if_True False u_; \
100.79 + \ u_ = Rewrite ins_base False u_; \
100.80 + \ u_ = Rewrite foldr_rec False u_; \
100.81 + \ u_ = Rewrite ins_rec False u_; \
100.82 + \ u_ = Calculate le u_; \
100.83 + \ u_ = Rewrite if_True False u_; \
100.84 + \ u_ = Rewrite ins_rec False u_; \
100.85 + \ u_ = Calculate le u_; \
100.86 + \ u_ = Rewrite if_False False u_; \
100.87 + \ u_ = Rewrite foldr_base False u_ \
100.88 + \ in u_)")
100.89 + } : met),
100.90 +
100.91 + (("InsSort.thy","sort"):metID,
100.92 + {ppc = prep_met
100.93 + [("#Given" ,"unsorted u_"),
100.94 + ("#Find" ,"sorted s_")
100.95 + ],
100.96 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
100.97 + scr=Script ((inst_abs o term_of o the o (parse thy))
100.98 + "Script Sort (u_::'a list) = \
100.99 + \ Rewrite_Set ins_sort False u_")
100.100 + } : met)
100.101 +------- *)
100.102 +(*,
100.103 +
100.104 + (("",""):metID,
100.105 + {ppc = prep_met
100.106 + [("#Given" ,""),
100.107 + ("#Find" ,""),
100.108 + ("#Relate","")
100.109 + ],
100.110 + rew_ord'="tless_true",rls'="eval_rls",asm_rls=[],asm_thm=[],
100.111 + scr=EmptyScr} : met),
100.112 +*)
100.113 +];
100.114 +(*-------------------------from InsSort.ML 8.3.01----------------------*)
100.115 +
100.116 +
100.117 +(*------------------------- nipkow ----------------------*)
100.118 +consts
100.119 + sort :: 'a list => 'a list
100.120 + ins :: ['a,'a list] => 'a list
100.121 +(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a
100.122 +*)
100.123 +rules
100.124 + ins_base "ins e [] = [e]"
100.125 + ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))"
100.126 +
100.127 +rules
100.128 + sort_def "sort ls = (foldl ins ls [])"
100.129 +end
100.130 +
100.131 +
100.132 +(** swp: ..L **)
100.133 +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
100.134 +fun foldL f [] e = e
100.135 + | foldL f (l::ls) e = f(l,foldL f ls e);
100.136 +
100.137 +(* fn : int * int list -> int list *)
100.138 +fun insL (e,[]) = [e]
100.139 + | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls);
100.140 +
100.141 +fun sortL ls = foldL insL ls [];
100.142 +
100.143 +sortL [2,3,1]; (* [1,2,3] *)
100.144 +
100.145 +
100.146 +(** swp, curried: ..LC **)
100.147 +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
100.148 +fun foldLC f [] e = e
100.149 + | foldLC f (x::xs) e = f x (foldLC f xs e);
100.150 +
100.151 +(* fn : int * int list -> int list *)
100.152 +fun insLC e [] = [e]
100.153 + | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls);
100.154 +
100.155 +fun sortLC ls = foldLC insLC ls [];
100.156 +
100.157 +sortLC [2,3,1]; (* [1,2,3] *)
100.158 +
100.159 +
100.160 +(** sml110: ..l **)
100.161 +(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *)
100.162 +foldl;
100.163 +(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!!
100.164 +fun foldl f e [] = e
100.165 + | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0
100.166 +
100.167 +foldl op+ (0,[100,11,1]);
100.168 +val it = 0 : int ... GEHT NICHT !!! *)
100.169 +
100.170 +fun insl (e,[]) = [e]
100.171 + | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls);
100.172 +
100.173 +fun sortl ls = foldl insl [] ls;
100.174 +
100.175 +sortl [2,3,1]; (* [1,2,3] *)
100.176 +
100.177 +
100.178 +(** sml110, curried: ..lC **)
100.179 +(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *)
100.180 +fun foldlC f e [] = e
100.181 + | foldlC f e (l::ls) = f e (foldlC f e ls);
100.182 +
100.183 +(* fn : int -> int list -> int list *)
100.184 +fun inslC e [] = [e]
100.185 + | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls);
100.186 +
100.187 +fun sortlC ls = foldlC inslC [] ls;
100.188 +
100.189 +sortlC [2,3,1];
100.190 +
100.191 +(*--- 15.6.00 ---*)
100.192 +
100.193 +
100.194 +fun Foldl f a [] = a
100.195 + | Foldl f a (x::xs) = Foldl f (f a x) xs;
100.196 +(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*)
100.197 +
100.198 +fun add a b = a+b:int;
100.199 +
100.200 +Foldl add 0 [1,2,3];
100.201 +
100.202 +fun ins0 a [] = [a]
100.203 + | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs);
100.204 +(*val ins = fn : int -> int list -> int list*)
100.205 +
100.206 +fun ins [] a = [a]
100.207 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.208 +(*val ins = fn : int -> int list -> int list*)
100.209 +
100.210 +ins 3 [1,2,4];
100.211 +
100.212 +fun sort xs = Foldl ins0 xs [];
100.213 +(*operator domain: int -> int list -> int
100.214 + operand: int -> int list -> int list
100.215 + in expression:
100.216 + Foldl ins
100.217 + *)
100.218 +fun sort xs = Foldl ins xs [];
100.219 +
100.220 +
100.221 +
100.222 +(*--- 17.6.00 ---*)
100.223 +
100.224 +
100.225 +fun foldr f [] a = a
100.226 + | foldr f (x::xs) a = foldr f xs (f a x);
100.227 +(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*)
100.228 +
100.229 +fun add a b = a+b:int;
100.230 +
100.231 +fold add [1,2,3] 0;
100.232 +
100.233 +fun ins [] a = [a]
100.234 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.235 +(*val ins = fn : int list -> int -> int list*)
100.236 +
100.237 +ins [1,2,4] 3;
100.238 +
100.239 +fun sort xs = foldr ins xs [];
100.240 +
100.241 +sort [3,1,4,2];
100.242 +
100.243 +
100.244 +
100.245 +(*--- 17.6.00 II ---*)
100.246 +
100.247 +fun foldl f a [] = a
100.248 + | foldl f a (x::xs) = foldl f (f a x) xs;
100.249 +
100.250 +fun ins [] a = [a]
100.251 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.252 +
100.253 +fun sort xs = foldl ins xs [];
100.254 +
100.255 +sort [3,1,4,2];
100.256 +(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*)
100.257 +
100.258 +(*------------------------- nipkow ----------------------*)
100.259 +consts
100.260 + sort :: 'a list => 'a list
100.261 + ins :: ['a,'a list] => 'a list
100.262 +(*foldl :: [['a,'b] => 'a, 'a, 'b list] => 'a
100.263 +*)
100.264 +rules
100.265 + ins_base "ins e [] = [e]"
100.266 + ins_rec "ins e (l#ls) = (if l < e then l#(ins e ls) else e#(l#ls))"
100.267 +
100.268 +rules
100.269 + sort_def "sort ls = (foldl ins ls [])"
100.270 +end
100.271 +
100.272 +
100.273 +(** swp: ..L **)
100.274 +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
100.275 +fun foldL f [] e = e
100.276 + | foldL f (l::ls) e = f(l,foldL f ls e);
100.277 +
100.278 +(* fn : int * int list -> int list *)
100.279 +fun insL (e,[]) = [e]
100.280 + | insL (e,l::ls) = if l < e then l::(insL(e,ls)) else e::(l::ls);
100.281 +
100.282 +fun sortL ls = foldL insL ls [];
100.283 +
100.284 +sortL [2,3,1]; (* [1,2,3] *)
100.285 +
100.286 +
100.287 +(** swp, curried: ..LC **)
100.288 +(* fn : ('a * 'b -> 'b) -> 'a list -> 'b -> 'b *)
100.289 +fun foldLC f [] e = e
100.290 + | foldLC f (x::xs) e = f x (foldLC f xs e);
100.291 +
100.292 +(* fn : int * int list -> int list *)
100.293 +fun insLC e [] = [e]
100.294 + | insLC e (l::ls) = if l < e then l::(insLC e ls) else e::(l::ls);
100.295 +
100.296 +fun sortLC ls = foldLC insLC ls [];
100.297 +
100.298 +sortLC [2,3,1]; (* [1,2,3] *)
100.299 +
100.300 +
100.301 +(** sml110: ..l **)
100.302 +(* fn : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b *)
100.303 +foldl;
100.304 +(* fn : ('a * 'a -> 'a) -> 'a * 'b list -> 'a : ANDERS !!!
100.305 +fun foldl f e [] = e
100.306 + | foldl f e (l::ls) = f e (foldl f (e,ls)); 0+...+0+0
100.307 +
100.308 +foldl op+ (0,[100,11,1]);
100.309 +val it = 0 : int ... GEHT NICHT !!! *)
100.310 +
100.311 +fun insl (e,[]) = [e]
100.312 + | insl (e,l::ls) = if l < e then l::(insl(e,ls)) else e::(l::ls);
100.313 +
100.314 +fun sortl ls = foldl insl [] ls;
100.315 +
100.316 +sortl [2,3,1]; (* [1,2,3] *)
100.317 +
100.318 +
100.319 +(** sml110, curried: ..lC **)
100.320 +(* fn : ('a -> 'a -> 'a) -> 'a -> 'b list -> 'a *)
100.321 +fun foldlC f e [] = e
100.322 + | foldlC f e (l::ls) = f e (foldlC f e ls);
100.323 +
100.324 +(* fn : int -> int list -> int list *)
100.325 +fun inslC e [] = [e]
100.326 + | inslC e (l::ls) = if l < e then l::(inslC e ls) else e::(l::ls);
100.327 +
100.328 +fun sortlC ls = foldlC inslC [] ls;
100.329 +
100.330 +sortlC [2,3,1];
100.331 +
100.332 +(*--- 15.6.00 ---*)
100.333 +
100.334 +
100.335 +fun Foldl f a [] = a
100.336 + | Foldl f a (x::xs) = Foldl f (f a x) xs;
100.337 +(*val Foldl = fn : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a*)
100.338 +
100.339 +fun add a b = a+b:int;
100.340 +
100.341 +Foldl add 0 [1,2,3];
100.342 +
100.343 +fun ins0 a [] = [a]
100.344 + | ins0 a (x::xs) = if x < a then x::(ins0 a xs) else a::(x::xs);
100.345 +(*val ins = fn : int -> int list -> int list*)
100.346 +
100.347 +fun ins [] a = [a]
100.348 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.349 +(*val ins = fn : int -> int list -> int list*)
100.350 +
100.351 +ins 3 [1,2,4];
100.352 +
100.353 +fun sort xs = Foldl ins0 xs [];
100.354 +(*operator domain: int -> int list -> int
100.355 + operand: int -> int list -> int list
100.356 + in expression:
100.357 + Foldl ins
100.358 + *)
100.359 +fun sort xs = Foldl ins xs [];
100.360 +
100.361 +
100.362 +
100.363 +(*--- 17.6.00 ---*)
100.364 +
100.365 +
100.366 +fun foldr f [] a = a
100.367 + | foldr f (x::xs) a = foldr f xs (f a x);
100.368 +(*val fold = fn : ('a -> 'b -> 'a) -> 'b list -> 'a -> 'a*)
100.369 +
100.370 +fun add a b = a+b:int;
100.371 +
100.372 +fold add [1,2,3] 0;
100.373 +
100.374 +fun ins [] a = [a]
100.375 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.376 +(*val ins = fn : int list -> int -> int list*)
100.377 +
100.378 +ins [1,2,4] 3;
100.379 +
100.380 +fun sort xs = foldr ins xs [];
100.381 +
100.382 +sort [3,1,4,2];
100.383 +
100.384 +
100.385 +
100.386 +(*--- 17.6.00 II ---*)
100.387 +
100.388 +fun foldl f a [] = a
100.389 + | foldl f a (x::xs) = foldl f (f a x) xs;
100.390 +
100.391 +fun ins [] a = [a]
100.392 + | ins (x::xs) a = if x < a then x::(ins xs a) else a::(x::xs);
100.393 +
100.394 +fun sort xs = foldl ins xs [];
100.395 +
100.396 +sort [3,1,4,2];
100.397 +(*val it = [3,1,4,2] : int list !?!?!?!?!?!?!?!?!?!?!?!?!?!?!?*)
100.398 +(*------------------------- nipkow ----------------------*)
101.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
101.2 +++ b/src/Tools/isac/Knowledge/InsSort.thy Wed Aug 25 16:20:07 2010 +0200
101.3 @@ -0,0 +1,63 @@
101.4 +(* 6.8.02 change to Isabelle2002 caused error -- thy excluded !
101.5 +
101.6 +Proving equations for primrec function(s) "InsSort.foldr" ...
101.7 +GC #1.17.30.54.345.21479: (10 ms)
101.8 +*** Definition of InsSort.ins :: "['a::ord list, 'a::ord] => 'a::ord list"
101.9 +*** imposes additional sort constraints on the declared type of the constant
101.10 +*** The error(s) above occurred in definition "InsSort.ins.ins_list_def (@@@)"
101.11 +*)
101.12 +
101.13 +(* insertion sort, would need lists different from script-lists WN.11.00
101.14 +WN.7.5.03: -"- started with someList :: 'a list => unl, fun dest_list
101.15 +WN.8.5.03: error (@@@) remained with outcommenting foldr ?!?
101.16 +
101.17 + use_thy_only"Knowledge/InsSort";
101.18 +
101.19 +*)
101.20 +
101.21 +InsSort = Script +
101.22 +
101.23 +consts
101.24 +
101.25 +(*foldr :: [['a,'b] => 'a, 'b list, 'a] => 'a
101.26 +WN.8.5.03: already defined in Isabelle2002 (instantiated by Typefix):
101.27 + "[[real, real] => real, real list, real] => real") : term
101.28 +
101.29 + val t = str2term "foldr";
101.30 +val t =
101.31 + Const
101.32 + ("List.foldr",
101.33 + "[[RealDef.real, RealDef.real] => RealDef.real, RealDef.real List.list,
101.34 + RealDef.real] => RealDef.real") : term
101.35 + *)
101.36 + ins :: ['a list,'a] => 'a list
101.37 + sort :: 'a list => 'a list
101.38 +
101.39 +(*descriptions, script-id*)
101.40 + unsorted :: 'a list => unl
101.41 + sorted :: 'a list => unl
101.42 +
101.43 +(*subproblem and script-name*)
101.44 + Ins'_sort :: "['a list, \
101.45 + \ 'a list] => 'a list"
101.46 + ("((Script Ins'_sort (_ =))// \
101.47 + \ (_))" 9)
101.48 + Sort :: "['a list, \
101.49 + \ 'a list] => 'a list"
101.50 + ("((Script Sort (_ =))// \
101.51 + \ (_))" 9)
101.52 +
101.53 +(*primrec
101.54 + foldr_base "foldr f [] a = a"
101.55 + foldr_rec "foldr f (x#xs) a = foldr f xs (f a x)"
101.56 +*)
101.57 +
101.58 +rules
101.59 +
101.60 +(*primrec .. outcommented analoguous to ListC.thy*)
101.61 + ins_base "ins [] a = [a]"
101.62 + ins_rec "ins (x#xs) a = (if x < a then x#(ins xs a) else a#(x#xs))"
101.63 +
101.64 + sort_def "sort ls = foldr ins ls []"
101.65 +
101.66 +end
102.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
102.2 +++ b/src/Tools/isac/Knowledge/Integrate.ML Wed Aug 25 16:20:07 2010 +0200
102.3 @@ -0,0 +1,357 @@
102.4 +(* tools for integration over the reals
102.5 + author: Walther Neuper 050905, 08:51
102.6 + (c) due to copyright terms
102.7 +
102.8 +use"Knowledge/Integrate.ML";
102.9 +use"Integrate.ML";
102.10 +
102.11 +remove_thy"Integrate";
102.12 +use_thy"Knowledge/Isac";
102.13 +*)
102.14 +
102.15 +(** interface isabelle -- isac **)
102.16 +
102.17 +theory' := overwritel (!theory', [("Integrate.thy",Integrate.thy)]);
102.18 +
102.19 +(** eval functions **)
102.20 +
102.21 +val c = Free ("c", HOLogic.realT);
102.22 +(*.create a new unique variable 'c..' in a term; for use by Calc in a rls;
102.23 + an alternative to do this would be '(Try (Calculate new_c_) (new_c es__))'
102.24 + in the script; this will be possible if currying doesnt take the value
102.25 + from a variable, but the value '(new_c es__)' itself.*)
102.26 +fun new_c term =
102.27 + let fun selc var =
102.28 + case (explode o id_of) var of
102.29 + "c"::[] => true
102.30 + | "c"::"_"::is => (case (int_of_str o implode) is of
102.31 + SOME _ => true
102.32 + | NONE => false)
102.33 + | _ => false;
102.34 + fun get_coeff c = case (explode o id_of) c of
102.35 + "c"::"_"::is => (the o int_of_str o implode) is
102.36 + | _ => 0;
102.37 + val cs = filter selc (vars term);
102.38 + in
102.39 + case cs of
102.40 + [] => c
102.41 + | [c] => Free ("c_2", HOLogic.realT)
102.42 + | cs =>
102.43 + let val max_coeff = maxl (map get_coeff cs)
102.44 + in Free ("c_"^string_of_int (max_coeff + 1), HOLogic.realT) end
102.45 + end;
102.46 +
102.47 +(*WN080222
102.48 +(*("new_c", ("Integrate.new'_c", eval_new_c "#new_c_"))*)
102.49 +fun eval_new_c _ _ (p as (Const ("Integrate.new'_c",_) $ t)) _ =
102.50 + SOME ((term2str p) ^ " = " ^ term2str (new_c p),
102.51 + Trueprop $ (mk_equality (p, new_c p)))
102.52 + | eval_new_c _ _ _ _ = NONE;
102.53 +*)
102.54 +
102.55 +(*WN080222:*)
102.56 +(*("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "#add_new_c_"))
102.57 + add a new c to a term or a fun-equation;
102.58 + this is _not in_ the term, because only applied to _whole_ term*)
102.59 +fun eval_add_new_c (_:string) "Integrate.add'_new'_c" p (_:theory) =
102.60 + let val p' = case p of
102.61 + Const ("op =", T) $ lh $ rh =>
102.62 + Const ("op =", T) $ lh $ mk_add rh (new_c rh)
102.63 + | p => mk_add p (new_c p)
102.64 + in SOME ((term2str p) ^ " = " ^ term2str p',
102.65 + Trueprop $ (mk_equality (p, p')))
102.66 + end
102.67 + | eval_add_new_c _ _ _ _ = NONE;
102.68 +
102.69 +
102.70 +(*("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_x_"))*)
102.71 +fun eval_is_f_x _ _(p as (Const ("Integrate.is'_f'_x", _)
102.72 + $ arg)) _ =
102.73 + if is_f_x arg
102.74 + then SOME ((term2str p) ^ " = True",
102.75 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
102.76 + else SOME ((term2str p) ^ " = False",
102.77 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
102.78 + | eval_is_f_x _ _ _ _ = NONE;
102.79 +
102.80 +calclist':= overwritel (!calclist',
102.81 + [(*("new_c", ("Integrate.new'_c", eval_new_c "new_c_")),*)
102.82 + ("add_new_c", ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_")),
102.83 + ("is_f_x", ("Integrate.is'_f'_x", eval_is_f_x "is_f_idextifier_"))
102.84 + ]);
102.85 +
102.86 +
102.87 +(** rulesets **)
102.88 +
102.89 +(*.rulesets for integration.*)
102.90 +val integration_rules =
102.91 + Rls {id="integration_rules", preconds = [],
102.92 + rew_ord = ("termlessI",termlessI),
102.93 + erls = Rls {id="conditions_in_integration_rules",
102.94 + preconds = [],
102.95 + rew_ord = ("termlessI",termlessI),
102.96 + erls = Erls,
102.97 + srls = Erls, calc = [],
102.98 + rules = [(*for rewriting conditions in Thm's*)
102.99 + Calc ("Atools.occurs'_in",
102.100 + eval_occurs_in "#occurs_in_"),
102.101 + Thm ("not_true",num_str not_true),
102.102 + Thm ("not_false",not_false)
102.103 + ],
102.104 + scr = EmptyScr},
102.105 + srls = Erls, calc = [],
102.106 + rules = [
102.107 + Thm ("integral_const",num_str integral_const),
102.108 + Thm ("integral_var",num_str integral_var),
102.109 + Thm ("integral_add",num_str integral_add),
102.110 + Thm ("integral_mult",num_str integral_mult),
102.111 + Thm ("integral_pow",num_str integral_pow),
102.112 + Calc ("op +", eval_binop "#add_")(*for n+1*)
102.113 + ],
102.114 + scr = EmptyScr};
102.115 +val add_new_c =
102.116 + Seq {id="add_new_c", preconds = [],
102.117 + rew_ord = ("termlessI",termlessI),
102.118 + erls = Rls {id="conditions_in_add_new_c",
102.119 + preconds = [],
102.120 + rew_ord = ("termlessI",termlessI),
102.121 + erls = Erls,
102.122 + srls = Erls, calc = [],
102.123 + rules = [Calc ("Tools.matches", eval_matches""),
102.124 + Calc ("Integrate.is'_f'_x",
102.125 + eval_is_f_x "is_f_x_"),
102.126 + Thm ("not_true",num_str not_true),
102.127 + Thm ("not_false",num_str not_false)
102.128 + ],
102.129 + scr = EmptyScr},
102.130 + srls = Erls, calc = [],
102.131 + rules = [ (*Thm ("call_for_new_c", num_str call_for_new_c),*)
102.132 + Cal1 ("Integrate.add'_new'_c", eval_add_new_c "new_c_")
102.133 + ],
102.134 + scr = EmptyScr};
102.135 +
102.136 +(*.rulesets for simplifying Integrals.*)
102.137 +
102.138 +(*.for simplify_Integral adapted from 'norm_Rational_rls'.*)
102.139 +val norm_Rational_rls_noadd_fractions =
102.140 +Rls {id = "norm_Rational_rls_noadd_fractions", preconds = [],
102.141 + rew_ord = ("dummy_ord",dummy_ord),
102.142 + erls = norm_rat_erls, srls = Erls, calc = [],
102.143 + rules = [(*Rls_ common_nominator_p_rls,!!!*)
102.144 + Rls_ (*rat_mult_div_pow original corrected WN051028*)
102.145 + (Rls {id = "rat_mult_div_pow", preconds = [],
102.146 + rew_ord = ("dummy_ord",dummy_ord),
102.147 + erls = (*FIXME.WN051028 e_rls,*)
102.148 + append_rls "e_rls-is_polyexp" e_rls
102.149 + [Calc ("Poly.is'_polyexp",
102.150 + eval_is_polyexp "")],
102.151 + srls = Erls, calc = [],
102.152 + rules = [Thm ("rat_mult",num_str rat_mult),
102.153 + (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
102.154 + Thm ("rat_mult_poly_l",num_str rat_mult_poly_l),
102.155 + (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*)
102.156 + Thm ("rat_mult_poly_r",num_str rat_mult_poly_r),
102.157 + (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*)
102.158 +
102.159 + Thm ("real_divide_divide1_mg", real_divide_divide1_mg),
102.160 + (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*)
102.161 + Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
102.162 + (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
102.163 + Thm ("real_divide_divide2_eq", real_divide_divide2_eq),
102.164 + (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
102.165 + Calc ("HOL.divide" ,eval_cancel "#divide_"),
102.166 +
102.167 + Thm ("rat_power", num_str rat_power)
102.168 + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
102.169 + ],
102.170 + scr = Script ((term_of o the o (parse thy)) "empty_script")
102.171 + }),
102.172 + Rls_ make_rat_poly_with_parentheses,
102.173 + Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*)
102.174 + Rls_ rat_reduce_1
102.175 + ],
102.176 + scr = Script ((term_of o the o (parse thy)) "empty_script")
102.177 + }:rls;
102.178 +
102.179 +(*.for simplify_Integral adapted from 'norm_Rational'.*)
102.180 +val norm_Rational_noadd_fractions =
102.181 + Seq {id = "norm_Rational_noadd_fractions", preconds = [],
102.182 + rew_ord = ("dummy_ord",dummy_ord),
102.183 + erls = norm_rat_erls, srls = Erls, calc = [],
102.184 + rules = [Rls_ discard_minus_,
102.185 + Rls_ rat_mult_poly,(* removes double fractions like a/b/c *)
102.186 + Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*)
102.187 + Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*)
102.188 + Rls_ norm_Rational_rls_noadd_fractions,(* the main rls (#) *)
102.189 + Rls_ discard_parentheses_ (* mult only *)
102.190 + ],
102.191 + scr = Script ((term_of o the o (parse thy)) "empty_script")
102.192 + }:rls;
102.193 +
102.194 +(*.simplify terms before and after Integration such that
102.195 + ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO
102.196 + common denominator as done by norm_Rational or make_ratpoly_in.
102.197 + This is a copy from 'make_ratpoly_in' with respective reduction of rules and
102.198 + *1* expand the term, ie. distribute * and / over +
102.199 +.*)
102.200 +val separate_bdv2 =
102.201 + append_rls "separate_bdv2"
102.202 + collect_bdv
102.203 + [Thm ("separate_bdv", num_str separate_bdv),
102.204 + (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*)
102.205 + Thm ("separate_bdv_n", num_str separate_bdv_n),
102.206 + Thm ("separate_1_bdv", num_str separate_1_bdv),
102.207 + (*"?bdv / ?b = (1 / ?b) * ?bdv"*)
102.208 + Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*,
102.209 + (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*)
102.210 + *****Thm ("real_add_divide_distrib",
102.211 + *****num_str real_add_divide_distrib)
102.212 + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)----------*)
102.213 + ];
102.214 +val simplify_Integral =
102.215 + Seq {id = "simplify_Integral", preconds = []:term list,
102.216 + rew_ord = ("dummy_ord", dummy_ord),
102.217 + erls = Atools_erls, srls = Erls,
102.218 + calc = [], (*asm_thm = [],*)
102.219 + rules = [Thm ("real_add_mult_distrib",num_str real_add_mult_distrib),
102.220 + (*"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"*)
102.221 + Thm ("real_add_divide_distrib",num_str real_add_divide_distrib),
102.222 + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)
102.223 + (*^^^^^ *1* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*)
102.224 + Rls_ norm_Rational_noadd_fractions,
102.225 + Rls_ order_add_mult_in,
102.226 + Rls_ discard_parentheses,
102.227 + (*Rls_ collect_bdv, from make_polynomial_in*)
102.228 + Rls_ separate_bdv2,
102.229 + Calc ("HOL.divide" ,eval_cancel "#divide_")
102.230 + ],
102.231 + scr = EmptyScr}:rls;
102.232 +
102.233 +
102.234 +(*simplify terms before and after Integration such that
102.235 + ..a.x^2/2 + b.x^3/3.. is made to ..a/2.x^2 + b/3.x^3.. (and NO
102.236 + common denominator as done by norm_Rational or make_ratpoly_in.
102.237 + This is a copy from 'make_polynomial_in' with insertions from
102.238 + 'make_ratpoly_in'
102.239 +THIS IS KEPT FOR COMPARISON ............................................
102.240 +* val simplify_Integral = prep_rls(
102.241 +* Seq {id = "", preconds = []:term list,
102.242 +* rew_ord = ("dummy_ord", dummy_ord),
102.243 +* erls = Atools_erls, srls = Erls,
102.244 +* calc = [], (*asm_thm = [],*)
102.245 +* rules = [Rls_ expand_poly,
102.246 +* Rls_ order_add_mult_in,
102.247 +* Rls_ simplify_power,
102.248 +* Rls_ collect_numerals,
102.249 +* Rls_ reduce_012,
102.250 +* Thm ("realpow_oneI",num_str realpow_oneI),
102.251 +* Rls_ discard_parentheses,
102.252 +* Rls_ collect_bdv,
102.253 +* (*below inserted from 'make_ratpoly_in'*)
102.254 +* Rls_ (append_rls "separate_bdv"
102.255 +* collect_bdv
102.256 +* [Thm ("separate_bdv", num_str separate_bdv),
102.257 +* (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*)
102.258 +* Thm ("separate_bdv_n", num_str separate_bdv_n),
102.259 +* Thm ("separate_1_bdv", num_str separate_1_bdv),
102.260 +* (*"?bdv / ?b = (1 / ?b) * ?bdv"*)
102.261 +* Thm ("separate_1_bdv_n", num_str separate_1_bdv_n)(*,
102.262 +* (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*)
102.263 +* Thm ("real_add_divide_distrib",
102.264 +* num_str real_add_divide_distrib)
102.265 +* (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"*)*)
102.266 +* ]),
102.267 +* Calc ("HOL.divide" ,eval_cancel "#divide_")
102.268 +* ],
102.269 +* scr = EmptyScr
102.270 +* }:rls);
102.271 +.......................................................................*)
102.272 +
102.273 +val integration =
102.274 + Seq {id="integration", preconds = [],
102.275 + rew_ord = ("termlessI",termlessI),
102.276 + erls = Rls {id="conditions_in_integration",
102.277 + preconds = [],
102.278 + rew_ord = ("termlessI",termlessI),
102.279 + erls = Erls,
102.280 + srls = Erls, calc = [],
102.281 + rules = [],
102.282 + scr = EmptyScr},
102.283 + srls = Erls, calc = [],
102.284 + rules = [ Rls_ integration_rules,
102.285 + Rls_ add_new_c,
102.286 + Rls_ simplify_Integral
102.287 + ],
102.288 + scr = EmptyScr};
102.289 +ruleset' :=
102.290 +overwritelthy thy (!ruleset',
102.291 + [("integration_rules", prep_rls integration_rules),
102.292 + ("add_new_c", prep_rls add_new_c),
102.293 + ("simplify_Integral", prep_rls simplify_Integral),
102.294 + ("integration", prep_rls integration),
102.295 + ("separate_bdv2", separate_bdv2),
102.296 + ("norm_Rational_noadd_fractions", norm_Rational_noadd_fractions),
102.297 + ("norm_Rational_rls_noadd_fractions",
102.298 + norm_Rational_rls_noadd_fractions)
102.299 + ]);
102.300 +
102.301 +(** problems **)
102.302 +
102.303 +store_pbt
102.304 + (prep_pbt Integrate.thy "pbl_fun_integ" [] e_pblID
102.305 + (["integrate","function"],
102.306 + [("#Given" ,["functionTerm f_", "integrateBy v_"]),
102.307 + ("#Find" ,["antiDerivative F_"])
102.308 + ],
102.309 + append_rls "e_rls" e_rls [(*for preds in where_*)],
102.310 + SOME "Integrate (f_, v_)",
102.311 + [["diff","integration"]]));
102.312 +
102.313 +(*here "named" is used differently from Differentiation"*)
102.314 +store_pbt
102.315 + (prep_pbt Integrate.thy "pbl_fun_integ_nam" [] e_pblID
102.316 + (["named","integrate","function"],
102.317 + [("#Given" ,["functionTerm f_", "integrateBy v_"]),
102.318 + ("#Find" ,["antiDerivativeName F_"])
102.319 + ],
102.320 + append_rls "e_rls" e_rls [(*for preds in where_*)],
102.321 + SOME "Integrate (f_, v_)",
102.322 + [["diff","integration","named"]]));
102.323 +
102.324 +(** methods **)
102.325 +
102.326 +store_met
102.327 + (prep_met Integrate.thy "met_diffint" [] e_metID
102.328 + (["diff","integration"],
102.329 + [("#Given" ,["functionTerm f_", "integrateBy v_"]),
102.330 + ("#Find" ,["antiDerivative F_"])
102.331 + ],
102.332 + {rew_ord'="tless_true", rls'=Atools_erls, calc = [],
102.333 + srls = e_rls,
102.334 + prls=e_rls,
102.335 + crls = Atools_erls, nrls = e_rls},
102.336 +"Script IntegrationScript (f_::real) (v_::real) = \
102.337 +\ (let t_ = Take (Integral f_ D v_) \
102.338 +\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) (t_::real))"
102.339 +));
102.340 +
102.341 +store_met
102.342 + (prep_met Integrate.thy "met_diffint_named" [] e_metID
102.343 + (["diff","integration","named"],
102.344 + [("#Given" ,["functionTerm f_", "integrateBy v_"]),
102.345 + ("#Find" ,["antiDerivativeName F_"])
102.346 + ],
102.347 + {rew_ord'="tless_true", rls'=Atools_erls, calc = [],
102.348 + srls = e_rls,
102.349 + prls=e_rls,
102.350 + crls = Atools_erls, nrls = e_rls},
102.351 +"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \
102.352 +\ (let t_ = Take (F_ v_ = Integral f_ D v_) \
102.353 +\ in ((Try (Rewrite_Set_Inst [(bdv,v_)] simplify_Integral False)) @@\
102.354 +\ (Rewrite_Set_Inst [(bdv,v_)] integration False)) t_)"
102.355 +(*
102.356 +"Script NamedIntegrationScript (f_::real) (v_::real) (F_::real=>real) = \
102.357 +\ (let t_ = Take (F_ v_ = Integral f_ D v_) \
102.358 +\ in (Rewrite_Set_Inst [(bdv,v_)] integration False) t_)"
102.359 +*)
102.360 + ));
103.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
103.2 +++ b/src/Tools/isac/Knowledge/Integrate.thy Wed Aug 25 16:20:07 2010 +0200
103.3 @@ -0,0 +1,54 @@
103.4 +(* integration over the reals
103.5 + author: Walther Neuper
103.6 + 050814, 08:51
103.7 + (c) due to copyright terms
103.8 +
103.9 +remove_thy"Integrate";
103.10 +use_thy"Knowledge/Integrate";
103.11 +use_thy_only"Knowledge/Integrate";
103.12 +
103.13 +remove_thy"Typefix";
103.14 +use_thy"Knowledge/Isac";
103.15 +*)
103.16 +
103.17 +Integrate = Diff +
103.18 +
103.19 +consts
103.20 +
103.21 + Integral :: "[real, real]=> real" ("Integral _ D _" 91)
103.22 +(*new'_c :: "real => real" ("new'_c _" 66)*)
103.23 + is'_f'_x :: "real => bool" ("_ is'_f'_x" 10)
103.24 +
103.25 + (*descriptions in the related problems*)
103.26 + integrateBy :: real => una
103.27 + antiDerivative :: real => una
103.28 + antiDerivativeName :: (real => real) => una
103.29 +
103.30 + (*the CAS-command, eg. "Integrate (2*x^^^3, x)"*)
103.31 + Integrate :: "[real * real] => real"
103.32 +
103.33 + (*Script-names*)
103.34 + IntegrationScript :: "[real,real, real] => real"
103.35 + ("((Script IntegrationScript (_ _ =))// (_))" 9)
103.36 + NamedIntegrationScript :: "[real,real, real=>real, bool] => bool"
103.37 + ("((Script NamedIntegrationScript (_ _ _=))// (_))" 9)
103.38 +
103.39 +rules
103.40 +(*stated as axioms, todo: prove as theorems
103.41 + 'bdv' is a constant handled on the meta-level
103.42 + specifically as a 'bound variable' *)
103.43 +
103.44 + integral_const "Not (bdv occurs_in u) ==> Integral u D bdv = u * bdv"
103.45 + integral_var "Integral bdv D bdv = bdv ^^^ 2 / 2"
103.46 +
103.47 + integral_add "Integral (u + v) D bdv = \
103.48 + \(Integral u D bdv) + (Integral v D bdv)"
103.49 + integral_mult "[| Not (bdv occurs_in u); bdv occurs_in v |] ==> \
103.50 + \Integral (u * v) D bdv = u * (Integral v D bdv)"
103.51 +(*WN080222: this goes into sub-terms, too ...
103.52 + call_for_new_c "[| Not (matches (u + new_c v) a); Not (a is_f_x) |] ==> \
103.53 + \a = a + new_c a"
103.54 +*)
103.55 + integral_pow "Integral bdv ^^^ n D bdv = bdv ^^^ (n+1) / (n + 1)"
103.56 +
103.57 +end
103.58 \ No newline at end of file
104.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
104.2 +++ b/src/Tools/isac/Knowledge/Isac.ML Wed Aug 25 16:20:07 2010 +0200
104.3 @@ -0,0 +1,37 @@
104.4 +(* collect all knowledge defined in theories so far
104.5 + author: Walther Neuper 0003
104.6 + (c) isac-team
104.7 +
104.8 +use"Knowledge/Isac.ML";
104.9 +use"Isac.ML";
104.10 + *)
104.11 +
104.12 +
104.13 +theory' := overwritel (!theory', [("Isac.thy",Isac.thy)]);
104.14 +
104.15 +
104.16 +(**.set up a list for getting guh + theID for a thm (defined in isabelle).**)
104.17 +
104.18 +(*.get all theorems used by isac and defined in isabelle.*)
104.19 +local
104.20 + val isacrlsthms = ((gen_distinct eq_thmI) o (map rep_thm_G') o flat o
104.21 + (map (thms_of_rls o #2 o #2))) (!ruleset');
104.22 + val isacthms = (flat o (map (PureThy.all_thms_of o #2))) (!theory');
104.23 +in
104.24 + val rlsthmsNOTisac = gen_diff eq_thmI (isacrlsthms, isacthms);
104.25 +end;
104.26 +
104.27 +(*.set up the list using 'val first_isac_thy' (see ListC.ML).*)
104.28 +isab_thm_thy := make_isab rlsthmsNOTisac
104.29 + ((#ancestors o rep_theory) first_isac_thy);
104.30 +
104.31 +
104.32 +(*.create the hierarchy of theory elements from IsacKnowledge
104.33 + including thms from Isabelle used in rls;
104.34 + elements store_*d in any *.ML are not overwritten.*)
104.35 +
104.36 +thehier := the_hier (!thehier) (collect_thydata ());
104.37 +writeln("----------------------------------\n\
104.38 + \*** insert: not found ... IS OK : \n\
104.39 + \comes from fill_parents \n\
104.40 + \----------------------------------\n");
105.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
105.2 +++ b/src/Tools/isac/Knowledge/Isac.thy Wed Aug 25 16:20:07 2010 +0200
105.3 @@ -0,0 +1,21 @@
105.4 +(* theory collecting all knowledge defined so far
105.5 + WN.11.00
105.6 + *)
105.7 +
105.8 +Isac = PolyMinus + PolyEq + Vect + DiffApp + Biegelinie + AlgEin
105.9 + + (*InsSort +*) Test +
105.10 +
105.11 +end
105.12 +
105.13 +(* dependencies alternative to those defined by R.Lang during his thesis:
105.14 +
105.15 + Poly Root
105.16 + |\__________ |
105.17 + | \ |
105.18 + | Rational |
105.19 + | | |
105.20 + PolyEq RatEq RootEq
105.21 + \ / \ /
105.22 + \ / \ /
105.23 + RatPolyEq RatRootEq etc.
105.24 +*)
106.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
106.2 +++ b/src/Tools/isac/Knowledge/LinEq.ML Wed Aug 25 16:20:07 2010 +0200
106.3 @@ -0,0 +1,171 @@
106.4 +(*. (c) by Richard Lang, 2003 .*)
106.5 +(* collecting all knowledge for LinearEquations
106.6 + created by: rlang
106.7 + date: 02.10
106.8 + changed by: rlang
106.9 + last change by: rlang
106.10 + date: 02.11.04
106.11 +*)
106.12 +
106.13 +(* remove_thy"LinEq";
106.14 + use_thy"Knowledge/Isac";
106.15 +
106.16 + use_thy"Knowledge/LinEq";
106.17 +
106.18 + use"ROOT.ML";
106.19 + cd"knowledge";
106.20 +*)
106.21 +
106.22 +"******* LinEq.ML begin *******";
106.23 +
106.24 +(*-------------------- theory -------------------------------------------------*)
106.25 +theory' := overwritel (!theory', [("LinEq.thy",LinEq.thy)]);
106.26 +
106.27 +(*-------------- rules -------------------------------------------------------*)
106.28 +val LinEq_prls = (*3.10.02:just the following order due to subterm evaluation*)
106.29 + append_rls "LinEq_prls" e_rls
106.30 + [Calc ("op =",eval_equal "#equal_"),
106.31 + Calc ("Tools.matches",eval_matches ""),
106.32 + Calc ("Tools.lhs" ,eval_lhs ""),
106.33 + Calc ("Tools.rhs" ,eval_rhs ""),
106.34 + Calc ("Poly.has'_degree'_in",eval_has_degree_in ""),
106.35 + Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""),
106.36 + Calc ("Atools.occurs'_in",eval_occurs_in ""),
106.37 + Calc ("Atools.ident",eval_ident "#ident_"),
106.38 + Thm ("not_true",num_str not_true),
106.39 + Thm ("not_false",num_str not_false),
106.40 + Thm ("and_true",num_str and_true),
106.41 + Thm ("and_false",num_str and_false),
106.42 + Thm ("or_true",num_str or_true),
106.43 + Thm ("or_false",num_str or_false)
106.44 + ];
106.45 +(* ----- erls ----- *)
106.46 +val LinEq_crls =
106.47 + append_rls "LinEq_crls" poly_crls
106.48 + [Thm ("real_assoc_1",num_str real_assoc_1)
106.49 + (*
106.50 + Don't use
106.51 + Calc ("HOL.divide", eval_cancel "#divide_"),
106.52 + Calc ("Atools.pow" ,eval_binop "#power_"),
106.53 + *)
106.54 + ];
106.55 +
106.56 +(* ----- crls ----- *)
106.57 +val LinEq_erls =
106.58 + append_rls "LinEq_erls" Poly_erls
106.59 + [Thm ("real_assoc_1",num_str real_assoc_1)
106.60 + (*
106.61 + Don't use
106.62 + Calc ("HOL.divide", eval_cancel "#divide_"),
106.63 + Calc ("Atools.pow" ,eval_binop "#power_"),
106.64 + *)
106.65 + ];
106.66 +
106.67 +ruleset' := overwritelthy thy (!ruleset',
106.68 + [("LinEq_erls",LinEq_erls)(*FIXXXME:del with rls.rls'*)
106.69 + ]);
106.70 +
106.71 +val LinPoly_simplify = prep_rls(
106.72 + Rls {id = "LinPoly_simplify", preconds = [],
106.73 + rew_ord = ("termlessI",termlessI),
106.74 + erls = LinEq_erls,
106.75 + srls = Erls,
106.76 + calc = [],
106.77 + (*asm_thm = [],*)
106.78 + rules = [
106.79 + Thm ("real_assoc_1",num_str real_assoc_1),
106.80 + Calc ("op +",eval_binop "#add_"),
106.81 + Calc ("op -",eval_binop "#sub_"),
106.82 + Calc ("op *",eval_binop "#mult_"),
106.83 + (* Dont use
106.84 + Calc ("HOL.divide", eval_cancel "#divide_"),
106.85 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
106.86 + *)
106.87 + Calc ("Atools.pow" ,eval_binop "#power_")
106.88 + ],
106.89 + scr = Script ((term_of o the o (parse thy)) "empty_script")
106.90 + }:rls);
106.91 +ruleset' := overwritelthy thy (!ruleset',
106.92 + [("LinPoly_simplify",LinPoly_simplify)]);
106.93 +
106.94 +(*isolate the bound variable in an linear equation; 'bdv' is a meta-constant*)
106.95 +val LinEq_simplify = prep_rls(
106.96 +Rls {id = "LinEq_simplify", preconds = [],
106.97 + rew_ord = ("e_rew_ord",e_rew_ord),
106.98 + erls = LinEq_erls,
106.99 + srls = Erls,
106.100 + calc = [],
106.101 + (*asm_thm = [("lin_isolate_div","")],*)
106.102 + rules = [
106.103 + Thm("lin_isolate_add1",num_str lin_isolate_add1),
106.104 + (* a+bx=0 -> bx=-a *)
106.105 + Thm("lin_isolate_add2",num_str lin_isolate_add2),
106.106 + (* a+ x=0 -> x=-a *)
106.107 + Thm("lin_isolate_div",num_str lin_isolate_div)
106.108 + (* bx=c -> x=c/b *)
106.109 + ],
106.110 + scr = Script ((term_of o the o (parse thy)) "empty_script")
106.111 + }:rls);
106.112 +ruleset' := overwritelthy thy (!ruleset',
106.113 + [("LinEq_simplify",LinEq_simplify)]);
106.114 +
106.115 +(*----------------------------- problem types --------------------------------*)
106.116 +(*
106.117 +show_ptyps();
106.118 +(get_pbt ["linear","univariate","equation"]);
106.119 +*)
106.120 +(* ---------linear----------- *)
106.121 +store_pbt
106.122 + (prep_pbt LinEq.thy "pbl_equ_univ_lin" [] e_pblID
106.123 + (["linear","univariate","equation"],
106.124 + [("#Given" ,["equality e_","solveFor v_"]),
106.125 + ("#Where" ,["False", (*WN0509 just detected: this pbl can never be used?!?*)
106.126 + "Not( (lhs e_) is_polyrat_in v_)",
106.127 + "Not( (rhs e_) is_polyrat_in v_)",
106.128 + "((lhs e_) has_degree_in v_)=1",
106.129 + "((rhs e_) has_degree_in v_)=1"]),
106.130 + ("#Find" ,["solutions v_i_"])
106.131 + ],
106.132 + LinEq_prls, SOME "solve (e_::bool, v_)",
106.133 + [["LinEq","solve_lineq_equation"]]));
106.134 +
106.135 +(*-------------- methods-------------------------------------------------------*)
106.136 +store_met
106.137 + (prep_met LinEq.thy "met_eqlin" [] e_metID
106.138 + (["LinEq"],
106.139 + [],
106.140 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
106.141 + crls=LinEq_crls, nrls=norm_Poly
106.142 + (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
106.143 +
106.144 +(* ansprechen mit ["LinEq","solve_univar_equation"] *)
106.145 +store_met
106.146 +(prep_met LinEq.thy "met_eq_lin" [] e_metID
106.147 + (["LinEq","solve_lineq_equation"],
106.148 + [("#Given" ,["equality e_","solveFor v_"]),
106.149 + ("#Where" ,["Not( (lhs e_) is_polyrat_in v_)",
106.150 + "( (lhs e_) has_degree_in v_)=1"]),
106.151 + ("#Find" ,["solutions v_i_"])
106.152 + ],
106.153 + {rew_ord'="termlessI",
106.154 + rls'=LinEq_erls,
106.155 + srls=e_rls,
106.156 + prls=LinEq_prls,
106.157 + calc=[],
106.158 + crls=LinEq_crls, nrls=norm_Poly(*,
106.159 + asm_rls=[],
106.160 + asm_thm=[("lin_isolate_div","")]*)},
106.161 + "Script Solve_lineq_equation (e_::bool) (v_::real) = \
106.162 + \(let e_ =((Try (Rewrite all_left False)) @@ \
106.163 + \ (Try (Repeat (Rewrite makex1_x False))) @@ \
106.164 + \ (Try (Rewrite_Set expand_binoms False)) @@ \
106.165 + \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \
106.166 + \ make_ratpoly_in False))) @@ \
106.167 + \ (Try (Repeat (Rewrite_Set LinPoly_simplify False)))) e_;\
106.168 + \ e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
106.169 + \ LinEq_simplify True)) @@ \
106.170 + \ (Repeat(Try (Rewrite_Set LinPoly_simplify False)))) e_ \
106.171 + \ in ((Or_to_List e_)::bool list))"
106.172 + ));
106.173 +"******* LinEq.ML end *******";
106.174 +get_met ["LinEq","solve_lineq_equation"];
107.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
107.2 +++ b/src/Tools/isac/Knowledge/LinEq.thy Wed Aug 25 16:20:07 2010 +0200
107.3 @@ -0,0 +1,50 @@
107.4 +(*. (c) by Richard Lang, 2003 .*)
107.5 +(* theory collecting all knowledge for LinearEquations
107.6 + created by: rlang
107.7 + date: 02.10
107.8 + changed by: rlang
107.9 + last change by: rlang
107.10 + date: 02.10.20
107.11 +*)
107.12 +
107.13 +(*
107.14 + use"knowledge/LinEq.ML";
107.15 + use"LinEq.ML";
107.16 +
107.17 + use"ROOT.ML";
107.18 + cd"knowledge";
107.19 +
107.20 +*)
107.21 +
107.22 +LinEq = Poly + Equation +
107.23 +
107.24 +(*-------------------- consts------------------------------------------------*)
107.25 +consts
107.26 + Solve'_lineq'_equation
107.27 + :: "[bool,real, \
107.28 + \ bool list] => bool list"
107.29 + ("((Script Solve'_lineq'_equation (_ _ =))// \
107.30 + \ (_))" 9)
107.31 +
107.32 +(*-------------------- rules -------------------------------------------------*)
107.33 +rules
107.34 +(*-- normalize --*)
107.35 + (*WN0509 compare PolyEq.all_left "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)"*)
107.36 + all_left
107.37 + "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)"
107.38 + makex1_x
107.39 + "a^^^1 = a"
107.40 + real_assoc_1
107.41 + "a+(b+c) = a+b+c"
107.42 + real_assoc_2
107.43 + "a*(b*c) = a*b*c"
107.44 +
107.45 +(*-- solve --*)
107.46 + lin_isolate_add1
107.47 + "(a + b*bdv = 0) = (b*bdv = (-1)*a)"
107.48 + lin_isolate_add2
107.49 + "(a + bdv = 0) = ( bdv = (-1)*a)"
107.50 + lin_isolate_div
107.51 + "[|Not(b=0)|] ==> (b*bdv = c) = (bdv = c / b)"
107.52 +end
107.53 +
108.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
108.2 +++ b/src/Tools/isac/Knowledge/LogExp.ML Wed Aug 25 16:20:07 2010 +0200
108.3 @@ -0,0 +1,39 @@
108.4 +(* all outcommented in order to demonstrate authoring:
108.5 + WN071203
108.6 +*)
108.7 +
108.8 +(** interface isabelle -- isac **)
108.9 +theory' := overwritel (!theory', [("LogExp.thy",LogExp.thy)]);
108.10 +
108.11 +(*--------------------------------------------------*)
108.12 +
108.13 +(** problems **)
108.14 +store_pbt
108.15 + (prep_pbt LogExp.thy "pbl_test_equ_univ_log" [] e_pblID
108.16 + (["logarithmic","univariate","equation"],
108.17 + [("#Given",["equality e_","solveFor v_"]),
108.18 + ("#Where",["matches ((?a log ?v_) = ?b) e_"]),
108.19 + ("#Find" ,["solutions v_i_"]),
108.20 + ("#With" ,["||(lhs (Subst (v_i_,v_) e_) - \
108.21 + \ (rhs (Subst (v_i_,v_) e_) || < eps)"])
108.22 + ],
108.23 + PolyEq_prls, SOME "solve (e_::bool, v_)",
108.24 + [["Equation","solve_log"]]));
108.25 +
108.26 +(** methods **)
108.27 +store_met
108.28 + (prep_met LogExp.thy "met_equ_log" [] e_metID
108.29 + (["Equation","solve_log"],
108.30 + [("#Given" ,["equality e_","solveFor v_"]),
108.31 + ("#Where" ,["matches ((?a log ?v_) = ?b) e_"]),
108.32 + ("#Find" ,["solutions v_i_"])
108.33 + ],
108.34 + {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls,
108.35 + calc=[],crls=PolyEq_crls, nrls=norm_Rational},
108.36 + "Script Solve_log (e_::bool) (v_::real) = \
108.37 + \(let e_ = ((Rewrite equality_power False) @@ \
108.38 + \ (Rewrite exp_invers_log False) @@ \
108.39 + \ (Rewrite_Set norm_Poly False)) e_ \
108.40 + \ in [e_])"
108.41 + ));
108.42 +(*--------------------------------------------------*)
109.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
109.2 +++ b/src/Tools/isac/Knowledge/LogExp.thy Wed Aug 25 16:20:07 2010 +0200
109.3 @@ -0,0 +1,30 @@
109.4 +(* all outcommented in order to demonstrate authoring:
109.5 + WN071203
109.6 +remove_thy"LogExp";
109.7 +use_thy_only"Knowledge/LogExp";
109.8 +use_thy_only"Knowledge/Isac";
109.9 +*)
109.10 +LogExp = PolyEq +
109.11 +
109.12 +consts
109.13 +
109.14 + ln :: "real => real"
109.15 + exp :: "real => real" ("E'_ ^^^ _" 80)
109.16 +
109.17 +(*--------------------------------------------------*)
109.18 + alog :: "[real, real] => real" ("_ log _" 90)
109.19 +
109.20 + (*Script-names*)
109.21 + Solve'_log :: "[bool,real, bool list] \
109.22 + \=> bool list"
109.23 + ("((Script Solve'_log (_ _=))//(_))" 9)
109.24 +
109.25 +rules
109.26 +
109.27 + equality_pow "0 < a ==> (l = r) = (a^^^l = a^^^r)"
109.28 + (* this is what students ^^^^^^^... are told to do *)
109.29 + equality_power "((a log b) = c) = (a^^^(a log b) = a^^^c)"
109.30 + exp_invers_log "a^^^(a log b) = b"
109.31 +(*---------------------------------------------------*)
109.32 +
109.33 +end
109.34 \ No newline at end of file
110.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
110.2 +++ b/src/Tools/isac/Knowledge/Poly.ML Wed Aug 25 16:20:07 2010 +0200
110.3 @@ -0,0 +1,1495 @@
110.4 +(*.eval_funs, rulesets, problems and methods concerning polynamials
110.5 + authors: Matthias Goldgruber 2003
110.6 + (c) due to copyright terms
110.7 +
110.8 + use"../Knowledge/Poly.ML";
110.9 + use"Knowledge/Poly.ML";
110.10 + use"Poly.ML";
110.11 +
110.12 + remove_thy"Poly";
110.13 + use_thy"Knowledge/Isac";
110.14 +****************************************************************.*)
110.15 +
110.16 +(*.****************************************************************
110.17 + remark on 'polynomials'
110.18 + WN020919
110.19 + there are 5 kinds of expanded normalforms:
110.20 +[1] 'complete polynomial' (Komplettes Polynom), univariate
110.21 + a_0 + a_1.x^1 +...+ a_n.x^n not (a_n = 0)
110.22 + not (a_n = 0), some a_i may be zero (DON'T disappear),
110.23 + variables in monomials lexicographically ordered and complete,
110.24 + x written as 1*x^1, ...
110.25 +[2] 'polynomial' (Polynom), univariate and multivariate
110.26 + a_0 + a_1.x +...+ a_n.x^n not (a_n = 0)
110.27 + a_0 + a_1.x_1.x_2^n_12...x_m^n_1m +...+ a_n.x_1^n.x_2^n_n2...x_m^n_nm
110.28 + not (a_n = 0), some a_i may be zero (ie. monomials disappear),
110.29 + exponents and coefficients equal 1 are not (WN060904.TODO in cancel_p_)shown,
110.30 + and variables in monomials are lexicographically ordered
110.31 + examples: [1]: "1 + (-10) * x ^^^ 1 + 25 * x ^^^ 2"
110.32 + [1]: "11 + 0 * x ^^^ 1 + 1 * x ^^^ 2"
110.33 + [2]: "x + (-50) * x ^^^ 3"
110.34 + [2]: "(-1) * x * y ^^^ 2 + 7 * x ^^^ 3"
110.35 +
110.36 +[3] 'expanded_term' (Ausmultiplizierter Term):
110.37 + pull out unary minus to binary minus,
110.38 + as frequently exercised in schools; other conditions for [2] hold however
110.39 + examples: "a ^^^ 2 - 2 * a * b + b ^^^ 2"
110.40 + "4 * x ^^^ 2 - 9 * y ^^^ 2"
110.41 +[4] 'polynomial_in' (Polynom in):
110.42 + polynomial in 1 variable with arbitrary coefficients
110.43 + examples: "2 * x + (-50) * x ^^^ 3" (poly in x)
110.44 + "(u + v) + (2 * u ^^^ 2) * a + (-u) * a ^^^ 2 (poly in a)
110.45 +[5] 'expanded_in' (Ausmultiplizierter Termin in):
110.46 + analoguous to [3] with binary minus like [3]
110.47 + examples: "2 * x - 50 * x ^^^ 3" (expanded in x)
110.48 + "(u + v) + (2 * u ^^^ 2) * a - u * a ^^^ 2 (expanded in a)
110.49 +*****************************************************************.*)
110.50 +
110.51 +"******** Poly.ML begin ******************************************";
110.52 +theory' := overwritel (!theory', [("Poly.thy",Poly.thy)]);
110.53 +
110.54 +
110.55 +(* is_polyrat_in becomes true, if no bdv is in the denominator of a fraction*)
110.56 +fun is_polyrat_in t v =
110.57 + let
110.58 + fun coeff_in c v = member op = (vars c) v;
110.59 + fun finddivide (_ $ _ $ _ $ _) v = raise error("is_polyrat_in:")
110.60 + (* at the moment there is no term like this, but ....*)
110.61 + | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = not(coeff_in b v)
110.62 + | finddivide (_ $ t1 $ t2) v = (finddivide t1 v) orelse (finddivide t2 v)
110.63 + | finddivide (_ $ t1) v = (finddivide t1 v)
110.64 + | finddivide _ _ = false;
110.65 + in
110.66 + finddivide t v
110.67 + end;
110.68 +
110.69 +fun eval_is_polyrat_in _ _ (p as (Const ("Poly.is'_polyrat'_in",_) $ t $ v)) _ =
110.70 + if is_polyrat_in t v then
110.71 + SOME ((term2str p) ^ " = True",
110.72 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
110.73 + else SOME ((term2str p) ^ " = True",
110.74 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
110.75 + | eval_is_polyrat_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
110.76 +
110.77 +
110.78 +local
110.79 + (*.a 'c is coefficient of v' if v does NOT occur in c.*)
110.80 + fun coeff_in c v = not (member op = (vars c) v);
110.81 + (*
110.82 + val v = (term_of o the o (parse thy)) "x";
110.83 + val t = (term_of o the o (parse thy)) "1";
110.84 + coeff_in t v;
110.85 + (*val it = true : bool*)
110.86 + val t = (term_of o the o (parse thy)) "a*b+c";
110.87 + coeff_in t v;
110.88 + (*val it = true : bool*)
110.89 + val t = (term_of o the o (parse thy)) "a*x+c";
110.90 + coeff_in t v;
110.91 + (*val it = false : bool*)
110.92 + *)
110.93 + (*. a 'monomial t in variable v' is a term t with
110.94 + either (1) v NOT existent in t, or (2) v contained in t,
110.95 + if (1) then degree 0
110.96 + if (2) then v is a factor on the very right, ev. with exponent.*)
110.97 + fun factor_right_deg (*case 2*)
110.98 + (t as Const ("op *",_) $ t1 $
110.99 + (Const ("Atools.pow",_) $ vv $ Free (d,_))) v =
110.100 + if ((vv = v) andalso (coeff_in t1 v)) then SOME (int_of_str' d) else NONE
110.101 + | factor_right_deg
110.102 + (t as Const ("Atools.pow",_) $ vv $ Free (d,_)) v =
110.103 + if (vv = v) then SOME (int_of_str' d) else NONE
110.104 + | factor_right_deg (t as Const ("op *",_) $ t1 $ vv) v =
110.105 + if ((vv = v) andalso (coeff_in t1 v))then SOME 1 else NONE
110.106 + | factor_right_deg vv v =
110.107 + if (vv = v) then SOME 1 else NONE;
110.108 + fun mono_deg_in m v =
110.109 + if coeff_in m v then (*case 1*) SOME 0
110.110 + else factor_right_deg m v;
110.111 + (*
110.112 + val v = (term_of o the o (parse thy)) "x";
110.113 + val t = (term_of o the o (parse thy)) "(a*b+c)*x^^^7";
110.114 + mono_deg_in t v;
110.115 + (*val it = SOME 7*)
110.116 + val t = (term_of o the o (parse thy)) "x^^^7";
110.117 + mono_deg_in t v;
110.118 + (*val it = SOME 7*)
110.119 + val t = (term_of o the o (parse thy)) "(a*b+c)*x";
110.120 + mono_deg_in t v;
110.121 + (*val it = SOME 1*)
110.122 + val t = (term_of o the o (parse thy)) "(a*b+x)*x";
110.123 + mono_deg_in t v;
110.124 + (*val it = NONE*)
110.125 + val t = (term_of o the o (parse thy)) "x";
110.126 + mono_deg_in t v;
110.127 + (*val it = SOME 1*)
110.128 + val t = (term_of o the o (parse thy)) "(a*b+c)";
110.129 + mono_deg_in t v;
110.130 + (*val it = SOME 0*)
110.131 + val t = (term_of o the o (parse thy)) "ab - (a*b)*x";
110.132 + mono_deg_in t v;
110.133 + (*val it = NONE*)
110.134 + *)
110.135 + fun expand_deg_in t v =
110.136 + let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) =
110.137 + (case mono_deg_in t2 v of (* $ is left associative*)
110.138 + SOME d' => edi d' d' t1
110.139 + | NONE => NONE)
110.140 + | edi ~1 ~1 (Const ("op -",_) $ t1 $ t2) =
110.141 + (case mono_deg_in t2 v of
110.142 + SOME d' => edi d' d' t1
110.143 + | NONE => NONE)
110.144 + | edi d dmax (Const ("op -",_) $ t1 $ t2) =
110.145 + (case mono_deg_in t2 v of
110.146 + (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*)
110.147 + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE
110.148 + | NONE => NONE)
110.149 + | edi d dmax (Const ("op +",_) $ t1 $ t2) =
110.150 + (case mono_deg_in t2 v of
110.151 + (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*)
110.152 + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE
110.153 + | NONE => NONE)
110.154 + | edi ~1 ~1 t =
110.155 + (case mono_deg_in t v of
110.156 + d as SOME _ => d
110.157 + | NONE => NONE)
110.158 + | edi d dmax t = (*basecase last*)
110.159 + (case mono_deg_in t v of
110.160 + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE
110.161 + | NONE => NONE)
110.162 + in edi ~1 ~1 t end;
110.163 + (*
110.164 + val v = (term_of o the o (parse thy)) "x";
110.165 + val t = (term_of o the o (parse thy)) "a+b";
110.166 + expand_deg_in t v;
110.167 + (*val it = SOME 0*)
110.168 + val t = (term_of o the o (parse thy)) "(a+b)*x";
110.169 + expand_deg_in t v;
110.170 + (*SOME 1*)
110.171 + val t = (term_of o the o (parse thy)) "a*b - (a+b)*x";
110.172 + expand_deg_in t v;
110.173 + (*SOME 1*)
110.174 + val t = (term_of o the o (parse thy)) "a*b + (a-b)*x";
110.175 + expand_deg_in t v;
110.176 + (*SOME 1*)
110.177 + val t = (term_of o the o (parse thy)) "a*b + (a+b)*x + x^^^2";
110.178 + expand_deg_in t v;
110.179 + *)
110.180 + fun poly_deg_in t v =
110.181 + let fun edi ~1 ~1 (Const ("op +",_) $ t1 $ t2) =
110.182 + (case mono_deg_in t2 v of (* $ is left associative*)
110.183 + SOME d' => edi d' d' t1
110.184 + | NONE => NONE)
110.185 + | edi d dmax (Const ("op +",_) $ t1 $ t2) =
110.186 + (case mono_deg_in t2 v of
110.187 + (*RL orelse ((d=0) andalso (d'=0)) need to handle 3+4-...4 +x*)
110.188 + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then edi d' dmax t1 else NONE
110.189 + | NONE => NONE)
110.190 + | edi ~1 ~1 t =
110.191 + (case mono_deg_in t v of
110.192 + d as SOME _ => d
110.193 + | NONE => NONE)
110.194 + | edi d dmax t = (*basecase last*)
110.195 + (case mono_deg_in t v of
110.196 + SOME d' => if ((d > d') orelse ((d=0) andalso (d'=0))) then SOME dmax else NONE
110.197 + | NONE => NONE)
110.198 + in edi ~1 ~1 t end;
110.199 +in
110.200 +
110.201 +fun is_expanded_in t v =
110.202 + case expand_deg_in t v of SOME _ => true | NONE => false;
110.203 +fun is_poly_in t v =
110.204 + case poly_deg_in t v of SOME _ => true | NONE => false;
110.205 +fun has_degree_in t v =
110.206 + case expand_deg_in t v of SOME d => d | NONE => ~1;
110.207 +end;
110.208 +(*
110.209 + val v = (term_of o the o (parse thy)) "x";
110.210 + val t = (term_of o the o (parse thy)) "a*b - (a+b)*x + x^^^2";
110.211 + has_degree_in t v;
110.212 + (*val it = 2*)
110.213 + val t = (term_of o the o (parse thy)) "-8 - 2*x + x^^^2";
110.214 + has_degree_in t v;
110.215 + (*val it = 2*)
110.216 + val t = (term_of o the o (parse thy)) "6 + 13*x + 6*x^^^2";
110.217 + has_degree_in t v;
110.218 + (*val it = 2*)
110.219 +*)
110.220 +
110.221 +(*("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in ""))*)
110.222 +fun eval_is_expanded_in _ _
110.223 + (p as (Const ("Poly.is'_expanded'_in",_) $ t $ v)) _ =
110.224 + if is_expanded_in t v
110.225 + then SOME ((term2str p) ^ " = True",
110.226 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
110.227 + else SOME ((term2str p) ^ " = True",
110.228 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
110.229 + | eval_is_expanded_in _ _ _ _ = NONE;
110.230 +(*
110.231 + val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) is_expanded_in x";
110.232 + val SOME (id, t') = eval_is_expanded_in 0 0 t 0;
110.233 + (*val id = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*)
110.234 + term2str t';
110.235 + (*val it = "Poly.is'_expanded'_in (-8 - 2 * x + x ^^^ 2) x = True"*)
110.236 +*)
110.237 +(*("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in ""))*)
110.238 +fun eval_is_poly_in _ _
110.239 + (p as (Const ("Poly.is'_poly'_in",_) $ t $ v)) _ =
110.240 + if is_poly_in t v
110.241 + then SOME ((term2str p) ^ " = True",
110.242 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
110.243 + else SOME ((term2str p) ^ " = True",
110.244 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
110.245 + | eval_is_poly_in _ _ _ _ = NONE;
110.246 +(*
110.247 + val t = (term_of o the o (parse thy)) "(8 + 2*x + x^^^2) is_poly_in x";
110.248 + val SOME (id, t') = eval_is_poly_in 0 0 t 0;
110.249 + (*val id = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*)
110.250 + term2str t';
110.251 + (*val it = "Poly.is'_poly'_in (8 + 2 * x + x ^^^ 2) x = True"*)
110.252 +*)
110.253 +
110.254 +(*("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in ""))*)
110.255 +fun eval_has_degree_in _ _
110.256 + (p as (Const ("Poly.has'_degree'_in",_) $ t $ v)) _ =
110.257 + let val d = has_degree_in t v
110.258 + val d' = term_of_num HOLogic.realT d
110.259 + in SOME ((term2str p) ^ " = " ^ (string_of_int d),
110.260 + Trueprop $ (mk_equality (p, d')))
110.261 + end
110.262 + | eval_has_degree_in _ _ _ _ = NONE;
110.263 +(*
110.264 +> val t = (term_of o the o (parse thy)) "(-8 - 2*x + x^^^2) has_degree_in x";
110.265 +> val SOME (id, t') = eval_has_degree_in 0 0 t 0;
110.266 +val id = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string
110.267 +> term2str t';
110.268 +val it = "Poly.has'_degree'_in (-8 - 2 * x + x ^^^ 2) x = 2" : string
110.269 +*)
110.270 +
110.271 +(*..*)
110.272 +val calculate_Poly =
110.273 + append_rls "calculate_PolyFIXXXME.not.impl." e_rls
110.274 + [];
110.275 +
110.276 +(*.for evaluation of conditions in rewrite rules.*)
110.277 +val Poly_erls =
110.278 + append_rls "Poly_erls" Atools_erls
110.279 + [ Calc ("op =",eval_equal "#equal_"),
110.280 + Thm ("real_unari_minus",num_str real_unari_minus),
110.281 + Calc ("op +",eval_binop "#add_"),
110.282 + Calc ("op -",eval_binop "#sub_"),
110.283 + Calc ("op *",eval_binop "#mult_"),
110.284 + Calc ("Atools.pow" ,eval_binop "#power_")
110.285 + ];
110.286 +
110.287 +val poly_crls =
110.288 + append_rls "poly_crls" Atools_crls
110.289 + [ Calc ("op =",eval_equal "#equal_"),
110.290 + Thm ("real_unari_minus",num_str real_unari_minus),
110.291 + Calc ("op +",eval_binop "#add_"),
110.292 + Calc ("op -",eval_binop "#sub_"),
110.293 + Calc ("op *",eval_binop "#mult_"),
110.294 + Calc ("Atools.pow" ,eval_binop "#power_")
110.295 + ];
110.296 +
110.297 +
110.298 +local (*. for make_polynomial .*)
110.299 +
110.300 +open Term; (* for type order = EQUAL | LESS | GREATER *)
110.301 +
110.302 +fun pr_ord EQUAL = "EQUAL"
110.303 + | pr_ord LESS = "LESS"
110.304 + | pr_ord GREATER = "GREATER";
110.305 +
110.306 +fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
110.307 + (case a of
110.308 + "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest string*)
110.309 + | _ => (((a, 0), T), 0))
110.310 + | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
110.311 + | dest_hd' (Var v) = (v, 2)
110.312 + | dest_hd' (Bound i) = ((("", i), dummyT), 3)
110.313 + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
110.314 +
110.315 +fun get_order_pow (t $ (Free(order,_))) = (* RL FIXXXME:geht zufaellig?WN*)
110.316 + (case int_of_str (order) of
110.317 + SOME d => d
110.318 + | NONE => 0)
110.319 + | get_order_pow _ = 0;
110.320 +
110.321 +fun size_of_term' (Const(str,_) $ t) =
110.322 + if "Atools.pow"= str then 1000 + size_of_term' t else 1+size_of_term' t(*WN*)
110.323 + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
110.324 + | size_of_term' (f$t) = size_of_term' f + size_of_term' t
110.325 + | size_of_term' _ = 1;
110.326 +
110.327 +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
110.328 + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
110.329 + | term_ord' pr thy (t, u) =
110.330 + (if pr then
110.331 + let
110.332 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
110.333 + val _=writeln("t= f@ts= \""^
110.334 + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
110.335 + (commas(map(Syntax.string_of_term (thy2ctxt thy))ts))^"]\"");
110.336 + val _=writeln("u= g@us= \""^
110.337 + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
110.338 + (commas(map(Syntax.string_of_term (thy2ctxt thy))us))^"]\"");
110.339 + val _=writeln("size_of_term(t,u)= ("^
110.340 + (string_of_int(size_of_term' t))^", "^
110.341 + (string_of_int(size_of_term' u))^")");
110.342 + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
110.343 + val _=writeln("terms_ord(ts,us) = "^
110.344 + ((pr_ord o terms_ord str false)(ts,us)));
110.345 + val _=writeln("-------");
110.346 + in () end
110.347 + else ();
110.348 + case int_ord (size_of_term' t, size_of_term' u) of
110.349 + EQUAL =>
110.350 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
110.351 + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
110.352 + | ord => ord)
110.353 + end
110.354 + | ord => ord)
110.355 +and hd_ord (f, g) = (* ~ term.ML *)
110.356 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
110.357 +and terms_ord str pr (ts, us) =
110.358 + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
110.359 +in
110.360 +
110.361 +fun ord_make_polynomial (pr:bool) thy (_:subst) tu =
110.362 + (term_ord' pr thy(***) tu = LESS );
110.363 +
110.364 +end;(*local*)
110.365 +
110.366 +
110.367 +rew_ord' := overwritel (!rew_ord',
110.368 +[("termlessI", termlessI),
110.369 + ("ord_make_polynomial", ord_make_polynomial false thy)
110.370 + ]);
110.371 +
110.372 +
110.373 +val expand =
110.374 + Rls{id = "expand", preconds = [],
110.375 + rew_ord = ("dummy_ord", dummy_ord),
110.376 + erls = e_rls,srls = Erls,
110.377 + calc = [],
110.378 + (*asm_thm = [],*)
110.379 + rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
110.380 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
110.381 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2)
110.382 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
110.383 + ], scr = EmptyScr}:rls;
110.384 +
110.385 +(*----------------- Begin: rulesets for make_polynomial_ -----------------
110.386 + 'rlsIDs' redefined by MG as 'rlsIDs_'
110.387 + ^^^*)
110.388 +
110.389 +val discard_minus_ =
110.390 + Rls{id = "discard_minus_", preconds = [],
110.391 + rew_ord = ("dummy_ord", dummy_ord),
110.392 + erls = e_rls,srls = Erls,
110.393 + calc = [],
110.394 + (*asm_thm = [],*)
110.395 + rules = [Thm ("real_diff_minus",num_str real_diff_minus),
110.396 + (*"a - b = a + -1 * b"*)
110.397 + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
110.398 + (*- ?z = "-1 * ?z"*)
110.399 + ], scr = EmptyScr}:rls;
110.400 +val expand_poly_ =
110.401 + Rls{id = "expand_poly_", preconds = [],
110.402 + rew_ord = ("dummy_ord", dummy_ord),
110.403 + erls = e_rls,srls = Erls,
110.404 + calc = [],
110.405 + (*asm_thm = [],*)
110.406 + rules = [Thm ("real_plus_binom_pow4",num_str real_plus_binom_pow4),
110.407 + (*"(a + b)^^^4 = ... "*)
110.408 + Thm ("real_plus_binom_pow5",num_str real_plus_binom_pow5),
110.409 + (*"(a + b)^^^5 = ... "*)
110.410 + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
110.411 + (*"(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *)
110.412 +
110.413 + (*WN071229 changed/removed for Schaerding -----vvv*)
110.414 + (*Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),*)
110.415 + (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
110.416 + Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),
110.417 + (*"(a + b)^^^2 = (a + b) * (a + b)"*)
110.418 + (*Thm ("real_plus_minus_binom1_p_p",
110.419 + num_str real_plus_minus_binom1_p_p),*)
110.420 + (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*)
110.421 + (*Thm ("real_plus_minus_binom2_p_p",
110.422 + num_str real_plus_minus_binom2_p_p),*)
110.423 + (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*)
110.424 + (*WN071229 changed/removed for Schaerding -----^^^*)
110.425 +
110.426 + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
110.427 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
110.428 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
110.429 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
110.430 +
110.431 + Thm ("realpow_multI", num_str realpow_multI),
110.432 + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
110.433 + Thm ("realpow_pow",num_str realpow_pow)
110.434 + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
110.435 + ], scr = EmptyScr}:rls;
110.436 +
110.437 +(*.the expression contains + - * ^ only ?
110.438 + this is weaker than 'is_polynomial' !.*)
110.439 +fun is_polyexp (Free _) = true
110.440 + | is_polyexp (Const ("op +",_) $ Free _ $ Free _) = true
110.441 + | is_polyexp (Const ("op -",_) $ Free _ $ Free _) = true
110.442 + | is_polyexp (Const ("op *",_) $ Free _ $ Free _) = true
110.443 + | is_polyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true
110.444 + | is_polyexp (Const ("op +",_) $ t1 $ t2) =
110.445 + ((is_polyexp t1) andalso (is_polyexp t2))
110.446 + | is_polyexp (Const ("op -",_) $ t1 $ t2) =
110.447 + ((is_polyexp t1) andalso (is_polyexp t2))
110.448 + | is_polyexp (Const ("op *",_) $ t1 $ t2) =
110.449 + ((is_polyexp t1) andalso (is_polyexp t2))
110.450 + | is_polyexp (Const ("Atools.pow",_) $ t1 $ t2) =
110.451 + ((is_polyexp t1) andalso (is_polyexp t2))
110.452 + | is_polyexp _ = false;
110.453 +
110.454 +(*("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp ""))*)
110.455 +fun eval_is_polyexp (thmid:string) _
110.456 + (t as (Const("Poly.is'_polyexp", _) $ arg)) thy =
110.457 + if is_polyexp arg
110.458 + then SOME (mk_thmid thmid ""
110.459 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
110.460 + Trueprop $ (mk_equality (t, HOLogic.true_const)))
110.461 + else SOME (mk_thmid thmid ""
110.462 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
110.463 + Trueprop $ (mk_equality (t, HOLogic.false_const)))
110.464 + | eval_is_polyexp _ _ _ _ = NONE;
110.465 +
110.466 +val expand_poly_rat_ =
110.467 + Rls{id = "expand_poly_rat_", preconds = [],
110.468 + rew_ord = ("dummy_ord", dummy_ord),
110.469 + erls = append_rls "e_rls-is_polyexp" e_rls
110.470 + [Calc ("Poly.is'_polyexp", eval_is_polyexp "")
110.471 + ],
110.472 + srls = Erls,
110.473 + calc = [],
110.474 + (*asm_thm = [],*)
110.475 + rules = [Thm ("real_plus_binom_pow4_poly",num_str real_plus_binom_pow4_poly),
110.476 + (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^4 = ... "*)
110.477 + Thm ("real_plus_binom_pow5_poly",num_str real_plus_binom_pow5_poly),
110.478 + (*"[| a is_polyexp; b is_polyexp |] ==> (a + b)^^^5 = ... "*)
110.479 + Thm ("real_plus_binom_pow2_poly",num_str real_plus_binom_pow2_poly),
110.480 + (*"[| a is_polyexp; b is_polyexp |] ==>
110.481 + (a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
110.482 + Thm ("real_plus_binom_pow3_poly",num_str real_plus_binom_pow3_poly),
110.483 + (*"[| a is_polyexp; b is_polyexp |] ==>
110.484 + (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3" *)
110.485 + Thm ("real_plus_minus_binom1_p_p",num_str real_plus_minus_binom1_p_p),
110.486 + (*"(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"*)
110.487 + Thm ("real_plus_minus_binom2_p_p",num_str real_plus_minus_binom2_p_p),
110.488 + (*"(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"*)
110.489 +
110.490 + Thm ("real_add_mult_distrib_poly" ,num_str real_add_mult_distrib_poly),
110.491 + (*"w is_polyexp ==> (z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
110.492 + Thm ("real_add_mult_distrib2_poly",num_str real_add_mult_distrib2_poly),
110.493 + (*"w is_polyexp ==> w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
110.494 +
110.495 + Thm ("realpow_multI_poly", num_str realpow_multI_poly),
110.496 + (*"[| r is_polyexp; s is_polyexp |] ==>
110.497 + (r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
110.498 + Thm ("realpow_pow",num_str realpow_pow)
110.499 + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
110.500 + ], scr = EmptyScr}:rls;
110.501 +
110.502 +val simplify_power_ =
110.503 + Rls{id = "simplify_power_", preconds = [],
110.504 + rew_ord = ("dummy_ord", dummy_ord),
110.505 + erls = e_rls, srls = Erls,
110.506 + calc = [],
110.507 + (*asm_thm = [],*)
110.508 + rules = [(*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen
110.509 + a*(a*a) --> a*a^^^2 und nicht a*(a*a) --> a^^^2*a *)
110.510 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
110.511 + (*"r * r = r ^^^ 2"*)
110.512 + Thm ("realpow_twoI_assoc_l",num_str realpow_twoI_assoc_l),
110.513 + (*"r * (r * s) = r ^^^ 2 * s"*)
110.514 +
110.515 + Thm ("realpow_plus_1",num_str realpow_plus_1),
110.516 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
110.517 + Thm ("realpow_plus_1_assoc_l", num_str realpow_plus_1_assoc_l),
110.518 + (*"r * (r ^^^ m * s) = r ^^^ (1 + m) * s"*)
110.519 + (*MG 9.7.03: neues Thm wegen a*(a*(a*b)) --> a^^^2*(a*b) *)
110.520 + Thm ("realpow_plus_1_assoc_l2", num_str realpow_plus_1_assoc_l2),
110.521 + (*"r ^^^ m * (r * s) = r ^^^ (1 + m) * s"*)
110.522 +
110.523 + Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)),
110.524 + (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
110.525 + Thm ("realpow_addI_assoc_l", num_str realpow_addI_assoc_l),
110.526 + (*"r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s"*)
110.527 +
110.528 + (* ist in expand_poly - wird hier aber auch gebraucht, wegen:
110.529 + "r * r = r ^^^ 2" wenn r=a^^^b*)
110.530 + Thm ("realpow_pow",num_str realpow_pow)
110.531 + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
110.532 + ], scr = EmptyScr}:rls;
110.533 +
110.534 +val calc_add_mult_pow_ =
110.535 + Rls{id = "calc_add_mult_pow_", preconds = [],
110.536 + rew_ord = ("dummy_ord", dummy_ord),
110.537 + erls = Atools_erls(*erls3.4.03*),srls = Erls,
110.538 + calc = [("PLUS" , ("op +", eval_binop "#add_")),
110.539 + ("TIMES" , ("op *", eval_binop "#mult_")),
110.540 + ("POWER", ("Atools.pow", eval_binop "#power_"))
110.541 + ],
110.542 + (*asm_thm = [],*)
110.543 + rules = [Calc ("op +", eval_binop "#add_"),
110.544 + Calc ("op *", eval_binop "#mult_"),
110.545 + Calc ("Atools.pow", eval_binop "#power_")
110.546 + ], scr = EmptyScr}:rls;
110.547 +
110.548 +val reduce_012_mult_ =
110.549 + Rls{id = "reduce_012_mult_", preconds = [],
110.550 + rew_ord = ("dummy_ord", dummy_ord),
110.551 + erls = e_rls,srls = Erls,
110.552 + calc = [],
110.553 + (*asm_thm = [],*)
110.554 + rules = [(* MG: folgende Thm müssen hier stehen bleiben: *)
110.555 + Thm ("real_mult_1_right",num_str real_mult_1_right),
110.556 + (*"z * 1 = z"*) (*wegen "a * b * b^^^(-1) + a"*)
110.557 + Thm ("realpow_zeroI",num_str realpow_zeroI),
110.558 + (*"r ^^^ 0 = 1"*) (*wegen "a*a^^^(-1)*c + b + c"*)
110.559 + Thm ("realpow_oneI",num_str realpow_oneI),
110.560 + (*"r ^^^ 1 = r"*)
110.561 + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI)
110.562 + (*"1 ^^^ n = 1"*)
110.563 + ], scr = EmptyScr}:rls;
110.564 +
110.565 +val collect_numerals_ =
110.566 + Rls{id = "collect_numerals_", preconds = [],
110.567 + rew_ord = ("dummy_ord", dummy_ord),
110.568 + erls = Atools_erls, srls = Erls,
110.569 + calc = [("PLUS" , ("op +", eval_binop "#add_"))
110.570 + ],
110.571 + rules = [Thm ("real_num_collect",num_str real_num_collect),
110.572 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
110.573 + Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r),
110.574 + (*"[| l is_const; m is_const |] ==> \
110.575 + \(k + m * n) + l * n = k + (l + m)*n"*)
110.576 + Thm ("real_one_collect",num_str real_one_collect),
110.577 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
110.578 + Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r),
110.579 + (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*)
110.580 +
110.581 + Calc ("op +", eval_binop "#add_"),
110.582 +
110.583 + (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen
110.584 + (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *)
110.585 + Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r),
110.586 + (*"(k + z1) + z1 = k + 2 * z1"*)
110.587 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym))
110.588 + (*"z1 + z1 = 2 * z1"*)
110.589 +
110.590 + ], scr = EmptyScr}:rls;
110.591 +
110.592 +val reduce_012_ =
110.593 + Rls{id = "reduce_012_", preconds = [],
110.594 + rew_ord = ("dummy_ord", dummy_ord),
110.595 + erls = e_rls,srls = Erls,
110.596 + calc = [],
110.597 + (*asm_thm = [],*)
110.598 + rules = [Thm ("real_mult_1",num_str real_mult_1),
110.599 + (*"1 * z = z"*)
110.600 + Thm ("real_mult_0",num_str real_mult_0),
110.601 + (*"0 * z = 0"*)
110.602 + Thm ("real_mult_0_right",num_str real_mult_0_right),
110.603 + (*"z * 0 = 0"*)
110.604 + Thm ("real_add_zero_left",num_str real_add_zero_left),
110.605 + (*"0 + z = z"*)
110.606 + Thm ("real_add_zero_right",num_str real_add_zero_right),
110.607 + (*"z + 0 = z"*) (*wegen a+b-b --> a+(1-1)*b --> a+0 --> a*)
110.608 +
110.609 + (*Thm ("realpow_oneI",num_str realpow_oneI)*)
110.610 + (*"?r ^^^ 1 = ?r"*)
110.611 + Thm ("real_0_divide",num_str real_0_divide)(*WN060914*)
110.612 + (*"0 / ?x = 0"*)
110.613 + ], scr = EmptyScr}:rls;
110.614 +
110.615 +(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*)
110.616 +val discard_parentheses_ =
110.617 + append_rls "discard_parentheses_" e_rls
110.618 + [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym))
110.619 + (*"?z1.1 * (?z2.1 * ?z3.1) = ?z1.1 * ?z2.1 * ?z3.1"*)
110.620 + (*Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))*)
110.621 + (*"?z1.1 + (?z2.1 + ?z3.1) = ?z1.1 + ?z2.1 + ?z3.1"*)
110.622 + ];
110.623 +
110.624 +(*----------------- End: rulesets for make_polynomial_ -----------------*)
110.625 +
110.626 +(*MG.0401 ev. for use in rls with ordered rewriting ?
110.627 +val collect_numerals_left =
110.628 + Rls{id = "collect_numerals", preconds = [],
110.629 + rew_ord = ("dummy_ord", dummy_ord),
110.630 + erls = Atools_erls(*erls3.4.03*),srls = Erls,
110.631 + calc = [("PLUS" , ("op +", eval_binop "#add_")),
110.632 + ("TIMES" , ("op *", eval_binop "#mult_")),
110.633 + ("POWER", ("Atools.pow", eval_binop "#power_"))
110.634 + ],
110.635 + (*asm_thm = [],*)
110.636 + rules = [Thm ("real_num_collect",num_str real_num_collect),
110.637 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
110.638 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
110.639 + (*"[| l is_const; m is_const |] ==>
110.640 + l * n + (m * n + k) = (l + m) * n + k"*)
110.641 + Thm ("real_one_collect",num_str real_one_collect),
110.642 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
110.643 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
110.644 + (*"m is_const ==> n + (m * n + k) = (1 + m) * n + k"*)
110.645 +
110.646 + Calc ("op +", eval_binop "#add_"),
110.647 +
110.648 + (*MG am 2.5.03: 2 Theoreme aus reduce_012 hierher verschoben*)
110.649 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
110.650 + (*"z1 + z1 = 2 * z1"*)
110.651 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc)
110.652 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
110.653 + ], scr = EmptyScr}:rls;*)
110.654 +
110.655 +val expand_poly =
110.656 + Rls{id = "expand_poly", preconds = [],
110.657 + rew_ord = ("dummy_ord", dummy_ord),
110.658 + erls = e_rls,srls = Erls,
110.659 + calc = [],
110.660 + (*asm_thm = [],*)
110.661 + rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
110.662 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
110.663 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
110.664 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
110.665 + (*Thm ("real_add_mult_distrib1",num_str real_add_mult_distrib1),
110.666 + ....... 18.3.03 undefined???*)
110.667 +
110.668 + Thm ("real_plus_binom_pow2",num_str real_plus_binom_pow2),
110.669 + (*"(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
110.670 + Thm ("real_minus_binom_pow2_p",num_str real_minus_binom_pow2_p),
110.671 + (*"(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2"*)
110.672 + Thm ("real_plus_minus_binom1_p",
110.673 + num_str real_plus_minus_binom1_p),
110.674 + (*"(a + b)*(a - b) = a^^^2 + -1*b^^^2"*)
110.675 + Thm ("real_plus_minus_binom2_p",
110.676 + num_str real_plus_minus_binom2_p),
110.677 + (*"(a - b)*(a + b) = a^^^2 + -1*b^^^2"*)
110.678 +
110.679 + Thm ("real_minus_minus",num_str real_minus_minus),
110.680 + (*"- (- ?z) = ?z"*)
110.681 + Thm ("real_diff_minus",num_str real_diff_minus),
110.682 + (*"a - b = a + -1 * b"*)
110.683 + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
110.684 + (*- ?z = "-1 * ?z"*)
110.685 +
110.686 + (*Thm ("",num_str ),
110.687 + Thm ("",num_str ),
110.688 + Thm ("",num_str ),*)
110.689 + (*Thm ("real_minus_add_distrib",
110.690 + num_str real_minus_add_distrib),*)
110.691 + (*"- (?x + ?y) = - ?x + - ?y"*)
110.692 + (*Thm ("real_diff_plus",num_str real_diff_plus)*)
110.693 + (*"a - b = a + -b"*)
110.694 + ], scr = EmptyScr}:rls;
110.695 +val simplify_power =
110.696 + Rls{id = "simplify_power", preconds = [],
110.697 + rew_ord = ("dummy_ord", dummy_ord),
110.698 + erls = e_rls, srls = Erls,
110.699 + calc = [],
110.700 + (*asm_thm = [],*)
110.701 + rules = [Thm ("realpow_multI", num_str realpow_multI),
110.702 + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
110.703 +
110.704 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
110.705 + (*"r1 * r1 = r1 ^^^ 2"*)
110.706 + Thm ("realpow_plus_1",num_str realpow_plus_1),
110.707 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
110.708 + Thm ("realpow_pow",num_str realpow_pow),
110.709 + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
110.710 + Thm ("sym_realpow_addI",num_str (realpow_addI RS sym)),
110.711 + (*"r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
110.712 + Thm ("realpow_oneI",num_str realpow_oneI),
110.713 + (*"r ^^^ 1 = r"*)
110.714 + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI)
110.715 + (*"1 ^^^ n = 1"*)
110.716 + ], scr = EmptyScr}:rls;
110.717 +(*MG.0401: termorders for multivariate polys dropped due to principal problems:
110.718 + (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*)
110.719 +val order_add_mult =
110.720 + Rls{id = "order_add_mult", preconds = [],
110.721 + rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy),
110.722 + erls = e_rls,srls = Erls,
110.723 + calc = [],
110.724 + (*asm_thm = [],*)
110.725 + rules = [Thm ("real_mult_commute",num_str real_mult_commute),
110.726 + (* z * w = w * z *)
110.727 + Thm ("real_mult_left_commute",num_str real_mult_left_commute),
110.728 + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
110.729 + Thm ("real_mult_assoc",num_str real_mult_assoc),
110.730 + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
110.731 + Thm ("real_add_commute",num_str real_add_commute),
110.732 + (*z + w = w + z*)
110.733 + Thm ("real_add_left_commute",num_str real_add_left_commute),
110.734 + (*x + (y + z) = y + (x + z)*)
110.735 + Thm ("real_add_assoc",num_str real_add_assoc)
110.736 + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
110.737 + ], scr = EmptyScr}:rls;
110.738 +(*MG.0401: termorders for multivariate polys dropped due to principal problems:
110.739 + (total-degree-)ordering of monoms NOT possible with size_of_term GIVEN*)
110.740 +val order_mult =
110.741 + Rls{id = "order_mult", preconds = [],
110.742 + rew_ord = ("ord_make_polynomial",ord_make_polynomial false Poly.thy),
110.743 + erls = e_rls,srls = Erls,
110.744 + calc = [],
110.745 + (*asm_thm = [],*)
110.746 + rules = [Thm ("real_mult_commute",num_str real_mult_commute),
110.747 + (* z * w = w * z *)
110.748 + Thm ("real_mult_left_commute",num_str real_mult_left_commute),
110.749 + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
110.750 + Thm ("real_mult_assoc",num_str real_mult_assoc)
110.751 + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
110.752 + ], scr = EmptyScr}:rls;
110.753 +val collect_numerals =
110.754 + Rls{id = "collect_numerals", preconds = [],
110.755 + rew_ord = ("dummy_ord", dummy_ord),
110.756 + erls = Atools_erls(*erls3.4.03*),srls = Erls,
110.757 + calc = [("PLUS" , ("op +", eval_binop "#add_")),
110.758 + ("TIMES" , ("op *", eval_binop "#mult_")),
110.759 + ("POWER", ("Atools.pow", eval_binop "#power_"))
110.760 + ],
110.761 + (*asm_thm = [],*)
110.762 + rules = [Thm ("real_num_collect",num_str real_num_collect),
110.763 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
110.764 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
110.765 + (*"[| l is_const; m is_const |] ==>
110.766 + l * n + (m * n + k) = (l + m) * n + k"*)
110.767 + Thm ("real_one_collect",num_str real_one_collect),
110.768 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
110.769 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
110.770 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
110.771 + Calc ("op +", eval_binop "#add_"),
110.772 + Calc ("op *", eval_binop "#mult_"),
110.773 + Calc ("Atools.pow", eval_binop "#power_")
110.774 + ], scr = EmptyScr}:rls;
110.775 +val reduce_012 =
110.776 + Rls{id = "reduce_012", preconds = [],
110.777 + rew_ord = ("dummy_ord", dummy_ord),
110.778 + erls = e_rls,srls = Erls,
110.779 + calc = [],
110.780 + (*asm_thm = [],*)
110.781 + rules = [Thm ("real_mult_1",num_str real_mult_1),
110.782 + (*"1 * z = z"*)
110.783 + (*Thm ("real_mult_minus1",num_str real_mult_minus1),14.3.03*)
110.784 + (*"-1 * z = - z"*)
110.785 + Thm ("sym_real_mult_minus_eq1",
110.786 + num_str (real_mult_minus_eq1 RS sym)),
110.787 + (*- (?x * ?y) = "- ?x * ?y"*)
110.788 + (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel),
110.789 + (*"- ?x * - ?y = ?x * ?y"*)---*)
110.790 + Thm ("real_mult_0",num_str real_mult_0),
110.791 + (*"0 * z = 0"*)
110.792 + Thm ("real_add_zero_left",num_str real_add_zero_left),
110.793 + (*"0 + z = z"*)
110.794 + Thm ("real_add_minus",num_str real_add_minus),
110.795 + (*"?z + - ?z = 0"*)
110.796 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
110.797 + (*"z1 + z1 = 2 * z1"*)
110.798 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc)
110.799 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
110.800 + ], scr = EmptyScr}:rls;
110.801 +(*ein Hilfs-'ruleset' (benutzt das leere 'ruleset')*)
110.802 +val discard_parentheses =
110.803 + append_rls "discard_parentheses" e_rls
110.804 + [Thm ("sym_real_mult_assoc", num_str (real_mult_assoc RS sym)),
110.805 + Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym))];
110.806 +
110.807 +val scr_make_polynomial =
110.808 +"Script Expand_binoms t_ =\
110.809 +\(Repeat \
110.810 +\((Try (Repeat (Rewrite real_diff_minus False))) @@ \
110.811 +
110.812 +\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \
110.813 +\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \
110.814 +\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \
110.815 +\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \
110.816 +
110.817 +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
110.818 +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
110.819 +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
110.820 +
110.821 +\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \
110.822 +\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \
110.823 +\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \
110.824 +\ (Try (Repeat (Rewrite real_add_commute False))) @@ \
110.825 +\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \
110.826 +\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \
110.827 +
110.828 +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
110.829 +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
110.830 +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
110.831 +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
110.832 +
110.833 +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
110.834 +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
110.835 +
110.836 +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
110.837 +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
110.838 +
110.839 +\ (Try (Repeat (Calculate plus ))) @@ \
110.840 +\ (Try (Repeat (Calculate times ))) @@ \
110.841 +\ (Try (Repeat (Calculate power_)))) \
110.842 +\ t_)";
110.843 +
110.844 +(*version used by MG.02/03, overwritten by version AG in 04 below
110.845 +val make_polynomial = prep_rls(
110.846 + Seq{id = "make_polynomial", preconds = []:term list,
110.847 + rew_ord = ("dummy_ord", dummy_ord),
110.848 + erls = Atools_erls, srls = Erls,
110.849 + calc = [],(*asm_thm = [],*)
110.850 + rules = [Rls_ expand_poly,
110.851 + Rls_ order_add_mult,
110.852 + Rls_ simplify_power, (*realpow_eq_oneI, eg. x^1 --> x *)
110.853 + Rls_ collect_numerals, (*eg. x^(2+ -1) --> x^1 *)
110.854 + Rls_ reduce_012,
110.855 + Thm ("realpow_oneI",num_str realpow_oneI),(*in --^*)
110.856 + Rls_ discard_parentheses
110.857 + ],
110.858 + scr = EmptyScr
110.859 + }:rls); *)
110.860 +
110.861 +val scr_expand_binoms =
110.862 +"Script Expand_binoms t_ =\
110.863 +\(Repeat \
110.864 +\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \
110.865 +\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \
110.866 +\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \
110.867 +\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \
110.868 +\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \
110.869 +\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \
110.870 +
110.871 +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
110.872 +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
110.873 +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
110.874 +
110.875 +\ (Try (Repeat (Calculate plus ))) @@ \
110.876 +\ (Try (Repeat (Calculate times ))) @@ \
110.877 +\ (Try (Repeat (Calculate power_))) @@ \
110.878 +
110.879 +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
110.880 +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
110.881 +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
110.882 +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
110.883 +
110.884 +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
110.885 +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
110.886 +
110.887 +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
110.888 +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
110.889 +
110.890 +\ (Try (Repeat (Calculate plus ))) @@ \
110.891 +\ (Try (Repeat (Calculate times ))) @@ \
110.892 +\ (Try (Repeat (Calculate power_)))) \
110.893 +\ t_)";
110.894 +
110.895 +val expand_binoms =
110.896 + Rls{id = "expand_binoms", preconds = [], rew_ord = ("termlessI",termlessI),
110.897 + erls = Atools_erls, srls = Erls,
110.898 + calc = [("PLUS" , ("op +", eval_binop "#add_")),
110.899 + ("TIMES" , ("op *", eval_binop "#mult_")),
110.900 + ("POWER", ("Atools.pow", eval_binop "#power_"))
110.901 + ],
110.902 + (*asm_thm = [],*)
110.903 + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
110.904 + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
110.905 + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
110.906 + (*"(a + b)*(a + b) = ...*)
110.907 + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
110.908 + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
110.909 + Thm ("real_minus_binom_times",num_str real_minus_binom_times),
110.910 + (*"(a - b)*(a - b) = ...*)
110.911 + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
110.912 + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
110.913 + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
110.914 + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
110.915 + (*RL 020915*)
110.916 + Thm ("real_pp_binom_times",num_str real_pp_binom_times),
110.917 + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
110.918 + Thm ("real_pm_binom_times",num_str real_pm_binom_times),
110.919 + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
110.920 + Thm ("real_mp_binom_times",num_str real_mp_binom_times),
110.921 + (*(a - b)*(c + d) = a*c + a*d - b*c - b*d*)
110.922 + Thm ("real_mm_binom_times",num_str real_mm_binom_times),
110.923 + (*(a - b)*(c - d) = a*c - a*d - b*c + b*d*)
110.924 + Thm ("realpow_multI",num_str realpow_multI),
110.925 + (*(a*b)^^^n = a^^^n * b^^^n*)
110.926 + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
110.927 + (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *)
110.928 + Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3),
110.929 + (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *)
110.930 +
110.931 +
110.932 + (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
110.933 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
110.934 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
110.935 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
110.936 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
110.937 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
110.938 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
110.939 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
110.940 + *)
110.941 +
110.942 + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
110.943 + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
110.944 + Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*)
110.945 +
110.946 + Calc ("op +", eval_binop "#add_"),
110.947 + Calc ("op *", eval_binop "#mult_"),
110.948 + Calc ("Atools.pow", eval_binop "#power_"),
110.949 + (*
110.950 + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
110.951 + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
110.952 + Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
110.953 + Thm ("real_add_commute",num_str real_add_commute), (**)
110.954 + Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
110.955 + Thm ("real_add_assoc",num_str real_add_assoc), (**)
110.956 + *)
110.957 +
110.958 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
110.959 + (*"r1 * r1 = r1 ^^^ 2"*)
110.960 + Thm ("realpow_plus_1",num_str realpow_plus_1),
110.961 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
110.962 + (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
110.963 + (*"z1 + z1 = 2 * z1"*)*)
110.964 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
110.965 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
110.966 +
110.967 + Thm ("real_num_collect",num_str real_num_collect),
110.968 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
110.969 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
110.970 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
110.971 + Thm ("real_one_collect",num_str real_one_collect),
110.972 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
110.973 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
110.974 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
110.975 +
110.976 + Calc ("op +", eval_binop "#add_"),
110.977 + Calc ("op *", eval_binop "#mult_"),
110.978 + Calc ("Atools.pow", eval_binop "#power_")
110.979 + ],
110.980 + scr = Script ((term_of o the o (parse thy)) scr_expand_binoms)
110.981 + }:rls;
110.982 +
110.983 +
110.984 +"******* Poly.ML end ******* ...RL";
110.985 +
110.986 +
110.987 +(**. MG.03: make_polynomial_ ... uses SML-fun for ordering .**)
110.988 +
110.989 +(*FIXME.0401: make SML-order local to make_polynomial(_) *)
110.990 +(*FIXME.0401: replace 'make_polynomial'(old) by 'make_polynomial_'(MG) *)
110.991 +(* Polynom --> List von Monomen *)
110.992 +fun poly2list (Const ("op +",_) $ t1 $ t2) =
110.993 + (poly2list t1) @ (poly2list t2)
110.994 + | poly2list t = [t];
110.995 +
110.996 +(* Monom --> Liste von Variablen *)
110.997 +fun monom2list (Const ("op *",_) $ t1 $ t2) =
110.998 + (monom2list t1) @ (monom2list t2)
110.999 + | monom2list t = [t];
110.1000 +
110.1001 +(* liefert Variablenname (String) einer Variablen und Basis bei Potenz *)
110.1002 +fun get_basStr (Const ("Atools.pow",_) $ Free (str, _) $ _) = str
110.1003 + | get_basStr (Free (str, _)) = str
110.1004 + | get_basStr t = "|||"; (* gross gewichtet; für Brüch ect. *)
110.1005 +(*| get_basStr t =
110.1006 + raise error("get_basStr: called with t= "^(term2str t));*)
110.1007 +
110.1008 +(* liefert Hochzahl (String) einer Variablen bzw Gewichtstring (zum Sortieren) *)
110.1009 +fun get_potStr (Const ("Atools.pow",_) $ Free _ $ Free (str, _)) = str
110.1010 + | get_potStr (Const ("Atools.pow",_) $ Free _ $ _ ) = "|||" (* gross gewichtet *)
110.1011 + | get_potStr (Free (str, _)) = "---" (* keine Hochzahl --> kleinst gewichtet *)
110.1012 + | get_potStr t = "||||||"; (* gross gewichtet; für Brüch ect. *)
110.1013 +(*| get_potStr t =
110.1014 + raise error("get_potStr: called with t= "^(term2str t));*)
110.1015 +
110.1016 +(* Umgekehrte string_ord *)
110.1017 +val string_ord_rev = rev_order o string_ord;
110.1018 +
110.1019 + (* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen)
110.1020 + innerhalb eines Monomes:
110.1021 + - zuerst lexikographisch nach Variablenname
110.1022 + - wenn gleich: nach steigender Potenz *)
110.1023 +fun var_ord (a,b: term) = prod_ord string_ord string_ord
110.1024 + ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b));
110.1025 +
110.1026 +(* Ordnung zum lexikographischen Vergleich zweier Variablen (oder Potenzen);
110.1027 + verwendet zum Sortieren von Monomen mittels Gesamtgradordnung:
110.1028 + - zuerst lexikographisch nach Variablenname
110.1029 + - wenn gleich: nach sinkender Potenz*)
110.1030 +fun var_ord_revPow (a,b: term) = prod_ord string_ord string_ord_rev
110.1031 + ((get_basStr a, get_potStr a), (get_basStr b, get_potStr b));
110.1032 +
110.1033 +
110.1034 +(* Ordnet ein Liste von Variablen (und Potenzen) lexikographisch *)
110.1035 +val sort_varList = sort var_ord;
110.1036 +
110.1037 +(* Entfernet aeussersten Operator (Wurzel) aus einem Term und schreibt
110.1038 + Argumente in eine Liste *)
110.1039 +fun args u : term list =
110.1040 + let fun stripc (f$t, ts) = stripc (f, t::ts)
110.1041 + | stripc (t as Free _, ts) = (t::ts)
110.1042 + | stripc (_, ts) = ts
110.1043 + in stripc (u, []) end;
110.1044 +
110.1045 +(* liefert True, falls der Term (Liste von Termen) nur Zahlen
110.1046 + (keine Variablen) enthaelt *)
110.1047 +fun filter_num [] = true
110.1048 + | filter_num [Free x] = if (is_num (Free x)) then true
110.1049 + else false
110.1050 + | filter_num ((Free _)::_) = false
110.1051 + | filter_num ts =
110.1052 + (filter_num o (filter_out is_num) o flat o (map args)) ts;
110.1053 +
110.1054 +(* liefert True, falls der Term nur Zahlen (keine Variablen) enthaelt
110.1055 + dh. er ist ein numerischer Wert und entspricht einem Koeffizienten *)
110.1056 +fun is_nums t = filter_num [t];
110.1057 +
110.1058 +(* Berechnet den Gesamtgrad eines Monoms *)
110.1059 +local
110.1060 + fun counter (n, []) = n
110.1061 + | counter (n, x :: xs) =
110.1062 + if (is_nums x) then
110.1063 + counter (n, xs)
110.1064 + else
110.1065 + (case x of
110.1066 + (Const ("Atools.pow", _) $ Free (str_b, _) $ Free (str_h, T)) =>
110.1067 + if (is_nums (Free (str_h, T))) then
110.1068 + counter (n + (the (int_of_str str_h)), xs)
110.1069 + else counter (n + 1000, xs) (*FIXME.MG?!*)
110.1070 + | (Const ("Atools.pow", _) $ Free (str_b, _) $ _ ) =>
110.1071 + counter (n + 1000, xs) (*FIXME.MG?!*)
110.1072 + | (Free (str, _)) => counter (n + 1, xs)
110.1073 + (*| _ => raise error("monom_degree: called with factor: "^(term2str x)))*)
110.1074 + | _ => counter (n + 10000, xs)) (*FIXME.MG?! ... Brüche ect.*)
110.1075 +in
110.1076 + fun monom_degree l = counter (0, l)
110.1077 +end;
110.1078 +
110.1079 +(* wie Ordnung dict_ord (lexicographische Ordnung zweier Listen, mit Vergleich
110.1080 + der Listen-Elemente mit elem_ord) - Elemente die Bedingung cond erfuellen,
110.1081 + werden jedoch dabei ignoriert (uebersprungen) *)
110.1082 +fun dict_cond_ord _ _ ([], []) = EQUAL
110.1083 + | dict_cond_ord _ _ ([], _ :: _) = LESS
110.1084 + | dict_cond_ord _ _ (_ :: _, []) = GREATER
110.1085 + | dict_cond_ord elem_ord cond (x :: xs, y :: ys) =
110.1086 + (case (cond x, cond y) of
110.1087 + (false, false) => (case elem_ord (x, y) of
110.1088 + EQUAL => dict_cond_ord elem_ord cond (xs, ys)
110.1089 + | ord => ord)
110.1090 + | (false, true) => dict_cond_ord elem_ord cond (x :: xs, ys)
110.1091 + | (true, false) => dict_cond_ord elem_ord cond (xs, y :: ys)
110.1092 + | (true, true) => dict_cond_ord elem_ord cond (xs, ys) );
110.1093 +
110.1094 +(* Gesamtgradordnung zum Vergleich von Monomen (Liste von Variablen/Potenzen):
110.1095 + zuerst nach Gesamtgrad, bei gleichem Gesamtgrad lexikographisch ordnen -
110.1096 + dabei werden Koeffizienten ignoriert (2*3*a^^^2*4*b gilt wie a^^^2*b) *)
110.1097 +fun degree_ord (xs, ys) =
110.1098 + prod_ord int_ord (dict_cond_ord var_ord_revPow is_nums)
110.1099 + ((monom_degree xs, xs), (monom_degree ys, ys));
110.1100 +
110.1101 +fun hd_str str = substring (str, 0, 1);
110.1102 +fun tl_str str = substring (str, 1, (size str) - 1);
110.1103 +
110.1104 +(* liefert nummerischen Koeffizienten eines Monoms oder NONE *)
110.1105 +fun get_koeff_of_mon [] = raise error("get_koeff_of_mon: called with l = []")
110.1106 + | get_koeff_of_mon (l as x::xs) = if is_nums x then SOME x
110.1107 + else NONE;
110.1108 +
110.1109 +(* wandelt Koeffizient in (zum sortieren geeigneten) String um *)
110.1110 +fun koeff2ordStr (SOME x) = (case x of
110.1111 + (Free (str, T)) =>
110.1112 + if (hd_str str) = "-" then (tl_str str)^"0" (* 3 < -3 *)
110.1113 + else str
110.1114 + | _ => "aaa") (* "num.Ausdruck" --> gross *)
110.1115 + | koeff2ordStr NONE = "---"; (* "kein Koeff" --> kleinste *)
110.1116 +
110.1117 +(* Order zum Vergleich von Koeffizienten (strings):
110.1118 + "kein Koeff" < "0" < "1" < "-1" < "2" < "-2" < ... < "num.Ausdruck" *)
110.1119 +fun compare_koeff_ord (xs, ys) =
110.1120 + string_ord ((koeff2ordStr o get_koeff_of_mon) xs,
110.1121 + (koeff2ordStr o get_koeff_of_mon) ys);
110.1122 +
110.1123 +(* Gesamtgradordnung degree_ord + Ordnen nach Koeffizienten falls EQUAL *)
110.1124 +fun koeff_degree_ord (xs, ys) =
110.1125 + prod_ord degree_ord compare_koeff_ord ((xs, xs), (ys, ys));
110.1126 +
110.1127 +(* Ordnet ein Liste von Monomen (Monom = Liste von Variablen) mittels
110.1128 + Gesamtgradordnung *)
110.1129 +val sort_monList = sort koeff_degree_ord;
110.1130 +
110.1131 +(* Alternativ zu degree_ord koennte auch die viel einfachere und
110.1132 + kuerzere Ordnung simple_ord verwendet werden - ist aber nicht
110.1133 + fuer unsere Zwecke geeignet!
110.1134 +
110.1135 +fun simple_ord (al,bl: term list) = dict_ord string_ord
110.1136 + (map get_basStr al, map get_basStr bl);
110.1137 +
110.1138 +val sort_monList = sort simple_ord; *)
110.1139 +
110.1140 +(* aus 2 Variablen wird eine Summe bzw ein Produkt erzeugt
110.1141 + (mit gewuenschtem Typen T) *)
110.1142 +fun plus T = Const ("op +", [T,T] ---> T);
110.1143 +fun mult T = Const ("op *", [T,T] ---> T);
110.1144 +fun binop op_ t1 t2 = op_ $ t1 $ t2;
110.1145 +fun create_prod T (a,b) = binop (mult T) a b;
110.1146 +fun create_sum T (a,b) = binop (plus T) a b;
110.1147 +
110.1148 +(* löscht letztes Element einer Liste *)
110.1149 +fun drop_last l = take ((length l)-1,l);
110.1150 +
110.1151 +(* Liste von Variablen --> Monom *)
110.1152 +fun create_monom T vl = foldr (create_prod T) (drop_last vl, last_elem vl);
110.1153 +(* Bemerkung:
110.1154 + foldr bewirkt rechtslastige Klammerung des Monoms - ist notwendig, damit zwei
110.1155 + gleiche Monome zusammengefasst werden können (collect_numerals)!
110.1156 + zB: 2*(x*(y*z)) + 3*(x*(y*z)) --> (2+3)*(x*(y*z))*)
110.1157 +
110.1158 +(* Liste von Monomen --> Polynom *)
110.1159 +fun create_polynom T ml = foldl (create_sum T) (hd ml, tl ml);
110.1160 +(* Bemerkung:
110.1161 + foldl bewirkt linkslastige Klammerung des Polynoms (der Summanten) -
110.1162 + bessere Darstellung, da keine Klammern sichtbar!
110.1163 + (und discard_parentheses in make_polynomial hat weniger zu tun) *)
110.1164 +
110.1165 +(* sorts the variables (faktors) of an expanded polynomial lexicographical *)
110.1166 +fun sort_variables t =
110.1167 + let
110.1168 + val ll = map monom2list (poly2list t);
110.1169 + val lls = map sort_varList ll;
110.1170 + val T = type_of t;
110.1171 + val ls = map (create_monom T) lls;
110.1172 + in create_polynom T ls end;
110.1173 +
110.1174 +(* sorts the monoms of an expanded and variable-sorted polynomial
110.1175 + by total_degree *)
110.1176 +fun sort_monoms t =
110.1177 + let
110.1178 + val ll = map monom2list (poly2list t);
110.1179 + val lls = sort_monList ll;
110.1180 + val T = type_of t;
110.1181 + val ls = map (create_monom T) lls;
110.1182 + in create_polynom T ls end;
110.1183 +
110.1184 +(* auch Klammerung muss übereinstimmen;
110.1185 + sort_variables klammert Produkte rechtslastig*)
110.1186 +fun is_multUnordered t = ((is_polyexp t) andalso not (t = sort_variables t));
110.1187 +
110.1188 +fun eval_is_multUnordered (thmid:string) _
110.1189 + (t as (Const("Poly.is'_multUnordered", _) $ arg)) thy =
110.1190 + if is_multUnordered arg
110.1191 + then SOME (mk_thmid thmid ""
110.1192 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
110.1193 + Trueprop $ (mk_equality (t, HOLogic.true_const)))
110.1194 + else SOME (mk_thmid thmid ""
110.1195 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
110.1196 + Trueprop $ (mk_equality (t, HOLogic.false_const)))
110.1197 + | eval_is_multUnordered _ _ _ _ = NONE;
110.1198 +
110.1199 +
110.1200 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
110.1201 + []:(rule * (term * term list)) list;
110.1202 +fun init_state (_:term) = e_rrlsstate;
110.1203 +fun locate_rule (_:rule list list) (_:term) (_:rule) =
110.1204 + ([]:(rule * (term * term list)) list);
110.1205 +fun next_rule (_:rule list list) (_:term) = (NONE:rule option);
110.1206 +fun normal_form t = SOME (sort_variables t,[]:term list);
110.1207 +
110.1208 +val order_mult_ =
110.1209 + Rrls {id = "order_mult_",
110.1210 + prepat =
110.1211 + [([(term_of o the o (parse thy)) "p is_multUnordered"],
110.1212 + (term_of o the o (parse thy)) "?p" )],
110.1213 + rew_ord = ("dummy_ord", dummy_ord),
110.1214 + erls = append_rls "e_rls-is_multUnordered" e_rls(*MG: poly_erls*)
110.1215 + [Calc ("Poly.is'_multUnordered", eval_is_multUnordered "")
110.1216 + ],
110.1217 + calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
110.1218 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
110.1219 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
110.1220 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
110.1221 + (*asm_thm=[],*)
110.1222 + scr=Rfuns {init_state = init_state,
110.1223 + normal_form = normal_form,
110.1224 + locate_rule = locate_rule,
110.1225 + next_rule = next_rule,
110.1226 + attach_form = attach_form}};
110.1227 +
110.1228 +val order_mult_rls_ =
110.1229 + Rls{id = "order_mult_rls_", preconds = [],
110.1230 + rew_ord = ("dummy_ord", dummy_ord),
110.1231 + erls = e_rls,srls = Erls,
110.1232 + calc = [],
110.1233 + (*asm_thm = [],*)
110.1234 + rules = [Rls_ order_mult_
110.1235 + ], scr = EmptyScr}:rls;
110.1236 +
110.1237 +fun is_addUnordered t = ((is_polyexp t) andalso not (t = sort_monoms t));
110.1238 +
110.1239 +(*WN.18.6.03 *)
110.1240 +(*("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered ""))*)
110.1241 +fun eval_is_addUnordered (thmid:string) _
110.1242 + (t as (Const("Poly.is'_addUnordered", _) $ arg)) thy =
110.1243 + if is_addUnordered arg
110.1244 + then SOME (mk_thmid thmid ""
110.1245 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
110.1246 + Trueprop $ (mk_equality (t, HOLogic.true_const)))
110.1247 + else SOME (mk_thmid thmid ""
110.1248 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
110.1249 + Trueprop $ (mk_equality (t, HOLogic.false_const)))
110.1250 + | eval_is_addUnordered _ _ _ _ = NONE;
110.1251 +
110.1252 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
110.1253 + []:(rule * (term * term list)) list;
110.1254 +fun init_state (_:term) = e_rrlsstate;
110.1255 +fun locate_rule (_:rule list list) (_:term) (_:rule) =
110.1256 + ([]:(rule * (term * term list)) list);
110.1257 +fun next_rule (_:rule list list) (_:term) = (NONE:rule option);
110.1258 +fun normal_form t = SOME (sort_monoms t,[]:term list);
110.1259 +
110.1260 +val order_add_ =
110.1261 + Rrls {id = "order_add_",
110.1262 + prepat = (*WN.18.6.03 Preconditions und Pattern,
110.1263 + die beide passen muessen, damit das Rrls angewandt wird*)
110.1264 + [([(term_of o the o (parse thy)) "p is_addUnordered"],
110.1265 + (term_of o the o (parse thy)) "?p"
110.1266 + (*WN.18.6.03 also KEIN pattern, dieses erzeugt nur das Environment
110.1267 + fuer die Evaluation der Precondition "p is_addUnordered"*))],
110.1268 + rew_ord = ("dummy_ord", dummy_ord),
110.1269 + erls = append_rls "e_rls-is_addUnordered" e_rls(*MG: poly_erls*)
110.1270 + [Calc ("Poly.is'_addUnordered", eval_is_addUnordered "")
110.1271 + (*WN.18.6.03 definiert in Poly.thy,
110.1272 + evaluiert prepat*)],
110.1273 + calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
110.1274 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
110.1275 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
110.1276 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
110.1277 + (*asm_thm=[],*)
110.1278 + scr=Rfuns {init_state = init_state,
110.1279 + normal_form = normal_form,
110.1280 + locate_rule = locate_rule,
110.1281 + next_rule = next_rule,
110.1282 + attach_form = attach_form}};
110.1283 +
110.1284 +val order_add_rls_ =
110.1285 + Rls{id = "order_add_rls_", preconds = [],
110.1286 + rew_ord = ("dummy_ord", dummy_ord),
110.1287 + erls = e_rls,srls = Erls,
110.1288 + calc = [],
110.1289 + (*asm_thm = [],*)
110.1290 + rules = [Rls_ order_add_
110.1291 + ], scr = EmptyScr}:rls;
110.1292 +
110.1293 +(*. see MG-DA.p.52ff .*)
110.1294 +val make_polynomial(*MG.03, overwrites version from above,
110.1295 + previously 'make_polynomial_'*) =
110.1296 + Seq {id = "make_polynomial", preconds = []:term list,
110.1297 + rew_ord = ("dummy_ord", dummy_ord),
110.1298 + erls = Atools_erls, srls = Erls,calc = [],
110.1299 + rules = [Rls_ discard_minus_,
110.1300 + Rls_ expand_poly_,
110.1301 + Calc ("op *", eval_binop "#mult_"),
110.1302 + Rls_ order_mult_rls_,
110.1303 + Rls_ simplify_power_,
110.1304 + Rls_ calc_add_mult_pow_,
110.1305 + Rls_ reduce_012_mult_,
110.1306 + Rls_ order_add_rls_,
110.1307 + Rls_ collect_numerals_,
110.1308 + Rls_ reduce_012_,
110.1309 + Rls_ discard_parentheses_
110.1310 + ],
110.1311 + scr = EmptyScr
110.1312 + }:rls;
110.1313 +val norm_Poly(*=make_polynomial*) =
110.1314 + Seq {id = "norm_Poly", preconds = []:term list,
110.1315 + rew_ord = ("dummy_ord", dummy_ord),
110.1316 + erls = Atools_erls, srls = Erls, calc = [],
110.1317 + rules = [Rls_ discard_minus_,
110.1318 + Rls_ expand_poly_,
110.1319 + Calc ("op *", eval_binop "#mult_"),
110.1320 + Rls_ order_mult_rls_,
110.1321 + Rls_ simplify_power_,
110.1322 + Rls_ calc_add_mult_pow_,
110.1323 + Rls_ reduce_012_mult_,
110.1324 + Rls_ order_add_rls_,
110.1325 + Rls_ collect_numerals_,
110.1326 + Rls_ reduce_012_,
110.1327 + Rls_ discard_parentheses_
110.1328 + ],
110.1329 + scr = EmptyScr
110.1330 + }:rls;
110.1331 +
110.1332 +(* MG:03 Like make_polynomial_ but without Rls_ discard_parentheses_
110.1333 + and expand_poly_rat_ instead of expand_poly_, see MG-DA.p.56ff*)
110.1334 +(* MG necessary for termination of norm_Rational(*_mg*) in Rational.ML*)
110.1335 +val make_rat_poly_with_parentheses =
110.1336 + Seq{id = "make_rat_poly_with_parentheses", preconds = []:term list,
110.1337 + rew_ord = ("dummy_ord", dummy_ord),
110.1338 + erls = Atools_erls, srls = Erls, calc = [],
110.1339 + rules = [Rls_ discard_minus_,
110.1340 + Rls_ expand_poly_rat_,(*ignors rationals*)
110.1341 + Calc ("op *", eval_binop "#mult_"),
110.1342 + Rls_ order_mult_rls_,
110.1343 + Rls_ simplify_power_,
110.1344 + Rls_ calc_add_mult_pow_,
110.1345 + Rls_ reduce_012_mult_,
110.1346 + Rls_ order_add_rls_,
110.1347 + Rls_ collect_numerals_,
110.1348 + Rls_ reduce_012_
110.1349 + (*Rls_ discard_parentheses_ *)
110.1350 + ],
110.1351 + scr = EmptyScr
110.1352 + }:rls;
110.1353 +
110.1354 +(*.a minimal ruleset for reverse rewriting of factions [2];
110.1355 + compare expand_binoms.*)
110.1356 +val rev_rew_p =
110.1357 +Seq{id = "reverse_rewriting", preconds = [], rew_ord = ("termlessI",termlessI),
110.1358 + erls = Atools_erls, srls = Erls,
110.1359 + calc = [(*("PLUS" , ("op +", eval_binop "#add_")),
110.1360 + ("TIMES" , ("op *", eval_binop "#mult_")),
110.1361 + ("POWER", ("Atools.pow", eval_binop "#power_"))*)
110.1362 + ],
110.1363 + rules = [Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
110.1364 + (*"(a + b)*(a + b) = a ^ 2 + 2 * a * b + b ^ 2*)
110.1365 + Thm ("real_plus_binom_times1" ,num_str real_plus_binom_times1),
110.1366 + (*"(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2"*)
110.1367 + Thm ("real_plus_binom_times2" ,num_str real_plus_binom_times2),
110.1368 + (*"(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2"*)
110.1369 +
110.1370 + Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*)
110.1371 +
110.1372 + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
110.1373 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
110.1374 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
110.1375 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
110.1376 +
110.1377 + Thm ("real_mult_assoc", num_str real_mult_assoc),
110.1378 + (*"?z1.1 * ?z2.1 * ?z3. =1 ?z1.1 * (?z2.1 * ?z3.1)"*)
110.1379 + Rls_ order_mult_rls_,
110.1380 + (*Rls_ order_add_rls_,*)
110.1381 +
110.1382 + Calc ("op +", eval_binop "#add_"),
110.1383 + Calc ("op *", eval_binop "#mult_"),
110.1384 + Calc ("Atools.pow", eval_binop "#power_"),
110.1385 +
110.1386 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
110.1387 + (*"r1 * r1 = r1 ^^^ 2"*)
110.1388 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
110.1389 + (*"z1 + z1 = 2 * z1"*)
110.1390 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
110.1391 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
110.1392 +
110.1393 + Thm ("real_num_collect",num_str real_num_collect),
110.1394 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
110.1395 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
110.1396 + (*"[| l is_const; m is_const |] ==>
110.1397 + l * n + (m * n + k) = (l + m) * n + k"*)
110.1398 + Thm ("real_one_collect",num_str real_one_collect),
110.1399 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
110.1400 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
110.1401 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
110.1402 +
110.1403 + Thm ("realpow_multI", num_str realpow_multI),
110.1404 + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
110.1405 +
110.1406 + Calc ("op +", eval_binop "#add_"),
110.1407 + Calc ("op *", eval_binop "#mult_"),
110.1408 + Calc ("Atools.pow", eval_binop "#power_"),
110.1409 +
110.1410 + Thm ("real_mult_1",num_str real_mult_1),(*"1 * z = z"*)
110.1411 + Thm ("real_mult_0",num_str real_mult_0),(*"0 * z = 0"*)
110.1412 + Thm ("real_add_zero_left",num_str real_add_zero_left)(*0 + z = z*)
110.1413 +
110.1414 + (*Rls_ order_add_rls_*)
110.1415 + ],
110.1416 +
110.1417 + scr = EmptyScr}:rls;
110.1418 +
110.1419 +ruleset' :=
110.1420 +overwritelthy thy (!ruleset',
110.1421 + [("norm_Poly", prep_rls norm_Poly),
110.1422 + ("Poly_erls",Poly_erls)(*FIXXXME:del with rls.rls'*),
110.1423 + ("expand", prep_rls expand),
110.1424 + ("expand_poly", prep_rls expand_poly),
110.1425 + ("simplify_power", prep_rls simplify_power),
110.1426 + ("order_add_mult", prep_rls order_add_mult),
110.1427 + ("collect_numerals", prep_rls collect_numerals),
110.1428 + ("collect_numerals_", prep_rls collect_numerals_),
110.1429 + ("reduce_012", prep_rls reduce_012),
110.1430 + ("discard_parentheses", prep_rls discard_parentheses),
110.1431 + ("make_polynomial", prep_rls make_polynomial),
110.1432 + ("expand_binoms", prep_rls expand_binoms),
110.1433 + ("rev_rew_p", prep_rls rev_rew_p),
110.1434 + ("discard_minus_", prep_rls discard_minus_),
110.1435 + ("expand_poly_", prep_rls expand_poly_),
110.1436 + ("expand_poly_rat_", prep_rls expand_poly_rat_),
110.1437 + ("simplify_power_", prep_rls simplify_power_),
110.1438 + ("calc_add_mult_pow_", prep_rls calc_add_mult_pow_),
110.1439 + ("reduce_012_mult_", prep_rls reduce_012_mult_),
110.1440 + ("reduce_012_", prep_rls reduce_012_),
110.1441 + ("discard_parentheses_",prep_rls discard_parentheses_),
110.1442 + ("order_mult_rls_", prep_rls order_mult_rls_),
110.1443 + ("order_add_rls_", prep_rls order_add_rls_),
110.1444 + ("make_rat_poly_with_parentheses",
110.1445 + prep_rls make_rat_poly_with_parentheses)
110.1446 + (*("", prep_rls ),
110.1447 + ("", prep_rls ),
110.1448 + ("", prep_rls )
110.1449 + *)
110.1450 + ]);
110.1451 +
110.1452 +calclist':= overwritel (!calclist',
110.1453 + [("is_polyrat_in", ("Poly.is'_polyrat'_in",
110.1454 + eval_is_polyrat_in "#eval_is_polyrat_in")),
110.1455 + ("is_expanded_in", ("Poly.is'_expanded'_in", eval_is_expanded_in "")),
110.1456 + ("is_poly_in", ("Poly.is'_poly'_in", eval_is_poly_in "")),
110.1457 + ("has_degree_in", ("Poly.has'_degree'_in", eval_has_degree_in "")),
110.1458 + ("is_polyexp", ("Poly.is'_polyexp", eval_is_polyexp "")),
110.1459 + ("is_multUnordered", ("Poly.is'_multUnordered", eval_is_multUnordered"")),
110.1460 + ("is_addUnordered", ("Poly.is'_addUnordered", eval_is_addUnordered ""))
110.1461 + ]);
110.1462 +
110.1463 +
110.1464 +(** problems **)
110.1465 +
110.1466 +store_pbt
110.1467 + (prep_pbt Poly.thy "pbl_simp_poly" [] e_pblID
110.1468 + (["polynomial","simplification"],
110.1469 + [("#Given" ,["term t_"]),
110.1470 + ("#Where" ,["t_ is_polyexp"]),
110.1471 + ("#Find" ,["normalform n_"])
110.1472 + ],
110.1473 + append_rls "e_rls" e_rls [(*for preds in where_*)
110.1474 + Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
110.1475 + SOME "Simplify t_",
110.1476 + [["simplification","for_polynomials"]]));
110.1477 +
110.1478 +
110.1479 +(** methods **)
110.1480 +
110.1481 +store_met
110.1482 + (prep_met Poly.thy "met_simp_poly" [] e_metID
110.1483 + (["simplification","for_polynomials"],
110.1484 + [("#Given" ,["term t_"]),
110.1485 + ("#Where" ,["t_ is_polyexp"]),
110.1486 + ("#Find" ,["normalform n_"])
110.1487 + ],
110.1488 + {rew_ord'="tless_true",
110.1489 + rls' = e_rls,
110.1490 + calc = [],
110.1491 + srls = e_rls,
110.1492 + prls = append_rls "simplification_for_polynomials_prls" e_rls
110.1493 + [(*for preds in where_*)
110.1494 + Calc ("Poly.is'_polyexp",eval_is_polyexp"")],
110.1495 + crls = e_rls, nrls = norm_Poly},
110.1496 + "Script SimplifyScript (t_::real) = \
110.1497 + \ ((Rewrite_Set norm_Poly False) t_)"
110.1498 + ));
111.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
111.2 +++ b/src/Tools/isac/Knowledge/Poly.thy Wed Aug 25 16:20:07 2010 +0200
111.3 @@ -0,0 +1,147 @@
111.4 +(* WN.020812: theorems in the Reals,
111.5 + necessary for special rule sets, in addition to Isabelle2002.
111.6 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
111.7 + !!! THIS IS THE _least_ NUMBER OF ADDITIONAL THEOREMS !!!
111.8 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
111.9 + xxxI contain ^^^ instead of ^ in the respective theorem xxx in 2002
111.10 + changed by: Richard Lang 020912
111.11 +*)
111.12 +
111.13 +(*
111.14 + use_thy"Knowledge/Poly";
111.15 + use_thy"Poly";
111.16 + use_thy_only"Knowledge/Poly";
111.17 +
111.18 + remove_thy"Poly";
111.19 + use_thy"Knowledge/Isac";
111.20 +
111.21 +
111.22 + use"ROOT.ML";
111.23 + cd"IsacKnowledge";
111.24 + *)
111.25 +
111.26 +Poly = Simplify +
111.27 +
111.28 +(*-------------------- consts-----------------------------------------------*)
111.29 +consts
111.30 +
111.31 + is'_expanded'_in :: "[real, real] => bool" ("_ is'_expanded'_in _")
111.32 + is'_poly'_in :: "[real, real] => bool" ("_ is'_poly'_in _") (*RL DA *)
111.33 + has'_degree'_in :: "[real, real] => real" ("_ has'_degree'_in _")(*RL DA *)
111.34 + is'_polyrat'_in :: "[real, real] => bool" ("_ is'_polyrat'_in _")(*RL030626*)
111.35 +
111.36 + is'_multUnordered :: "real => bool" ("_ is'_multUnordered")
111.37 + is'_addUnordered :: "real => bool" ("_ is'_addUnordered") (*WN030618*)
111.38 + is'_polyexp :: "real => bool" ("_ is'_polyexp")
111.39 +
111.40 + Expand'_binoms
111.41 + :: "['y, \
111.42 + \ 'y] => 'y"
111.43 + ("((Script Expand'_binoms (_ =))// \
111.44 + \ (_))" 9)
111.45 +
111.46 +(*-------------------- rules------------------------------------------------*)
111.47 +rules (*.not contained in Isabelle2002,
111.48 + stated as axioms, TODO: prove as theorems;
111.49 + theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*)
111.50 +
111.51 + realpow_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)"
111.52 + realpow_addI "r ^^^ (n + m) = r ^^^ n * r ^^^ m"
111.53 + realpow_addI_assoc_l "r ^^^ n * (r ^^^ m * s) = r ^^^ (n + m) * s"
111.54 + realpow_addI_assoc_r "s * r ^^^ n * r ^^^ m = s * r ^^^ (n + m)"
111.55 +
111.56 + realpow_oneI "r ^^^ 1 = r"
111.57 + realpow_zeroI "r ^^^ 0 = 1"
111.58 + realpow_eq_oneI "1 ^^^ n = 1"
111.59 + realpow_multI "(r * s) ^^^ n = r ^^^ n * s ^^^ n"
111.60 + realpow_multI_poly "[| r is_polyexp; s is_polyexp |] ==> \
111.61 + \(r * s) ^^^ n = r ^^^ n * s ^^^ n"
111.62 + realpow_minus_oneI "-1 ^^^ (2 * n) = 1"
111.63 +
111.64 + realpow_twoI "r ^^^ 2 = r * r"
111.65 + realpow_twoI_assoc_l "r * (r * s) = r ^^^ 2 * s"
111.66 + realpow_twoI_assoc_r "s * r * r = s * r ^^^ 2"
111.67 + realpow_two_atom "r is_atom ==> r * r = r ^^^ 2"
111.68 + realpow_plus_1 "r * r ^^^ n = r ^^^ (n + 1)"
111.69 + realpow_plus_1_assoc_l "r * (r ^^^ m * s) = r ^^^ (1 + m) * s"
111.70 + realpow_plus_1_assoc_l2 "r ^^^ m * (r * s) = r ^^^ (1 + m) * s"
111.71 + realpow_plus_1_assoc_r "s * r * r ^^^ m = s * r ^^^ (1 + m)"
111.72 + realpow_plus_1_atom "r is_atom ==> r * r ^^^ n = r ^^^ (1 + n)"
111.73 + realpow_def_atom "[| Not (r is_atom); 1 < n |] \
111.74 + \ ==> r ^^^ n = r * r ^^^ (n + -1)"
111.75 + realpow_addI_atom "r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"
111.76 +
111.77 +
111.78 + realpow_minus_even "n is_even ==> (- r) ^^^ n = r ^^^ n"
111.79 + realpow_minus_odd "Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"
111.80 +
111.81 +
111.82 +(* RL 020914 *)
111.83 + real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d"
111.84 + real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d"
111.85 + real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d"
111.86 + real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d"
111.87 + real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
111.88 + real_plus_binom_pow3_poly "[| a is_polyexp; b is_polyexp |] ==> \
111.89 + \(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
111.90 + real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3"
111.91 + real_minus_binom_pow3_p "(a + -1 * b)^^^3 = a^^^3 + -3*a^^^2*b + 3*a*b^^^2 + -1*b^^^3"
111.92 +(* real_plus_binom_pow "[| n is_const; 3 < n |] ==> \
111.93 + \(a + b)^^^n = (a + b) * (a + b)^^^(n - 1)" *)
111.94 + real_plus_binom_pow4 "(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)"
111.95 + real_plus_binom_pow4_poly "[| a is_polyexp; b is_polyexp |] ==> \
111.96 + \(a + b)^^^4 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a + b)"
111.97 + real_plus_binom_pow5 "(a + b)^^^5 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a^^^2 + 2*a*b + b^^^2)"
111.98 +
111.99 + real_plus_binom_pow5_poly "[| a is_polyexp; b is_polyexp |] ==> \
111.100 + \(a + b)^^^5 = (a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3)*(a^^^2 + 2*a*b + b^^^2)"
111.101 +
111.102 + real_diff_plus "a - b = a + -b" (*17.3.03: do_NOT_use*)
111.103 + real_diff_minus "a - b = a + -1 * b"
111.104 + real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2"
111.105 + real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2"
111.106 + (*WN071229 changed for Schaerding -----vvv*)
111.107 + (*real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"*)
111.108 + real_plus_binom_pow2 "(a + b)^^^2 = (a + b) * (a + b)"
111.109 + (*WN071229 changed for Schaerding -----^^^*)
111.110 + real_plus_binom_pow2_poly "[| a is_polyexp; b is_polyexp |] ==> \
111.111 + \(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"
111.112 + real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2"
111.113 + real_minus_binom_pow2_p "(a - b)^^^2 = a^^^2 + -2*a*b + b^^^2"
111.114 + real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2"
111.115 + real_plus_minus_binom1_p "(a + b)*(a - b) = a^^^2 + -1*b^^^2"
111.116 + real_plus_minus_binom1_p_p "(a + b)*(a + -1 * b) = a^^^2 + -1*b^^^2"
111.117 + real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2"
111.118 + real_plus_minus_binom2_p "(a - b)*(a + b) = a^^^2 + -1*b^^^2"
111.119 + real_plus_minus_binom2_p_p "(a + -1 * b)*(a + b) = a^^^2 + -1*b^^^2"
111.120 + real_plus_binom_times1 "(a + 1*b)*(a + -1*b) = a^^^2 + -1*b^^^2"
111.121 + real_plus_binom_times2 "(a + -1*b)*(a + 1*b) = a^^^2 + -1*b^^^2"
111.122 +
111.123 + real_num_collect "[| l is_const; m is_const |] ==> \
111.124 + \l * n + m * n = (l + m) * n"
111.125 +(* FIXME.MG.0401: replace 'real_num_collect_assoc'
111.126 + by 'real_num_collect_assoc_l' ... are equal, introduced by MG ! *)
111.127 + real_num_collect_assoc "[| l is_const; m is_const |] ==> \
111.128 + \l * n + (m * n + k) = (l + m) * n + k"
111.129 + real_num_collect_assoc_l "[| l is_const; m is_const |] ==> \
111.130 + \l * n + (m * n + k) = (l + m)
111.131 + * n + k"
111.132 + real_num_collect_assoc_r "[| l is_const; m is_const |] ==> \
111.133 + \(k + m * n) + l * n = k + (l + m) * n"
111.134 + real_one_collect "m is_const ==> n + m * n = (1 + m) * n"
111.135 +(* FIXME.MG.0401: replace 'real_one_collect_assoc'
111.136 + by 'real_one_collect_assoc_l' ... are equal, introduced by MG ! *)
111.137 + real_one_collect_assoc "m is_const ==> n + (m * n + k) = (1 + m)* n + k"
111.138 +
111.139 + real_one_collect_assoc_l "m is_const ==> n + (m * n + k) = (1 + m) * n + k"
111.140 + real_one_collect_assoc_r "m is_const ==>(k + n) + m * n = k + (1 + m) * n"
111.141 +
111.142 +(* FIXME.MG.0401: replace 'real_mult_2_assoc'
111.143 + by 'real_mult_2_assoc_l' ... are equal, introduced by MG ! *)
111.144 + real_mult_2_assoc "z1 + (z1 + k) = 2 * z1 + k"
111.145 + real_mult_2_assoc_l "z1 + (z1 + k) = 2 * z1 + k"
111.146 + real_mult_2_assoc_r "(k + z1) + z1 = k + 2 * z1"
111.147 +
111.148 + real_add_mult_distrib_poly "w is_polyexp ==> (z1 + z2) * w = z1 * w + z2 * w"
111.149 + real_add_mult_distrib2_poly "w is_polyexp ==> w * (z1 + z2) = w * z1 + w * z2"
111.150 +end
112.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
112.2 +++ b/src/Tools/isac/Knowledge/PolyEq.ML Wed Aug 25 16:20:07 2010 +0200
112.3 @@ -0,0 +1,1162 @@
112.4 +(*. (c) by Richard Lang, 2003 .*)
112.5 +(* collecting all knowledge for PolynomialEquations
112.6 + created by: rlang
112.7 + date: 02.07
112.8 + changed by: rlang
112.9 + last change by: rlang
112.10 + date: 02.11.26
112.11 +*)
112.12 +
112.13 +(* use"Knowledge/PolyEq.ML";
112.14 + use"PolyEq.ML";
112.15 +
112.16 + use"ROOT.ML";
112.17 + cd"IsacKnowledge";
112.18 +
112.19 + remove_thy"PolyEq";
112.20 + use_thy"Knowledge/Isac";
112.21 + *)
112.22 +"******* PolyEq.ML begin *******";
112.23 +
112.24 +theory' := overwritel (!theory', [("PolyEq.thy",PolyEq.thy)]);
112.25 +(*-------------------------functions---------------------*)
112.26 +(* just for try
112.27 +local
112.28 + fun add0 l d d_ = if (d_+1) < d then add0 (str2term"0"::l) d (d_+1) else l;
112.29 + fun poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("Atools.pow",_) $ v_ $ Free (d_,_)))) v l d =
112.30 + if (v=v_)
112.31 + then poly2list_ t1 v (((str2term("1")))::(add0 l d (int_of_str' d_))) (int_of_str' d_)
112.32 + else t::(add0 l d 0)
112.33 + | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $
112.34 + (Const ("Atools.pow",_) $ v_ $ Free (d_,_))))) v l d =
112.35 + if (v=v_)
112.36 + then poly2list_ t1 v (((t11))::(add0 l d (int_of_str' d_))) (int_of_str' d_)
112.37 + else t::(add0 l d 0)
112.38 + | poly2list_ (t as (Const ("op +",_) $ t1 $ (Free (v_ , _)) )) v l d =
112.39 + if (v = (str2term v_))
112.40 + then poly2list_ t1 v (((str2term("1")))::(add0 l d 1 )) 1
112.41 + else t::(add0 l d 0)
112.42 + | poly2list_ (t as (Const ("op +",_) $ t1 $ (Const ("op *",_) $ t11 $ (Free (v_,_)) ))) v l d =
112.43 + if (v= (str2term v_))
112.44 + then poly2list_ t1 v ( (t11)::(add0 l d 1 )) 1
112.45 + else t::(add0 l d 0)
112.46 + | poly2list_ (t as (Const ("op +",_) $ _ $ _))_ l d = t::(add0 l d 0)
112.47 + | poly2list_ (t as (Free (_,_))) _ l d = t::(add0 l d 0)
112.48 + | poly2list_ t _ l d = t::(add0 l d 0);
112.49 +
112.50 + fun poly2list t v = poly2list_ t v [] 0;
112.51 + fun diffpolylist_ [] _ = []
112.52 + | diffpolylist_ (x::xs) d = (str2term (if term2str(x)="0"
112.53 + then "0"
112.54 + else term2str(x)^"*"^str_of_int(d)))::diffpolylist_ xs (d+1);
112.55 + fun diffpolylist [] = []
112.56 + | diffpolylist (x::xs) = diffpolylist_ xs 1;
112.57 + (* diffpolylist(poly2list (str2term "1+ x +3*x^^^3") (str2term "x"));*)
112.58 +in
112.59 +
112.60 +end;
112.61 +*)
112.62 +(*-------------------------rulse-------------------------*)
112.63 +val PolyEq_prls = (*3.10.02:just the following order due to subterm evaluation*)
112.64 + append_rls "PolyEq_prls" e_rls
112.65 + [Calc ("Atools.ident",eval_ident "#ident_"),
112.66 + Calc ("Tools.matches",eval_matches ""),
112.67 + Calc ("Tools.lhs" ,eval_lhs ""),
112.68 + Calc ("Tools.rhs" ,eval_rhs ""),
112.69 + Calc ("Poly.is'_expanded'_in",eval_is_expanded_in ""),
112.70 + Calc ("Poly.is'_poly'_in",eval_is_poly_in ""),
112.71 + Calc ("Poly.has'_degree'_in",eval_has_degree_in ""),
112.72 + Calc ("Poly.is'_polyrat'_in",eval_is_polyrat_in ""),
112.73 + (*Calc ("Atools.occurs'_in",eval_occurs_in ""), *)
112.74 + (*Calc ("Atools.is'_const",eval_const "#is_const_"),*)
112.75 + Calc ("op =",eval_equal "#equal_"),
112.76 + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""),
112.77 + Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""),
112.78 + Thm ("not_true",num_str not_true),
112.79 + Thm ("not_false",num_str not_false),
112.80 + Thm ("and_true",num_str and_true),
112.81 + Thm ("and_false",num_str and_false),
112.82 + Thm ("or_true",num_str or_true),
112.83 + Thm ("or_false",num_str or_false)
112.84 + ];
112.85 +
112.86 +val PolyEq_erls =
112.87 + merge_rls "PolyEq_erls" LinEq_erls
112.88 + (append_rls "ops_preds" calculate_Rational
112.89 + [Calc ("op =",eval_equal "#equal_"),
112.90 + Thm ("plus_leq", num_str plus_leq),
112.91 + Thm ("minus_leq", num_str minus_leq),
112.92 + Thm ("rat_leq1", num_str rat_leq1),
112.93 + Thm ("rat_leq2", num_str rat_leq2),
112.94 + Thm ("rat_leq3", num_str rat_leq3)
112.95 + ]);
112.96 +
112.97 +val PolyEq_crls =
112.98 + merge_rls "PolyEq_crls" LinEq_crls
112.99 + (append_rls "ops_preds" calculate_Rational
112.100 + [Calc ("op =",eval_equal "#equal_"),
112.101 + Thm ("plus_leq", num_str plus_leq),
112.102 + Thm ("minus_leq", num_str minus_leq),
112.103 + Thm ("rat_leq1", num_str rat_leq1),
112.104 + Thm ("rat_leq2", num_str rat_leq2),
112.105 + Thm ("rat_leq3", num_str rat_leq3)
112.106 + ]);
112.107 +(*------
112.108 +val PolyEq_erls =
112.109 + merge_rls "PolyEq_erls"
112.110 + (append_rls "" (Rls {(*asm_thm=[],*)calc=[],
112.111 + erls= Rls {(*asm_thm=[],*)calc=[],
112.112 + erls= Erls,
112.113 + id="e_rls",preconds=[],
112.114 + rew_ord=("dummy_ord",dummy_ord),
112.115 + rules=[Thm ("",
112.116 + num_str ),
112.117 + Thm ("",
112.118 + num_str ),
112.119 + Thm ("",
112.120 + num_str )
112.121 + ],
112.122 + scr=EmptyScr,srls=Erls},
112.123 + id="e_rls",preconds=[],rew_ord=("dummy_ord",
112.124 + dummy_ord),
112.125 + rules=[],scr=EmptyScr,srls=Erls}
112.126 + )
112.127 + ((#rules o rep_rls) LinEq_erls))
112.128 + (append_rls "ops_preds" calculate_Rational
112.129 + [Calc ("op =",eval_equal "#equal_"),
112.130 + Thm ("plus_leq", num_str plus_leq),
112.131 + Thm ("minus_leq", num_str minus_leq),
112.132 + Thm ("rat_leq1", num_str rat_leq1),
112.133 + Thm ("rat_leq2", num_str rat_leq2),
112.134 + Thm ("rat_leq3", num_str rat_leq3)
112.135 + ]);
112.136 +-----*)
112.137 +
112.138 +
112.139 +val cancel_leading_coeff = prep_rls(
112.140 + Rls {id = "cancel_leading_coeff", preconds = [],
112.141 + rew_ord = ("e_rew_ord",e_rew_ord),
112.142 + erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*)
112.143 + rules = [Thm ("cancel_leading_coeff1",num_str cancel_leading_coeff1),
112.144 + Thm ("cancel_leading_coeff2",num_str cancel_leading_coeff2),
112.145 + Thm ("cancel_leading_coeff3",num_str cancel_leading_coeff3),
112.146 + Thm ("cancel_leading_coeff4",num_str cancel_leading_coeff4),
112.147 + Thm ("cancel_leading_coeff5",num_str cancel_leading_coeff5),
112.148 + Thm ("cancel_leading_coeff6",num_str cancel_leading_coeff6),
112.149 + Thm ("cancel_leading_coeff7",num_str cancel_leading_coeff7),
112.150 + Thm ("cancel_leading_coeff8",num_str cancel_leading_coeff8),
112.151 + Thm ("cancel_leading_coeff9",num_str cancel_leading_coeff9),
112.152 + Thm ("cancel_leading_coeff10",num_str cancel_leading_coeff10),
112.153 + Thm ("cancel_leading_coeff11",num_str cancel_leading_coeff11),
112.154 + Thm ("cancel_leading_coeff12",num_str cancel_leading_coeff12),
112.155 + Thm ("cancel_leading_coeff13",num_str cancel_leading_coeff13)
112.156 + ],
112.157 + scr = Script ((term_of o the o (parse thy))
112.158 + "empty_script")
112.159 + }:rls);
112.160 +val complete_square = prep_rls(
112.161 + Rls {id = "complete_square", preconds = [],
112.162 + rew_ord = ("e_rew_ord",e_rew_ord),
112.163 + erls = PolyEq_erls, srls = Erls, calc = [], (*asm_thm = [],*)
112.164 + rules = [Thm ("complete_square1",num_str complete_square1),
112.165 + Thm ("complete_square2",num_str complete_square2),
112.166 + Thm ("complete_square3",num_str complete_square3),
112.167 + Thm ("complete_square4",num_str complete_square4),
112.168 + Thm ("complete_square5",num_str complete_square5)
112.169 + ],
112.170 + scr = Script ((term_of o the o (parse thy))
112.171 + "empty_script")
112.172 + }:rls);
112.173 +ruleset' := overwritelthy thy (!ruleset',
112.174 + [("cancel_leading_coeff",cancel_leading_coeff),
112.175 + ("complete_square",complete_square),
112.176 + ("PolyEq_erls",PolyEq_erls)(*FIXXXME:del with rls.rls'*)
112.177 + ]);
112.178 +val polyeq_simplify = prep_rls(
112.179 + Rls {id = "polyeq_simplify", preconds = [],
112.180 + rew_ord = ("termlessI",termlessI),
112.181 + erls = PolyEq_erls,
112.182 + srls = Erls,
112.183 + calc = [],
112.184 + (*asm_thm = [],*)
112.185 + rules = [Thm ("real_assoc_1",num_str real_assoc_1),
112.186 + Thm ("real_assoc_2",num_str real_assoc_2),
112.187 + Thm ("real_diff_minus",num_str real_diff_minus),
112.188 + Thm ("real_unari_minus",num_str real_unari_minus),
112.189 + Thm ("realpow_multI",num_str realpow_multI),
112.190 + Calc ("op +",eval_binop "#add_"),
112.191 + Calc ("op -",eval_binop "#sub_"),
112.192 + Calc ("op *",eval_binop "#mult_"),
112.193 + Calc ("HOL.divide", eval_cancel "#divide_"),
112.194 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
112.195 + Calc ("Atools.pow" ,eval_binop "#power_"),
112.196 + Rls_ reduce_012
112.197 + ],
112.198 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.199 + }:rls);
112.200 +ruleset' := overwritelthy thy (!ruleset',
112.201 + [("polyeq_simplify",polyeq_simplify)]);
112.202 +
112.203 +
112.204 +(* ------------- polySolve ------------------ *)
112.205 +(* -- d0 -- *)
112.206 +(*isolate the bound variable in an d0 equation; 'bdv' is a meta-constant*)
112.207 +val d0_polyeq_simplify = prep_rls(
112.208 + Rls {id = "d0_polyeq_simplify", preconds = [],
112.209 + rew_ord = ("e_rew_ord",e_rew_ord),
112.210 + erls = PolyEq_erls,
112.211 + srls = Erls,
112.212 + calc = [],
112.213 + (*asm_thm = [],*)
112.214 + rules = [Thm("d0_true",num_str d0_true),
112.215 + Thm("d0_false",num_str d0_false)
112.216 + ],
112.217 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.218 + }:rls);
112.219 +(* -- d1 -- *)
112.220 +(*isolate the bound variable in an d1 equation; 'bdv' is a meta-constant*)
112.221 +val d1_polyeq_simplify = prep_rls(
112.222 + Rls {id = "d1_polyeq_simplify", preconds = [],
112.223 + rew_ord = ("e_rew_ord",e_rew_ord),
112.224 + erls = PolyEq_erls,
112.225 + srls = Erls,
112.226 + calc = [],
112.227 + (*asm_thm = [("d1_isolate_div","")],*)
112.228 + rules = [
112.229 + Thm("d1_isolate_add1",num_str d1_isolate_add1),
112.230 + (* a+bx=0 -> bx=-a *)
112.231 + Thm("d1_isolate_add2",num_str d1_isolate_add2),
112.232 + (* a+ x=0 -> x=-a *)
112.233 + Thm("d1_isolate_div",num_str d1_isolate_div)
112.234 + (* bx=c -> x=c/b *)
112.235 + ],
112.236 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.237 + }:rls);
112.238 +(* -- d2 -- *)
112.239 +(*isolate the bound variable in an d2 equation with bdv only; 'bdv' is a meta-constant*)
112.240 +val d2_polyeq_bdv_only_simplify = prep_rls(
112.241 + Rls {id = "d2_polyeq_bdv_only_simplify", preconds = [],
112.242 + rew_ord = ("e_rew_ord",e_rew_ord),
112.243 + erls = PolyEq_erls,
112.244 + srls = Erls,
112.245 + calc = [],
112.246 + (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""),
112.247 + ("d2_isolate_div","")],*)
112.248 + rules = [
112.249 + Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *)
112.250 + Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *)
112.251 + Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *)
112.252 + Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *)
112.253 + Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*)
112.254 + Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg), (* [0<c] x^2=c -> [] *)
112.255 + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *)
112.256 + Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*)
112.257 + Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*)
112.258 + Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*)
112.259 + ],
112.260 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.261 + }:rls);
112.262 +(*isolate the bound variable in an d2 equation with sqrt only; 'bdv' is a meta-constant*)
112.263 +val d2_polyeq_sq_only_simplify = prep_rls(
112.264 + Rls {id = "d2_polyeq_sq_only_simplify", preconds = [],
112.265 + rew_ord = ("e_rew_ord",e_rew_ord),
112.266 + erls = PolyEq_erls,
112.267 + srls = Erls,
112.268 + calc = [],
112.269 + (*asm_thm = [("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""),
112.270 + ("d2_isolate_div","")],*)
112.271 + rules = [
112.272 + Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*)
112.273 + Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*)
112.274 + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *)
112.275 + Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*)
112.276 + Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[] *)
112.277 + Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*)
112.278 + ],
112.279 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.280 + }:rls);
112.281 +(*isolate the bound variable in an d2 equation with pqFormula; 'bdv' is a meta-constant*)
112.282 +val d2_polyeq_pqFormula_simplify = prep_rls(
112.283 + Rls {id = "d2_polyeq_pqFormula_simplify", preconds = [],
112.284 + rew_ord = ("e_rew_ord",e_rew_ord),
112.285 + erls = PolyEq_erls,
112.286 + srls = Erls,
112.287 + calc = [],
112.288 + (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""),
112.289 + ("d2_pqformula5",""),("d2_pqformula6",""),("d2_pqformula7",""),("d2_pqformula8",""),
112.290 + ("d2_pqformula9",""),("d2_pqformula10",""),
112.291 + ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),
112.292 + ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""),("d2_pqformula10_neg","")],*)
112.293 + rules = [
112.294 + Thm("d2_pqformula1",num_str d2_pqformula1), (* q+px+ x^2=0 *)
112.295 + Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* q+px+ x^2=0 *)
112.296 + Thm("d2_pqformula2",num_str d2_pqformula2), (* q+px+1x^2=0 *)
112.297 + Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* q+px+1x^2=0 *)
112.298 + Thm("d2_pqformula3",num_str d2_pqformula3), (* q+ x+ x^2=0 *)
112.299 + Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* q+ x+ x^2=0 *)
112.300 + Thm("d2_pqformula4",num_str d2_pqformula4), (* q+ x+1x^2=0 *)
112.301 + Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* q+ x+1x^2=0 *)
112.302 + Thm("d2_pqformula5",num_str d2_pqformula5), (* qx+ x^2=0 *)
112.303 + Thm("d2_pqformula6",num_str d2_pqformula6), (* qx+1x^2=0 *)
112.304 + Thm("d2_pqformula7",num_str d2_pqformula7), (* x+ x^2=0 *)
112.305 + Thm("d2_pqformula8",num_str d2_pqformula8), (* x+1x^2=0 *)
112.306 + Thm("d2_pqformula9",num_str d2_pqformula9), (* q +1x^2=0 *)
112.307 + Thm("d2_pqformula9_neg",num_str d2_pqformula9_neg), (* q +1x^2=0 *)
112.308 + Thm("d2_pqformula10",num_str d2_pqformula10), (* q + x^2=0 *)
112.309 + Thm("d2_pqformula10_neg",num_str d2_pqformula10_neg), (* q + x^2=0 *)
112.310 + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *)
112.311 + Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* 1x^2=0 *)
112.312 + ],
112.313 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.314 + }:rls);
112.315 +(*isolate the bound variable in an d2 equation with abcFormula; 'bdv' is a meta-constant*)
112.316 +val d2_polyeq_abcFormula_simplify = prep_rls(
112.317 + Rls {id = "d2_polyeq_abcFormula_simplify", preconds = [],
112.318 + rew_ord = ("e_rew_ord",e_rew_ord),
112.319 + erls = PolyEq_erls,
112.320 + srls = Erls,
112.321 + calc = [],
112.322 + (*asm_thm = [("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""),
112.323 + ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""),
112.324 + ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""),
112.325 + ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""),
112.326 + ("d2_abcformula3_neg",""),("d2_abcformula4_neg",""),("d2_abcformula5_neg",""),
112.327 + ("d2_abcformula6_neg","")],*)
112.328 + rules = [
112.329 + Thm("d2_abcformula1",num_str d2_abcformula1), (*c+bx+cx^2=0 *)
112.330 + Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (*c+bx+cx^2=0 *)
112.331 + Thm("d2_abcformula2",num_str d2_abcformula2), (*c+ x+cx^2=0 *)
112.332 + Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (*c+ x+cx^2=0 *)
112.333 + Thm("d2_abcformula3",num_str d2_abcformula3), (*c+bx+ x^2=0 *)
112.334 + Thm("d2_abcformula3_neg",num_str d2_abcformula3_neg), (*c+bx+ x^2=0 *)
112.335 + Thm("d2_abcformula4",num_str d2_abcformula4), (*c+ x+ x^2=0 *)
112.336 + Thm("d2_abcformula4_neg",num_str d2_abcformula4_neg), (*c+ x+ x^2=0 *)
112.337 + Thm("d2_abcformula5",num_str d2_abcformula5), (*c+ cx^2=0 *)
112.338 + Thm("d2_abcformula5_neg",num_str d2_abcformula5_neg), (*c+ cx^2=0 *)
112.339 + Thm("d2_abcformula6",num_str d2_abcformula6), (*c+ x^2=0 *)
112.340 + Thm("d2_abcformula6_neg",num_str d2_abcformula6_neg), (*c+ x^2=0 *)
112.341 + Thm("d2_abcformula7",num_str d2_abcformula7), (* bx+ax^2=0 *)
112.342 + Thm("d2_abcformula8",num_str d2_abcformula8), (* bx+ x^2=0 *)
112.343 + Thm("d2_abcformula9",num_str d2_abcformula9), (* x+ax^2=0 *)
112.344 + Thm("d2_abcformula10",num_str d2_abcformula10), (* x+ x^2=0 *)
112.345 + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 *)
112.346 + Thm("d2_sqrt_equation3",num_str d2_sqrt_equation3) (* bx^2=0 *)
112.347 + ],
112.348 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.349 + }:rls);
112.350 +(*isolate the bound variable in an d2 equation; 'bdv' is a meta-constant*)
112.351 +val d2_polyeq_simplify = prep_rls(
112.352 + Rls {id = "d2_polyeq_simplify", preconds = [],
112.353 + rew_ord = ("e_rew_ord",e_rew_ord),
112.354 + erls = PolyEq_erls,
112.355 + srls = Erls,
112.356 + calc = [],
112.357 + (*asm_thm = [("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""),
112.358 + ("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),
112.359 + ("d2_pqformula4_neg",""),
112.360 + ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""),
112.361 + ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""),
112.362 + ("d2_sqrt_equation1_neg",""),("d2_isolate_div","")],*)
112.363 + rules = [
112.364 + Thm("d2_pqformula1",num_str d2_pqformula1), (* p+qx+ x^2=0 *)
112.365 + Thm("d2_pqformula1_neg",num_str d2_pqformula1_neg), (* p+qx+ x^2=0 *)
112.366 + Thm("d2_pqformula2",num_str d2_pqformula2), (* p+qx+1x^2=0 *)
112.367 + Thm("d2_pqformula2_neg",num_str d2_pqformula2_neg), (* p+qx+1x^2=0 *)
112.368 + Thm("d2_pqformula3",num_str d2_pqformula3), (* p+ x+ x^2=0 *)
112.369 + Thm("d2_pqformula3_neg",num_str d2_pqformula3_neg), (* p+ x+ x^2=0 *)
112.370 + Thm("d2_pqformula4",num_str d2_pqformula4), (* p+ x+1x^2=0 *)
112.371 + Thm("d2_pqformula4_neg",num_str d2_pqformula4_neg), (* p+ x+1x^2=0 *)
112.372 + Thm("d2_abcformula1",num_str d2_abcformula1), (* c+bx+cx^2=0 *)
112.373 + Thm("d2_abcformula1_neg",num_str d2_abcformula1_neg), (* c+bx+cx^2=0 *)
112.374 + Thm("d2_abcformula2",num_str d2_abcformula2), (* c+ x+cx^2=0 *)
112.375 + Thm("d2_abcformula2_neg",num_str d2_abcformula2_neg), (* c+ x+cx^2=0 *)
112.376 + Thm("d2_prescind1",num_str d2_prescind1), (* ax+bx^2=0 -> x(a+bx)=0 *)
112.377 + Thm("d2_prescind2",num_str d2_prescind2), (* ax+ x^2=0 -> x(a+ x)=0 *)
112.378 + Thm("d2_prescind3",num_str d2_prescind3), (* x+bx^2=0 -> x(1+bx)=0 *)
112.379 + Thm("d2_prescind4",num_str d2_prescind4), (* x+ x^2=0 -> x(1+ x)=0 *)
112.380 + Thm("d2_isolate_add1",num_str d2_isolate_add1), (* a+ bx^2=0 -> bx^2=(-1)a*)
112.381 + Thm("d2_isolate_add2",num_str d2_isolate_add2), (* a+ x^2=0 -> x^2=(-1)a*)
112.382 + Thm("d2_sqrt_equation1",num_str d2_sqrt_equation1), (* x^2=c -> x=+-sqrt(c)*)
112.383 + Thm("d2_sqrt_equation1_neg",num_str d2_sqrt_equation1_neg),(* [c<0] x^2=c -> x=[]*)
112.384 + Thm("d2_sqrt_equation2",num_str d2_sqrt_equation2), (* x^2=0 -> x=0 *)
112.385 + Thm("d2_reduce_equation1",num_str d2_reduce_equation1),(* x(a+bx)=0 -> x=0 | a+bx=0*)
112.386 + Thm("d2_reduce_equation2",num_str d2_reduce_equation2),(* x(a+ x)=0 -> x=0 | a+ x=0*)
112.387 + Thm("d2_isolate_div",num_str d2_isolate_div) (* bx^2=c -> x^2=c/b*)
112.388 + ],
112.389 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.390 + }:rls);
112.391 +(* -- d3 -- *)
112.392 +(*isolate the bound variable in an d3 equation; 'bdv' is a meta-constant*)
112.393 +val d3_polyeq_simplify = prep_rls(
112.394 + Rls {id = "d3_polyeq_simplify", preconds = [],
112.395 + rew_ord = ("e_rew_ord",e_rew_ord),
112.396 + erls = PolyEq_erls,
112.397 + srls = Erls,
112.398 + calc = [],
112.399 + (*asm_thm = [("d3_isolate_div","")],*)
112.400 + rules = [
112.401 + Thm("d3_reduce_equation1",num_str d3_reduce_equation1),
112.402 + (*a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0)*)
112.403 + Thm("d3_reduce_equation2",num_str d3_reduce_equation2),
112.404 + (* bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0)*)
112.405 + Thm("d3_reduce_equation3",num_str d3_reduce_equation3),
112.406 + (*a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0)*)
112.407 + Thm("d3_reduce_equation4",num_str d3_reduce_equation4),
112.408 + (* bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0)*)
112.409 + Thm("d3_reduce_equation5",num_str d3_reduce_equation5),
112.410 + (*a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0)*)
112.411 + Thm("d3_reduce_equation6",num_str d3_reduce_equation6),
112.412 + (* bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0)*)
112.413 + Thm("d3_reduce_equation7",num_str d3_reduce_equation7),
112.414 + (*a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*)
112.415 + Thm("d3_reduce_equation8",num_str d3_reduce_equation8),
112.416 + (* bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0)*)
112.417 + Thm("d3_reduce_equation9",num_str d3_reduce_equation9),
112.418 + (*a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0)*)
112.419 + Thm("d3_reduce_equation10",num_str d3_reduce_equation10),
112.420 + (* bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0)*)
112.421 + Thm("d3_reduce_equation11",num_str d3_reduce_equation11),
112.422 + (*a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0)*)
112.423 + Thm("d3_reduce_equation12",num_str d3_reduce_equation12),
112.424 + (* bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0)*)
112.425 + Thm("d3_reduce_equation13",num_str d3_reduce_equation13),
112.426 + (* b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0)*)
112.427 + Thm("d3_reduce_equation14",num_str d3_reduce_equation14),
112.428 + (* bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0)*)
112.429 + Thm("d3_reduce_equation15",num_str d3_reduce_equation15),
112.430 + (* b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0)*)
112.431 + Thm("d3_reduce_equation16",num_str d3_reduce_equation16),
112.432 + (* bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0)*)
112.433 + Thm("d3_isolate_add1",num_str d3_isolate_add1),
112.434 + (*[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (bdv=0 | (b*bdv^^^3=a)*)
112.435 + Thm("d3_isolate_add2",num_str d3_isolate_add2),
112.436 + (*[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = (bdv=0 | ( bdv^^^3=a)*)
112.437 + Thm("d3_isolate_div",num_str d3_isolate_div),
112.438 + (*[|Not(b=0)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b*)
112.439 + Thm("d3_root_equation2",num_str d3_root_equation2),
112.440 + (*(bdv^^^3=0) = (bdv=0) *)
112.441 + Thm("d3_root_equation1",num_str d3_root_equation1)
112.442 + (*bdv^^^3=c) = (bdv = nroot 3 c*)
112.443 + ],
112.444 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.445 + }:rls);
112.446 +(* -- d4 -- *)
112.447 +(*isolate the bound variable in an d4 equation; 'bdv' is a meta-constant*)
112.448 +val d4_polyeq_simplify = prep_rls(
112.449 + Rls {id = "d4_polyeq_simplify", preconds = [],
112.450 + rew_ord = ("e_rew_ord",e_rew_ord),
112.451 + erls = PolyEq_erls,
112.452 + srls = Erls,
112.453 + calc = [],
112.454 + (*asm_thm = [],*)
112.455 + rules = [Thm("d4_sub_u1",num_str d4_sub_u1)
112.456 + (* ax^4+bx^2+c=0 -> x=+-sqrt(ax^2+bx^+c) *)
112.457 + ],
112.458 + scr = Script ((term_of o the o (parse thy)) "empty_script")
112.459 + }:rls);
112.460 +
112.461 +ruleset' := overwritelthy thy (!ruleset',
112.462 + [("d0_polyeq_simplify", d0_polyeq_simplify),
112.463 + ("d1_polyeq_simplify", d1_polyeq_simplify),
112.464 + ("d2_polyeq_simplify", d2_polyeq_simplify),
112.465 + ("d2_polyeq_bdv_only_simplify", d2_polyeq_bdv_only_simplify),
112.466 + ("d2_polyeq_sq_only_simplify", d2_polyeq_sq_only_simplify),
112.467 + ("d2_polyeq_pqFormula_simplify", d2_polyeq_pqFormula_simplify),
112.468 + ("d2_polyeq_abcFormula_simplify", d2_polyeq_abcFormula_simplify),
112.469 + ("d3_polyeq_simplify", d3_polyeq_simplify),
112.470 + ("d4_polyeq_simplify", d4_polyeq_simplify)
112.471 + ]);
112.472 +
112.473 +(*------------------------problems------------------------*)
112.474 +(*
112.475 +(get_pbt ["degree_2","polynomial","univariate","equation"]);
112.476 +show_ptyps();
112.477 +*)
112.478 +
112.479 +(*-------------------------poly-----------------------*)
112.480 +store_pbt
112.481 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly" [] e_pblID
112.482 + (["polynomial","univariate","equation"],
112.483 + [("#Given" ,["equality e_","solveFor v_"]),
112.484 + ("#Where" ,["~((e_::bool) is_ratequation_in (v_::real))",
112.485 + "~((lhs e_) is_rootTerm_in (v_::real))",
112.486 + "~((rhs e_) is_rootTerm_in (v_::real))"]),
112.487 + ("#Find" ,["solutions v_i_"])
112.488 + ],
112.489 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.490 + []));
112.491 +(*--- d0 ---*)
112.492 +store_pbt
112.493 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg0" [] e_pblID
112.494 + (["degree_0","polynomial","univariate","equation"],
112.495 + [("#Given" ,["equality e_","solveFor v_"]),
112.496 + ("#Where" ,["matches (?a = 0) e_",
112.497 + "(lhs e_) is_poly_in v_",
112.498 + "((lhs e_) has_degree_in v_ ) = 0"
112.499 + ]),
112.500 + ("#Find" ,["solutions v_i_"])
112.501 + ],
112.502 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.503 + [["PolyEq","solve_d0_polyeq_equation"]]));
112.504 +
112.505 +(*--- d1 ---*)
112.506 +store_pbt
112.507 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg1" [] e_pblID
112.508 + (["degree_1","polynomial","univariate","equation"],
112.509 + [("#Given" ,["equality e_","solveFor v_"]),
112.510 + ("#Where" ,["matches (?a = 0) e_",
112.511 + "(lhs e_) is_poly_in v_",
112.512 + "((lhs e_) has_degree_in v_ ) = 1"
112.513 + ]),
112.514 + ("#Find" ,["solutions v_i_"])
112.515 + ],
112.516 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.517 + [["PolyEq","solve_d1_polyeq_equation"]]));
112.518 +
112.519 +(*--- d2 ---*)
112.520 +store_pbt
112.521 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2" [] e_pblID
112.522 + (["degree_2","polynomial","univariate","equation"],
112.523 + [("#Given" ,["equality e_","solveFor v_"]),
112.524 + ("#Where" ,["matches (?a = 0) e_",
112.525 + "(lhs e_) is_poly_in v_ ",
112.526 + "((lhs e_) has_degree_in v_ ) = 2"]),
112.527 + ("#Find" ,["solutions v_i_"])
112.528 + ],
112.529 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.530 + [["PolyEq","solve_d2_polyeq_equation"]]));
112.531 +
112.532 + store_pbt
112.533 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_sqonly" [] e_pblID
112.534 + (["sq_only","degree_2","polynomial","univariate","equation"],
112.535 + [("#Given" ,["equality e_","solveFor v_"]),
112.536 + ("#Where" ,["matches ( ?a + ?v_^^^2 = 0) e_ | \
112.537 + \matches ( ?a + ?b*?v_^^^2 = 0) e_ | \
112.538 + \matches ( ?v_^^^2 = 0) e_ | \
112.539 + \matches ( ?b*?v_^^^2 = 0) e_" ,
112.540 + "Not (matches (?a + ?v_ + ?v_^^^2 = 0) e_) &\
112.541 + \Not (matches (?a + ?b*?v_ + ?v_^^^2 = 0) e_) &\
112.542 + \Not (matches (?a + ?v_ + ?c*?v_^^^2 = 0) e_) &\
112.543 + \Not (matches (?a + ?b*?v_ + ?c*?v_^^^2 = 0) e_) &\
112.544 + \Not (matches ( ?v_ + ?v_^^^2 = 0) e_) &\
112.545 + \Not (matches ( ?b*?v_ + ?v_^^^2 = 0) e_) &\
112.546 + \Not (matches ( ?v_ + ?c*?v_^^^2 = 0) e_) &\
112.547 + \Not (matches ( ?b*?v_ + ?c*?v_^^^2 = 0) e_)"]),
112.548 + ("#Find" ,["solutions v_i_"])
112.549 + ],
112.550 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.551 + [["PolyEq","solve_d2_polyeq_sqonly_equation"]]));
112.552 +
112.553 +store_pbt
112.554 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_bdvonly" [] e_pblID
112.555 + (["bdv_only","degree_2","polynomial","univariate","equation"],
112.556 + [("#Given" ,["equality e_","solveFor v_"]),
112.557 + ("#Where" ,["matches (?a*?v_ + ?v_^^^2 = 0) e_ | \
112.558 + \matches ( ?v_ + ?v_^^^2 = 0) e_ | \
112.559 + \matches ( ?v_ + ?b*?v_^^^2 = 0) e_ | \
112.560 + \matches (?a*?v_ + ?b*?v_^^^2 = 0) e_ | \
112.561 + \matches ( ?v_^^^2 = 0) e_ | \
112.562 + \matches ( ?b*?v_^^^2 = 0) e_ "]),
112.563 + ("#Find" ,["solutions v_i_"])
112.564 + ],
112.565 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.566 + [["PolyEq","solve_d2_polyeq_bdvonly_equation"]]));
112.567 +
112.568 +store_pbt
112.569 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_pq" [] e_pblID
112.570 + (["pqFormula","degree_2","polynomial","univariate","equation"],
112.571 + [("#Given" ,["equality e_","solveFor v_"]),
112.572 + ("#Where" ,["matches (?a + 1*?v_^^^2 = 0) e_ | \
112.573 + \matches (?a + ?v_^^^2 = 0) e_"]),
112.574 + ("#Find" ,["solutions v_i_"])
112.575 + ],
112.576 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.577 + [["PolyEq","solve_d2_polyeq_pq_equation"]]));
112.578 +
112.579 +store_pbt
112.580 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg2_abc" [] e_pblID
112.581 + (["abcFormula","degree_2","polynomial","univariate","equation"],
112.582 + [("#Given" ,["equality e_","solveFor v_"]),
112.583 + ("#Where" ,["matches (?a + ?v_^^^2 = 0) e_ | \
112.584 + \matches (?a + ?b*?v_^^^2 = 0) e_"]),
112.585 + ("#Find" ,["solutions v_i_"])
112.586 + ],
112.587 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.588 + [["PolyEq","solve_d2_polyeq_abc_equation"]]));
112.589 +
112.590 +(*--- d3 ---*)
112.591 +store_pbt
112.592 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg3" [] e_pblID
112.593 + (["degree_3","polynomial","univariate","equation"],
112.594 + [("#Given" ,["equality e_","solveFor v_"]),
112.595 + ("#Where" ,["matches (?a = 0) e_",
112.596 + "(lhs e_) is_poly_in v_ ",
112.597 + "((lhs e_) has_degree_in v_) = 3"]),
112.598 + ("#Find" ,["solutions v_i_"])
112.599 + ],
112.600 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.601 + [["PolyEq","solve_d3_polyeq_equation"]]));
112.602 +
112.603 +(*--- d4 ---*)
112.604 +store_pbt
112.605 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_deg4" [] e_pblID
112.606 + (["degree_4","polynomial","univariate","equation"],
112.607 + [("#Given" ,["equality e_","solveFor v_"]),
112.608 + ("#Where" ,["matches (?a = 0) e_",
112.609 + "(lhs e_) is_poly_in v_ ",
112.610 + "((lhs e_) has_degree_in v_) = 4"]),
112.611 + ("#Find" ,["solutions v_i_"])
112.612 + ],
112.613 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.614 + [(*["PolyEq","solve_d4_polyeq_equation"]*)]));
112.615 +
112.616 +(*--- normalize ---*)
112.617 +store_pbt
112.618 + (prep_pbt PolyEq.thy "pbl_equ_univ_poly_norm" [] e_pblID
112.619 + (["normalize","polynomial","univariate","equation"],
112.620 + [("#Given" ,["equality e_","solveFor v_"]),
112.621 + ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\
112.622 + \(Not(((lhs e_) is_poly_in v_)))"]),
112.623 + ("#Find" ,["solutions v_i_"])
112.624 + ],
112.625 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.626 + [["PolyEq","normalize_poly"]]));
112.627 +(*-------------------------expanded-----------------------*)
112.628 +store_pbt
112.629 + (prep_pbt PolyEq.thy "pbl_equ_univ_expand" [] e_pblID
112.630 + (["expanded","univariate","equation"],
112.631 + [("#Given" ,["equality e_","solveFor v_"]),
112.632 + ("#Where" ,["matches (?a = 0) e_",
112.633 + "(lhs e_) is_expanded_in v_ "]),
112.634 + ("#Find" ,["solutions v_i_"])
112.635 + ],
112.636 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.637 + []));
112.638 +
112.639 +(*--- d2 ---*)
112.640 +store_pbt
112.641 + (prep_pbt PolyEq.thy "pbl_equ_univ_expand_deg2" [] e_pblID
112.642 + (["degree_2","expanded","univariate","equation"],
112.643 + [("#Given" ,["equality e_","solveFor v_"]),
112.644 + ("#Where" ,["((lhs e_) has_degree_in v_) = 2"]),
112.645 + ("#Find" ,["solutions v_i_"])
112.646 + ],
112.647 + PolyEq_prls, SOME "solve (e_::bool, v_)",
112.648 + [["PolyEq","complete_square"]]));
112.649 +
112.650 +
112.651 +"-------------------------methods-----------------------";
112.652 +store_met
112.653 + (prep_met PolyEq.thy "met_polyeq" [] e_metID
112.654 + (["PolyEq"],
112.655 + [],
112.656 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
112.657 + crls=PolyEq_crls, nrls=norm_Rational
112.658 + (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
112.659 +
112.660 +store_met
112.661 + (prep_met PolyEq.thy "met_polyeq_norm" [] e_metID
112.662 + (["PolyEq","normalize_poly"],
112.663 + [("#Given" ,["equality e_","solveFor v_"]),
112.664 + ("#Where" ,["(Not((matches (?a = 0 ) e_ ))) |\
112.665 + \(Not(((lhs e_) is_poly_in v_)))"]),
112.666 + ("#Find" ,["solutions v_i_"])
112.667 + ],
112.668 + {rew_ord'="termlessI",
112.669 + rls'=PolyEq_erls,
112.670 + srls=e_rls,
112.671 + prls=PolyEq_prls,
112.672 + calc=[],
112.673 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.674 + asm_rls=[],
112.675 + asm_thm=[]*)},
112.676 + (*RL: Ratpoly loest Brueche ohne bdv*)
112.677 + "Script Normalize_poly (e_::bool) (v_::real) = \
112.678 + \(let e_ =((Try (Rewrite all_left False)) @@ \
112.679 + \ (Try (Repeat (Rewrite makex1_x False))) @@ \
112.680 + \ (Try (Repeat (Rewrite_Set expand_binoms False))) @@ \
112.681 + \ (Try (Repeat (Rewrite_Set_Inst [(bdv,v_::real)] \
112.682 + \ make_ratpoly_in False))) @@ \
112.683 + \ (Try (Repeat (Rewrite_Set polyeq_simplify False)))) e_ \
112.684 + \ in (SubProblem (PolyEq_,[polynomial,univariate,equation], \
112.685 + \ [no_met]) [bool_ e_, real_ v_]))"
112.686 + ));
112.687 +
112.688 +store_met
112.689 + (prep_met PolyEq.thy "met_polyeq_d0" [] e_metID
112.690 + (["PolyEq","solve_d0_polyeq_equation"],
112.691 + [("#Given" ,["equality e_","solveFor v_"]),
112.692 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.693 + "((lhs e_) has_degree_in v_) = 0"]),
112.694 + ("#Find" ,["solutions v_i_"])
112.695 + ],
112.696 + {rew_ord'="termlessI",
112.697 + rls'=PolyEq_erls,
112.698 + srls=e_rls,
112.699 + prls=PolyEq_prls,
112.700 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.701 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.702 + asm_rls=[],
112.703 + asm_thm=[]*)},
112.704 + "Script Solve_d0_polyeq_equation (e_::bool) (v_::real) = \
112.705 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.706 + \ d0_polyeq_simplify False))) e_ \
112.707 + \ in ((Or_to_List e_)::bool list))"
112.708 + ));
112.709 +
112.710 +store_met
112.711 + (prep_met PolyEq.thy "met_polyeq_d1" [] e_metID
112.712 + (["PolyEq","solve_d1_polyeq_equation"],
112.713 + [("#Given" ,["equality e_","solveFor v_"]),
112.714 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.715 + "((lhs e_) has_degree_in v_) = 1"]),
112.716 + ("#Find" ,["solutions v_i_"])
112.717 + ],
112.718 + {rew_ord'="termlessI",
112.719 + rls'=PolyEq_erls,
112.720 + srls=e_rls,
112.721 + prls=PolyEq_prls,
112.722 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.723 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.724 + (* asm_rls=["d1_polyeq_simplify"],*)
112.725 + asm_rls=[],
112.726 + asm_thm=[("d1_isolate_div","")]*)},
112.727 + "Script Solve_d1_polyeq_equation (e_::bool) (v_::real) = \
112.728 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.729 + \ d1_polyeq_simplify True)) @@ \
112.730 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.731 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
112.732 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.733 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.734 + ));
112.735 +
112.736 +store_met
112.737 + (prep_met PolyEq.thy "met_polyeq_d22" [] e_metID
112.738 + (["PolyEq","solve_d2_polyeq_equation"],
112.739 + [("#Given" ,["equality e_","solveFor v_"]),
112.740 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.741 + "((lhs e_) has_degree_in v_) = 2"]),
112.742 + ("#Find" ,["solutions v_i_"])
112.743 + ],
112.744 + {rew_ord'="termlessI",
112.745 + rls'=PolyEq_erls,
112.746 + srls=e_rls,
112.747 + prls=PolyEq_prls,
112.748 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.749 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.750 + (*asm_rls=["d2_polyeq_simplify","d1_polyeq_simplify"],*)
112.751 + asm_rls=[],
112.752 + asm_thm = [("d1_isolate_div",""),("d2_pqformula1",""),("d2_pqformula2",""),
112.753 + ("d2_pqformula3",""),("d2_pqformula4",""),("d2_pqformula1_neg",""),
112.754 + ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),("d2_pqformula4_neg",""),
112.755 + ("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula1_neg",""),
112.756 + ("d2_abcformula2_neg",""), ("d2_sqrt_equation1",""),
112.757 + ("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)},
112.758 + "Script Solve_d2_polyeq_equation (e_::bool) (v_::real) = \
112.759 + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.760 + \ d2_polyeq_simplify True)) @@ \
112.761 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.762 + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.763 + \ d1_polyeq_simplify True)) @@ \
112.764 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.765 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
112.766 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.767 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.768 + ));
112.769 +
112.770 +store_met
112.771 + (prep_met PolyEq.thy "met_polyeq_d2_bdvonly" [] e_metID
112.772 + (["PolyEq","solve_d2_polyeq_bdvonly_equation"],
112.773 + [("#Given" ,["equality e_","solveFor v_"]),
112.774 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.775 + "((lhs e_) has_degree_in v_) = 2"]),
112.776 + ("#Find" ,["solutions v_i_"])
112.777 + ],
112.778 + {rew_ord'="termlessI",
112.779 + rls'=PolyEq_erls,
112.780 + srls=e_rls,
112.781 + prls=PolyEq_prls,
112.782 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.783 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.784 + (*asm_rls=["d2_polyeq_bdv_only_simplify","d1_polyeq_simplify "],*)
112.785 + asm_rls=[],
112.786 + asm_thm=[("d1_isolate_div",""),("d2_isolate_div",""),
112.787 + ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg","")]*)},
112.788 + "Script Solve_d2_polyeq_bdvonly_equation (e_::bool) (v_::real) =\
112.789 + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.790 + \ d2_polyeq_bdv_only_simplify True)) @@ \
112.791 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.792 + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.793 + \ d1_polyeq_simplify True)) @@ \
112.794 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.795 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
112.796 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.797 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.798 + ));
112.799 +
112.800 +store_met
112.801 + (prep_met PolyEq.thy "met_polyeq_d2_sqonly" [] e_metID
112.802 + (["PolyEq","solve_d2_polyeq_sqonly_equation"],
112.803 + [("#Given" ,["equality e_","solveFor v_"]),
112.804 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.805 + "((lhs e_) has_degree_in v_) = 2"]),
112.806 + ("#Find" ,["solutions v_i_"])
112.807 + ],
112.808 + {rew_ord'="termlessI",
112.809 + rls'=PolyEq_erls,
112.810 + srls=e_rls,
112.811 + prls=PolyEq_prls,
112.812 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.813 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.814 + (*asm_rls=["d2_polyeq_sq_only_simplify"],*)
112.815 + asm_rls=[],
112.816 + asm_thm=[("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""),
112.817 + ("d2_isolate_div","")]*)},
112.818 + "Script Solve_d2_polyeq_sqonly_equation (e_::bool) (v_::real) =\
112.819 + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.820 + \ d2_polyeq_sq_only_simplify True)) @@ \
112.821 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.822 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_; \
112.823 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.824 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.825 + ));
112.826 +
112.827 +store_met
112.828 + (prep_met PolyEq.thy "met_polyeq_d2_pq" [] e_metID
112.829 + (["PolyEq","solve_d2_polyeq_pq_equation"],
112.830 + [("#Given" ,["equality e_","solveFor v_"]),
112.831 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.832 + "((lhs e_) has_degree_in v_) = 2"]),
112.833 + ("#Find" ,["solutions v_i_"])
112.834 + ],
112.835 + {rew_ord'="termlessI",
112.836 + rls'=PolyEq_erls,
112.837 + srls=e_rls,
112.838 + prls=PolyEq_prls,
112.839 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.840 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.841 + (*asm_rls=["d2_polyeq_pqFormula_simplify"],*)
112.842 + asm_rls=[],
112.843 + asm_thm=[("d2_pqformula1",""),("d2_pqformula2",""),("d2_pqformula3",""),
112.844 + ("d2_pqformula4",""),("d2_pqformula5",""),("d2_pqformula6",""),
112.845 + ("d2_pqformula7",""),("d2_pqformula8",""),("d2_pqformula9",""),
112.846 + ("d2_pqformula10",""),("d2_pqformula1_neg",""),("d2_pqformula2_neg",""),
112.847 + ("d2_pqformula3_neg",""), ("d2_pqformula4_neg",""),("d2_pqformula9_neg",""),
112.848 + ("d2_pqformula10_neg","")]*)},
112.849 + "Script Solve_d2_polyeq_pq_equation (e_::bool) (v_::real) = \
112.850 + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.851 + \ d2_polyeq_pqFormula_simplify True)) @@ \
112.852 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.853 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
112.854 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.855 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.856 + ));
112.857 +
112.858 +store_met
112.859 + (prep_met PolyEq.thy "met_polyeq_d2_abc" [] e_metID
112.860 + (["PolyEq","solve_d2_polyeq_abc_equation"],
112.861 + [("#Given" ,["equality e_","solveFor v_"]),
112.862 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.863 + "((lhs e_) has_degree_in v_) = 2"]),
112.864 + ("#Find" ,["solutions v_i_"])
112.865 + ],
112.866 + {rew_ord'="termlessI",
112.867 + rls'=PolyEq_erls,
112.868 + srls=e_rls,
112.869 + prls=PolyEq_prls,
112.870 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.871 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.872 + (*asm_rls=["d2_polyeq_abcFormula_simplify"],*)
112.873 + asm_rls=[],
112.874 + asm_thm=[("d2_abcformula1",""),("d2_abcformula2",""),("d2_abcformula3",""),
112.875 + ("d2_abcformula4",""),("d2_abcformula5",""),("d2_abcformula6",""),
112.876 + ("d2_abcformula7",""),("d2_abcformula8",""),("d2_abcformula9",""),
112.877 + ("d2_abcformula10",""),("d2_abcformula1_neg",""),("d2_abcformula2_neg",""),
112.878 + ("d2_abcformula3_neg",""), ("d2_abcformula4_neg",""),("d2_abcformula5_neg",""),
112.879 + ("d2_abcformula6_neg","")]*)},
112.880 + "Script Solve_d2_polyeq_abc_equation (e_::bool) (v_::real) = \
112.881 + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.882 + \ d2_polyeq_abcFormula_simplify True)) @@ \
112.883 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.884 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
112.885 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.886 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.887 + ));
112.888 +
112.889 +store_met
112.890 + (prep_met PolyEq.thy "met_polyeq_d3" [] e_metID
112.891 + (["PolyEq","solve_d3_polyeq_equation"],
112.892 + [("#Given" ,["equality e_","solveFor v_"]),
112.893 + ("#Where" ,["(lhs e_) is_poly_in v_ ",
112.894 + "((lhs e_) has_degree_in v_) = 3"]),
112.895 + ("#Find" ,["solutions v_i_"])
112.896 + ],
112.897 + {rew_ord'="termlessI",
112.898 + rls'=PolyEq_erls,
112.899 + srls=e_rls,
112.900 + prls=PolyEq_prls,
112.901 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.902 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.903 + (* asm_rls=["d1_polyeq_simplify","d2_polyeq_simplify","d1_polyeq_simplify"],*)
112.904 + asm_rls=[],
112.905 + asm_thm=[("d3_isolate_div",""),("d1_isolate_div",""),("d2_pqformula1",""),
112.906 + ("d2_pqformula2",""),("d2_pqformula3",""),("d2_pqformula4",""),
112.907 + ("d2_pqformula1_neg",""), ("d2_pqformula2_neg",""),("d2_pqformula3_neg",""),
112.908 + ("d2_pqformula4_neg",""), ("d2_abcformula1",""),("d2_abcformula2",""),
112.909 + ("d2_abcformula1_neg",""),("d2_abcformula2_neg",""),
112.910 + ("d2_sqrt_equation1",""),("d2_sqrt_equation1_neg",""), ("d2_isolate_div","")]*)},
112.911 + "Script Solve_d3_polyeq_equation (e_::bool) (v_::real) = \
112.912 + \ (let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.913 + \ d3_polyeq_simplify True)) @@ \
112.914 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.915 + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.916 + \ d2_polyeq_simplify True)) @@ \
112.917 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.918 + \ (Try (Rewrite_Set_Inst [(bdv,v_::real)] \
112.919 + \ d1_polyeq_simplify True)) @@ \
112.920 + \ (Try (Rewrite_Set polyeq_simplify False)) @@ \
112.921 + \ (Try (Rewrite_Set norm_Rational_parenthesized False))) e_;\
112.922 + \ (L_::bool list) = ((Or_to_List e_)::bool list) \
112.923 + \ in Check_elementwise L_ {(v_::real). Assumptions} )"
112.924 + ));
112.925 +
112.926 + (*.solves all expanded (ie. normalized) terms of degree 2.*)
112.927 + (*Oct.02 restriction: 'eval_true 0 =< discriminant' ony for integer values
112.928 + by 'PolyEq_erls'; restricted until Float.thy is implemented*)
112.929 +store_met
112.930 + (prep_met PolyEq.thy "met_polyeq_complsq" [] e_metID
112.931 + (["PolyEq","complete_square"],
112.932 + [("#Given" ,["equality e_","solveFor v_"]),
112.933 + ("#Where" ,["matches (?a = 0) e_",
112.934 + "((lhs e_) has_degree_in v_) = 2"]),
112.935 + ("#Find" ,["solutions v_i_"])
112.936 + ],
112.937 + {rew_ord'="termlessI",rls'=PolyEq_erls,srls=e_rls,prls=PolyEq_prls,
112.938 + calc=[("sqrt", ("Root.sqrt", eval_sqrt "#sqrt_"))],
112.939 + crls=PolyEq_crls, nrls=norm_Rational(*,
112.940 + asm_rls=[],
112.941 + asm_thm=[("root_plus_minus","")]*)},
112.942 + "Script Complete_square (e_::bool) (v_::real) = \
112.943 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\
112.944 + \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \
112.945 + \ @@ (Try (Rewrite square_explicit1 False)) \
112.946 + \ @@ (Try (Rewrite square_explicit2 False)) \
112.947 + \ @@ (Rewrite root_plus_minus True) \
112.948 + \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False))) \
112.949 + \ @@ (Try (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \
112.950 + \ @@ (Try (Repeat \
112.951 + \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \
112.952 + \ @@ (Try (Rewrite_Set calculate_RootRat False)) \
112.953 + \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \
112.954 + \ in ((Or_to_List e_)::bool list))"
112.955 + ));
112.956 +(*6.10.02: x^2=64: root_plus_minus -/-/->
112.957 + "Script Complete_square (e_::bool) (v_::real) = \
112.958 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_)] cancel_leading_coeff True))\
112.959 + \ @@ (Try (Rewrite_Set_Inst [(bdv,v_)] complete_square True)) \
112.960 + \ @@ (Try ((Rewrite square_explicit1 False) \
112.961 + \ Or (Rewrite square_explicit2 False))) \
112.962 + \ @@ (Rewrite root_plus_minus True) \
112.963 + \ @@ ((Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit1 False)) \
112.964 + \ Or (Repeat (Rewrite_Inst [(bdv,v_)] bdv_explicit2 False))) \
112.965 + \ @@ (Try (Repeat \
112.966 + \ (Rewrite_Inst [(bdv,v_)] bdv_explicit3 False))) \
112.967 + \ @@ (Try (Rewrite_Set calculate_RootRat False)) \
112.968 + \ @@ (Try (Repeat (Calculate sqrt_)))) e_ \
112.969 + \ in ((Or_to_List e_)::bool list))"*)
112.970 +
112.971 +"******* PolyEq.ML end *******";
112.972 +
112.973 +(*eine gehackte termorder*)
112.974 +local (*. for make_polynomial_in .*)
112.975 +
112.976 +open Term; (* for type order = EQUAL | LESS | GREATER *)
112.977 +
112.978 +fun pr_ord EQUAL = "EQUAL"
112.979 + | pr_ord LESS = "LESS"
112.980 + | pr_ord GREATER = "GREATER";
112.981 +
112.982 +fun dest_hd' x (Const (a, T)) = (((a, 0), T), 0)
112.983 + | dest_hd' x (t as Free (a, T)) =
112.984 + if x = t then ((("|||||||||||||", 0), T), 0) (*WN*)
112.985 + else (((a, 0), T), 1)
112.986 + | dest_hd' x (Var v) = (v, 2)
112.987 + | dest_hd' x (Bound i) = ((("", i), dummyT), 3)
112.988 + | dest_hd' x (Abs (_, T, _)) = ((("", 0), T), 4);
112.989 +
112.990 +fun size_of_term' x (Const ("Atools.pow",_) $ Free (var,_) $ Free (pot,_)) =
112.991 + (case x of (*WN*)
112.992 + (Free (xstr,_)) =>
112.993 + (if xstr = var then 1000*(the (int_of_str pot)) else 3)
112.994 + | _ => raise error ("size_of_term' called with subst = "^
112.995 + (term2str x)))
112.996 + | size_of_term' x (Free (subst,_)) =
112.997 + (case x of
112.998 + (Free (xstr,_)) => (if xstr = subst then 1000 else 1)
112.999 + | _ => raise error ("size_of_term' called with subst = "^
112.1000 + (term2str x)))
112.1001 + | size_of_term' x (Abs (_,_,body)) = 1 + size_of_term' x body
112.1002 + | size_of_term' x (f$t) = size_of_term' x f + size_of_term' x t
112.1003 + | size_of_term' x _ = 1;
112.1004 +
112.1005 +
112.1006 +fun term_ord' x pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
112.1007 + (case term_ord' x pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
112.1008 + | term_ord' x pr thy (t, u) =
112.1009 + (if pr then
112.1010 + let
112.1011 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
112.1012 + val _=writeln("t= f@ts= \""^
112.1013 + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
112.1014 + (commas(map(string_of_cterm o cterm_of(sign_of thy)) ts))^"]\"");
112.1015 + val _=writeln("u= g@us= \""^
112.1016 + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
112.1017 + (commas(map(string_of_cterm o cterm_of(sign_of thy)) us))^"]\"");
112.1018 + val _=writeln("size_of_term(t,u)= ("^
112.1019 + (string_of_int(size_of_term' x t))^", "^
112.1020 + (string_of_int(size_of_term' x u))^")");
112.1021 + val _=writeln("hd_ord(f,g) = "^((pr_ord o (hd_ord x))(f,g)));
112.1022 + val _=writeln("terms_ord(ts,us) = "^
112.1023 + ((pr_ord o (terms_ord x) str false)(ts,us)));
112.1024 + val _=writeln("-------");
112.1025 + in () end
112.1026 + else ();
112.1027 + case int_ord (size_of_term' x t, size_of_term' x u) of
112.1028 + EQUAL =>
112.1029 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
112.1030 + (case hd_ord x (f, g) of EQUAL => (terms_ord x str pr) (ts, us)
112.1031 + | ord => ord)
112.1032 + end
112.1033 + | ord => ord)
112.1034 +and hd_ord x (f, g) = (* ~ term.ML *)
112.1035 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' x f,
112.1036 + dest_hd' x g)
112.1037 +and terms_ord x str pr (ts, us) =
112.1038 + list_ord (term_ord' x pr (assoc_thy "Isac.thy"))(ts, us);
112.1039 +(*val x = (term_of o the o (parse thy)) "x"; (*FIXXXXXXME*)
112.1040 +*)
112.1041 +
112.1042 +in
112.1043 +
112.1044 +fun ord_make_polynomial_in (pr:bool) thy subst tu =
112.1045 + let
112.1046 + (* val _=writeln("*** subs variable is: "^(subst2str subst)); *)
112.1047 + in
112.1048 + case subst of
112.1049 + (_,x)::_ => (term_ord' x pr thy tu = LESS)
112.1050 + | _ => raise error ("ord_make_polynomial_in called with subst = "^
112.1051 + (subst2str subst))
112.1052 + end;
112.1053 +end;
112.1054 +
112.1055 +val order_add_mult_in = prep_rls(
112.1056 + Rls{id = "order_add_mult_in", preconds = [],
112.1057 + rew_ord = ("ord_make_polynomial_in",
112.1058 + ord_make_polynomial_in false Poly.thy),
112.1059 + erls = e_rls,srls = Erls,
112.1060 + calc = [],
112.1061 + (*asm_thm = [],*)
112.1062 + rules = [Thm ("real_mult_commute",num_str real_mult_commute),
112.1063 + (* z * w = w * z *)
112.1064 + Thm ("real_mult_left_commute",num_str real_mult_left_commute),
112.1065 + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
112.1066 + Thm ("real_mult_assoc",num_str real_mult_assoc),
112.1067 + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
112.1068 + Thm ("real_add_commute",num_str real_add_commute),
112.1069 + (*z + w = w + z*)
112.1070 + Thm ("real_add_left_commute",num_str real_add_left_commute),
112.1071 + (*x + (y + z) = y + (x + z)*)
112.1072 + Thm ("real_add_assoc",num_str real_add_assoc)
112.1073 + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
112.1074 + ], scr = EmptyScr}:rls);
112.1075 +
112.1076 +val collect_bdv = prep_rls(
112.1077 + Rls{id = "collect_bdv", preconds = [],
112.1078 + rew_ord = ("dummy_ord", dummy_ord),
112.1079 + erls = e_rls,srls = Erls,
112.1080 + calc = [],
112.1081 + (*asm_thm = [],*)
112.1082 + rules = [Thm ("bdv_collect_1",num_str bdv_collect_1),
112.1083 + Thm ("bdv_collect_2",num_str bdv_collect_2),
112.1084 + Thm ("bdv_collect_3",num_str bdv_collect_3),
112.1085 +
112.1086 + Thm ("bdv_collect_assoc1_1",num_str bdv_collect_assoc1_1),
112.1087 + Thm ("bdv_collect_assoc1_2",num_str bdv_collect_assoc1_2),
112.1088 + Thm ("bdv_collect_assoc1_3",num_str bdv_collect_assoc1_3),
112.1089 +
112.1090 + Thm ("bdv_collect_assoc2_1",num_str bdv_collect_assoc2_1),
112.1091 + Thm ("bdv_collect_assoc2_2",num_str bdv_collect_assoc2_2),
112.1092 + Thm ("bdv_collect_assoc2_3",num_str bdv_collect_assoc2_3),
112.1093 +
112.1094 +
112.1095 + Thm ("bdv_n_collect_1",num_str bdv_n_collect_1),
112.1096 + Thm ("bdv_n_collect_2",num_str bdv_n_collect_2),
112.1097 + Thm ("bdv_n_collect_3",num_str bdv_n_collect_3),
112.1098 +
112.1099 + Thm ("bdv_n_collect_assoc1_1",num_str bdv_n_collect_assoc1_1),
112.1100 + Thm ("bdv_n_collect_assoc1_2",num_str bdv_n_collect_assoc1_2),
112.1101 + Thm ("bdv_n_collect_assoc1_3",num_str bdv_n_collect_assoc1_3),
112.1102 +
112.1103 + Thm ("bdv_n_collect_assoc2_1",num_str bdv_n_collect_assoc2_1),
112.1104 + Thm ("bdv_n_collect_assoc2_2",num_str bdv_n_collect_assoc2_2),
112.1105 + Thm ("bdv_n_collect_assoc2_3",num_str bdv_n_collect_assoc2_3)
112.1106 + ], scr = EmptyScr}:rls);
112.1107 +
112.1108 +(*.transforms an arbitrary term without roots to a polynomial [4]
112.1109 + according to knowledge/Poly.sml.*)
112.1110 +val make_polynomial_in = prep_rls(
112.1111 + Seq {id = "make_polynomial_in", preconds = []:term list,
112.1112 + rew_ord = ("dummy_ord", dummy_ord),
112.1113 + erls = Atools_erls, srls = Erls,
112.1114 + calc = [], (*asm_thm = [],*)
112.1115 + rules = [Rls_ expand_poly,
112.1116 + Rls_ order_add_mult_in,
112.1117 + Rls_ simplify_power,
112.1118 + Rls_ collect_numerals,
112.1119 + Rls_ reduce_012,
112.1120 + Thm ("realpow_oneI",num_str realpow_oneI),
112.1121 + Rls_ discard_parentheses,
112.1122 + Rls_ collect_bdv
112.1123 + ],
112.1124 + scr = EmptyScr
112.1125 + }:rls);
112.1126 +
112.1127 +val separate_bdvs =
112.1128 + append_rls "separate_bdvs"
112.1129 + collect_bdv
112.1130 + [Thm ("separate_bdv", num_str separate_bdv),
112.1131 + (*"?a * ?bdv / ?b = ?a / ?b * ?bdv"*)
112.1132 + Thm ("separate_bdv_n", num_str separate_bdv_n),
112.1133 + Thm ("separate_1_bdv", num_str separate_1_bdv),
112.1134 + (*"?bdv / ?b = (1 / ?b) * ?bdv"*)
112.1135 + Thm ("separate_1_bdv_n", num_str separate_1_bdv_n),
112.1136 + (*"?bdv ^^^ ?n / ?b = 1 / ?b * ?bdv ^^^ ?n"*)
112.1137 + Thm ("real_add_divide_distrib",
112.1138 + num_str real_add_divide_distrib)
112.1139 + (*"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"
112.1140 + WN051031 DOES NOT BELONG TO HERE*)
112.1141 + ];
112.1142 +val make_ratpoly_in = prep_rls(
112.1143 + Seq {id = "make_ratpoly_in", preconds = []:term list,
112.1144 + rew_ord = ("dummy_ord", dummy_ord),
112.1145 + erls = Atools_erls, srls = Erls,
112.1146 + calc = [], (*asm_thm = [],*)
112.1147 + rules = [Rls_ norm_Rational,
112.1148 + Rls_ order_add_mult_in,
112.1149 + Rls_ discard_parentheses,
112.1150 + Rls_ separate_bdvs,
112.1151 + (* Rls_ rearrange_assoc, WN060916 why does cancel_p not work?*)
112.1152 + Rls_ cancel_p
112.1153 + (*Calc ("HOL.divide" ,eval_cancel "#divide_") too weak!*)
112.1154 + ],
112.1155 + scr = EmptyScr}:rls);
112.1156 +
112.1157 +
112.1158 +ruleset' := overwritelthy thy (!ruleset',
112.1159 + [("order_add_mult_in", order_add_mult_in),
112.1160 + ("collect_bdv", collect_bdv),
112.1161 + ("make_polynomial_in", make_polynomial_in),
112.1162 + ("make_ratpoly_in", make_ratpoly_in),
112.1163 + ("separate_bdvs", separate_bdvs)
112.1164 + ]);
112.1165 +
113.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
113.2 +++ b/src/Tools/isac/Knowledge/PolyEq.thy Wed Aug 25 16:20:07 2010 +0200
113.3 @@ -0,0 +1,407 @@
113.4 +(*.(c) by Richard Lang, 2003 .*)
113.5 +(* theory collecting all knowledge
113.6 + (predicates 'is_rootEq_in', 'is_sqrt_in', 'is_ratEq_in')
113.7 + for PolynomialEquations.
113.8 + alternative dependencies see Isac.thy
113.9 + created by: rlang
113.10 + date: 02.07
113.11 + changed by: rlang
113.12 + last change by: rlang
113.13 + date: 03.06.03
113.14 +*)
113.15 +
113.16 +(* remove_thy"PolyEq";
113.17 + use_thy"Knowledge/Isac";
113.18 + use_thy"Knowledge/PolyEq";
113.19 +
113.20 + remove_thy"PolyEq";
113.21 + use_thy"Isac";
113.22 +
113.23 + use"ROOT.ML";
113.24 + cd"knowledge";
113.25 + *)
113.26 +
113.27 +PolyEq = LinEq + RootRatEq +
113.28 +(*-------------------- consts ------------------------------------------------*)
113.29 +consts
113.30 +
113.31 +(*---------scripts--------------------------*)
113.32 + Complete'_square
113.33 + :: "[bool,real, \
113.34 + \ bool list] => bool list"
113.35 + ("((Script Complete'_square (_ _ =))// \
113.36 + \ (_))" 9)
113.37 + (*----- poly ----- *)
113.38 + Normalize'_poly
113.39 + :: "[bool,real, \
113.40 + \ bool list] => bool list"
113.41 + ("((Script Normalize'_poly (_ _=))// \
113.42 + \ (_))" 9)
113.43 + Solve'_d0'_polyeq'_equation
113.44 + :: "[bool,real, \
113.45 + \ bool list] => bool list"
113.46 + ("((Script Solve'_d0'_polyeq'_equation (_ _ =))// \
113.47 + \ (_))" 9)
113.48 + Solve'_d1'_polyeq'_equation
113.49 + :: "[bool,real, \
113.50 + \ bool list] => bool list"
113.51 + ("((Script Solve'_d1'_polyeq'_equation (_ _ =))// \
113.52 + \ (_))" 9)
113.53 + Solve'_d2'_polyeq'_equation
113.54 + :: "[bool,real, \
113.55 + \ bool list] => bool list"
113.56 + ("((Script Solve'_d2'_polyeq'_equation (_ _ =))// \
113.57 + \ (_))" 9)
113.58 + Solve'_d2'_polyeq'_sqonly'_equation
113.59 + :: "[bool,real, \
113.60 + \ bool list] => bool list"
113.61 + ("((Script Solve'_d2'_polyeq'_sqonly'_equation (_ _ =))// \
113.62 + \ (_))" 9)
113.63 + Solve'_d2'_polyeq'_bdvonly'_equation
113.64 + :: "[bool,real, \
113.65 + \ bool list] => bool list"
113.66 + ("((Script Solve'_d2'_polyeq'_bdvonly'_equation (_ _ =))// \
113.67 + \ (_))" 9)
113.68 + Solve'_d2'_polyeq'_pq'_equation
113.69 + :: "[bool,real, \
113.70 + \ bool list] => bool list"
113.71 + ("((Script Solve'_d2'_polyeq'_pq'_equation (_ _ =))// \
113.72 + \ (_))" 9)
113.73 + Solve'_d2'_polyeq'_abc'_equation
113.74 + :: "[bool,real, \
113.75 + \ bool list] => bool list"
113.76 + ("((Script Solve'_d2'_polyeq'_abc'_equation (_ _ =))// \
113.77 + \ (_))" 9)
113.78 + Solve'_d3'_polyeq'_equation
113.79 + :: "[bool,real, \
113.80 + \ bool list] => bool list"
113.81 + ("((Script Solve'_d3'_polyeq'_equation (_ _ =))// \
113.82 + \ (_))" 9)
113.83 + Solve'_d4'_polyeq'_equation
113.84 + :: "[bool,real, \
113.85 + \ bool list] => bool list"
113.86 + ("((Script Solve'_d4'_polyeq'_equation (_ _ =))// \
113.87 + \ (_))" 9)
113.88 + Biquadrat'_poly
113.89 + :: "[bool,real, \
113.90 + \ bool list] => bool list"
113.91 + ("((Script Biquadrat'_poly (_ _=))// \
113.92 + \ (_))" 9)
113.93 +
113.94 +(*-------------------- rules -------------------------------------------------*)
113.95 +rules
113.96 +
113.97 + cancel_leading_coeff1 "Not (c =!= 0) ==> (a + b*bdv + c*bdv^^^2 = 0) = \
113.98 + \ (a/c + b/c*bdv + bdv^^^2 = 0)"
113.99 + cancel_leading_coeff2 "Not (c =!= 0) ==> (a - b*bdv + c*bdv^^^2 = 0) = \
113.100 + \ (a/c - b/c*bdv + bdv^^^2 = 0)"
113.101 + cancel_leading_coeff3 "Not (c =!= 0) ==> (a + b*bdv - c*bdv^^^2 = 0) = \
113.102 + \ (a/c + b/c*bdv - bdv^^^2 = 0)"
113.103 +
113.104 + cancel_leading_coeff4 "Not (c =!= 0) ==> (a + bdv + c*bdv^^^2 = 0) = \
113.105 + \ (a/c + 1/c*bdv + bdv^^^2 = 0)"
113.106 + cancel_leading_coeff5 "Not (c =!= 0) ==> (a - bdv + c*bdv^^^2 = 0) = \
113.107 + \ (a/c - 1/c*bdv + bdv^^^2 = 0)"
113.108 + cancel_leading_coeff6 "Not (c =!= 0) ==> (a + bdv - c*bdv^^^2 = 0) = \
113.109 + \ (a/c + 1/c*bdv - bdv^^^2 = 0)"
113.110 +
113.111 + cancel_leading_coeff7 "Not (c =!= 0) ==> ( b*bdv + c*bdv^^^2 = 0) = \
113.112 + \ ( b/c*bdv + bdv^^^2 = 0)"
113.113 + cancel_leading_coeff8 "Not (c =!= 0) ==> ( b*bdv - c*bdv^^^2 = 0) = \
113.114 + \ ( b/c*bdv - bdv^^^2 = 0)"
113.115 +
113.116 + cancel_leading_coeff9 "Not (c =!= 0) ==> ( bdv + c*bdv^^^2 = 0) = \
113.117 + \ ( 1/c*bdv + bdv^^^2 = 0)"
113.118 + cancel_leading_coeff10"Not (c =!= 0) ==> ( bdv - c*bdv^^^2 = 0) = \
113.119 + \ ( 1/c*bdv - bdv^^^2 = 0)"
113.120 +
113.121 + cancel_leading_coeff11"Not (c =!= 0) ==> (a + b*bdv^^^2 = 0) = \
113.122 + \ (a/b + bdv^^^2 = 0)"
113.123 + cancel_leading_coeff12"Not (c =!= 0) ==> (a - b*bdv^^^2 = 0) = \
113.124 + \ (a/b - bdv^^^2 = 0)"
113.125 + cancel_leading_coeff13"Not (c =!= 0) ==> ( b*bdv^^^2 = 0) = \
113.126 + \ ( bdv^^^2 = 0/b)"
113.127 +
113.128 + complete_square1 "(q + p*bdv + bdv^^^2 = 0) = \
113.129 + \(q + (p/2 + bdv)^^^2 = (p/2)^^^2)"
113.130 + complete_square2 "( p*bdv + bdv^^^2 = 0) = \
113.131 + \( (p/2 + bdv)^^^2 = (p/2)^^^2)"
113.132 + complete_square3 "( bdv + bdv^^^2 = 0) = \
113.133 + \( (1/2 + bdv)^^^2 = (1/2)^^^2)"
113.134 +
113.135 + complete_square4 "(q - p*bdv + bdv^^^2 = 0) = \
113.136 + \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)"
113.137 + complete_square5 "(q + p*bdv - bdv^^^2 = 0) = \
113.138 + \(q + (p/2 - bdv)^^^2 = (p/2)^^^2)"
113.139 +
113.140 + square_explicit1 "(a + b^^^2 = c) = ( b^^^2 = c - a)"
113.141 + square_explicit2 "(a - b^^^2 = c) = (-(b^^^2) = c - a)"
113.142 +
113.143 + bdv_explicit1 "(a + bdv = b) = (bdv = - a + b)"
113.144 + bdv_explicit2 "(a - bdv = b) = ((-1)*bdv = - a + b)"
113.145 + bdv_explicit3 "((-1)*bdv = b) = (bdv = (-1)*b)"
113.146 +
113.147 + plus_leq "(0 <= a + b) = ((-1)*b <= a)"(*Isa?*)
113.148 + minus_leq "(0 <= a - b) = ( b <= a)"(*Isa?*)
113.149 +
113.150 +(*-- normalize --*)
113.151 + (*WN0509 compare LinEq.all_left "[|Not(b=!=0)|] ==> (a=b) = (a+(-1)*b=0)"*)
113.152 + all_left
113.153 + "[|Not(b=!=0)|] ==> (a = b) = (a - b = 0)"
113.154 + makex1_x
113.155 + "a^^^1 = a"
113.156 + real_assoc_1
113.157 + "a+(b+c) = a+b+c"
113.158 + real_assoc_2
113.159 + "a*(b*c) = a*b*c"
113.160 +
113.161 +(* ---- degree 0 ----*)
113.162 + d0_true
113.163 + "(0=0) = True"
113.164 + d0_false
113.165 + "[|Not(bdv occurs_in a);Not(a=0)|] ==> (a=0) = False"
113.166 +(* ---- degree 1 ----*)
113.167 + d1_isolate_add1
113.168 + "[|Not(bdv occurs_in a)|] ==> (a + b*bdv = 0) = (b*bdv = (-1)*a)"
113.169 + d1_isolate_add2
113.170 + "[|Not(bdv occurs_in a)|] ==> (a + bdv = 0) = ( bdv = (-1)*a)"
113.171 + d1_isolate_div
113.172 + "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv = c) = (bdv = c/b)"
113.173 +(* ---- degree 2 ----*)
113.174 + d2_isolate_add1
113.175 + "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^2=0) = (b*bdv^^^2= (-1)*a)"
113.176 + d2_isolate_add2
113.177 + "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^2=0) = ( bdv^^^2= (-1)*a)"
113.178 + d2_isolate_div
113.179 + "[|Not(b=0);Not(bdv occurs_in c)|] ==> (b*bdv^^^2=c) = (bdv^^^2=c/b)"
113.180 + d2_prescind1
113.181 + "(a*bdv + b*bdv^^^2 = 0) = (bdv*(a +b*bdv)=0)"
113.182 + d2_prescind2
113.183 + "(a*bdv + bdv^^^2 = 0) = (bdv*(a + bdv)=0)"
113.184 + d2_prescind3
113.185 + "( bdv + b*bdv^^^2 = 0) = (bdv*(1+b*bdv)=0)"
113.186 + d2_prescind4
113.187 + "( bdv + bdv^^^2 = 0) = (bdv*(1+ bdv)=0)"
113.188 + (* eliminate degree 2 *)
113.189 + (* thm for neg arguments in sqroot have postfix _neg *)
113.190 + d2_sqrt_equation1
113.191 + "[|(0<=c);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = ((bdv=sqrt c) | (bdv=(-1)*sqrt c ))"
113.192 + d2_sqrt_equation1_neg
113.193 + "[|(c<0);Not(bdv occurs_in c)|] ==> (bdv^^^2=c) = False"
113.194 + d2_sqrt_equation2
113.195 + "(bdv^^^2=0) = (bdv=0)"
113.196 + d2_sqrt_equation3
113.197 + "(b*bdv^^^2=0) = (bdv=0)"
113.198 + d2_reduce_equation1
113.199 + "(bdv*(a +b*bdv)=0) = ((bdv=0)|(a+b*bdv=0))"
113.200 + d2_reduce_equation2
113.201 + "(bdv*(a + bdv)=0) = ((bdv=0)|(a+ bdv=0))"
113.202 + d2_pqformula1
113.203 + "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+ bdv^^^2=0) =
113.204 + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2)
113.205 + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))"
113.206 + d2_pqformula1_neg
113.207 + "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+ bdv^^^2=0) = False"
113.208 + d2_pqformula2
113.209 + "[|0<=p^^^2 - 4*q|] ==> (q+p*bdv+1*bdv^^^2=0) =
113.210 + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 4*q)/2)
113.211 + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 4*q)/2))"
113.212 + d2_pqformula2_neg
113.213 + "[|p^^^2 - 4*q<0|] ==> (q+p*bdv+1*bdv^^^2=0) = False"
113.214 + d2_pqformula3
113.215 + "[|0<=1 - 4*q|] ==> (q+ bdv+ bdv^^^2=0) =
113.216 + ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2)
113.217 + | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))"
113.218 + d2_pqformula3_neg
113.219 + "[|1 - 4*q<0|] ==> (q+ bdv+ bdv^^^2=0) = False"
113.220 + d2_pqformula4
113.221 + "[|0<=1 - 4*q|] ==> (q+ bdv+1*bdv^^^2=0) =
113.222 + ((bdv= (-1)*(1/2) + sqrt(1 - 4*q)/2)
113.223 + | (bdv= (-1)*(1/2) - sqrt(1 - 4*q)/2))"
113.224 + d2_pqformula4_neg
113.225 + "[|1 - 4*q<0|] ==> (q+ bdv+1*bdv^^^2=0) = False"
113.226 + d2_pqformula5
113.227 + "[|0<=p^^^2 - 0|] ==> ( p*bdv+ bdv^^^2=0) =
113.228 + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2)
113.229 + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))"
113.230 + (* d2_pqformula5_neg not need p^2 never less zero in R *)
113.231 + d2_pqformula6
113.232 + "[|0<=p^^^2 - 0|] ==> ( p*bdv+1*bdv^^^2=0) =
113.233 + ((bdv= (-1)*(p/2) + sqrt(p^^^2 - 0)/2)
113.234 + | (bdv= (-1)*(p/2) - sqrt(p^^^2 - 0)/2))"
113.235 + (* d2_pqformula6_neg not need p^2 never less zero in R *)
113.236 + d2_pqformula7
113.237 + "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) =
113.238 + ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2)
113.239 + | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))"
113.240 + (* d2_pqformula7_neg not need, because 1<0 ==> False*)
113.241 + d2_pqformula8
113.242 + "[|0<=1 - 0|] ==> ( bdv+1*bdv^^^2=0) =
113.243 + ((bdv= (-1)*(1/2) + sqrt(1 - 0)/2)
113.244 + | (bdv= (-1)*(1/2) - sqrt(1 - 0)/2))"
113.245 + (* d2_pqformula8_neg not need, because 1<0 ==> False*)
113.246 + d2_pqformula9
113.247 + "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ 1*bdv^^^2=0) =
113.248 + ((bdv= 0 + sqrt(0 - 4*q)/2)
113.249 + | (bdv= 0 - sqrt(0 - 4*q)/2))"
113.250 + d2_pqformula9_neg
113.251 + "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ 1*bdv^^^2=0) = False"
113.252 + d2_pqformula10
113.253 + "[|Not(bdv occurs_in q); 0<= (-1)*4*q|] ==> (q+ bdv^^^2=0) =
113.254 + ((bdv= 0 + sqrt(0 - 4*q)/2)
113.255 + | (bdv= 0 - sqrt(0 - 4*q)/2))"
113.256 + d2_pqformula10_neg
113.257 + "[|Not(bdv occurs_in q); (-1)*4*q<0|] ==> (q+ bdv^^^2=0) = False"
113.258 + d2_abcformula1
113.259 + "[|0<=b^^^2 - 4*a*c|] ==> (c + b*bdv+a*bdv^^^2=0) =
113.260 + ((bdv=( -b + sqrt(b^^^2 - 4*a*c))/(2*a))
113.261 + | (bdv=( -b - sqrt(b^^^2 - 4*a*c))/(2*a)))"
113.262 + d2_abcformula1_neg
113.263 + "[|b^^^2 - 4*a*c<0|] ==> (c + b*bdv+a*bdv^^^2=0) = False"
113.264 + d2_abcformula2
113.265 + "[|0<=1 - 4*a*c|] ==> (c+ bdv+a*bdv^^^2=0) =
113.266 + ((bdv=( -1 + sqrt(1 - 4*a*c))/(2*a))
113.267 + | (bdv=( -1 - sqrt(1 - 4*a*c))/(2*a)))"
113.268 + d2_abcformula2_neg
113.269 + "[|1 - 4*a*c<0|] ==> (c+ bdv+a*bdv^^^2=0) = False"
113.270 + d2_abcformula3
113.271 + "[|0<=b^^^2 - 4*1*c|] ==> (c + b*bdv+ bdv^^^2=0) =
113.272 + ((bdv=( -b + sqrt(b^^^2 - 4*1*c))/(2*1))
113.273 + | (bdv=( -b - sqrt(b^^^2 - 4*1*c))/(2*1)))"
113.274 + d2_abcformula3_neg
113.275 + "[|b^^^2 - 4*1*c<0|] ==> (c + b*bdv+ bdv^^^2=0) = False"
113.276 + d2_abcformula4
113.277 + "[|0<=1 - 4*1*c|] ==> (c + bdv+ bdv^^^2=0) =
113.278 + ((bdv=( -1 + sqrt(1 - 4*1*c))/(2*1))
113.279 + | (bdv=( -1 - sqrt(1 - 4*1*c))/(2*1)))"
113.280 + d2_abcformula4_neg
113.281 + "[|1 - 4*1*c<0|] ==> (c + bdv+ bdv^^^2=0) = False"
113.282 + d2_abcformula5
113.283 + "[|Not(bdv occurs_in c); 0<=0 - 4*a*c|] ==> (c + a*bdv^^^2=0) =
113.284 + ((bdv=( 0 + sqrt(0 - 4*a*c))/(2*a))
113.285 + | (bdv=( 0 - sqrt(0 - 4*a*c))/(2*a)))"
113.286 + d2_abcformula5_neg
113.287 + "[|Not(bdv occurs_in c); 0 - 4*a*c<0|] ==> (c + a*bdv^^^2=0) = False"
113.288 + d2_abcformula6
113.289 + "[|Not(bdv occurs_in c); 0<=0 - 4*1*c|] ==> (c+ bdv^^^2=0) =
113.290 + ((bdv=( 0 + sqrt(0 - 4*1*c))/(2*1))
113.291 + | (bdv=( 0 - sqrt(0 - 4*1*c))/(2*1)))"
113.292 + d2_abcformula6_neg
113.293 + "[|Not(bdv occurs_in c); 0 - 4*1*c<0|] ==> (c+ bdv^^^2=0) = False"
113.294 + d2_abcformula7
113.295 + "[|0<=b^^^2 - 0|] ==> ( b*bdv+a*bdv^^^2=0) =
113.296 + ((bdv=( -b + sqrt(b^^^2 - 0))/(2*a))
113.297 + | (bdv=( -b - sqrt(b^^^2 - 0))/(2*a)))"
113.298 + (* d2_abcformula7_neg not need b^2 never less zero in R *)
113.299 + d2_abcformula8
113.300 + "[|0<=b^^^2 - 0|] ==> ( b*bdv+ bdv^^^2=0) =
113.301 + ((bdv=( -b + sqrt(b^^^2 - 0))/(2*1))
113.302 + | (bdv=( -b - sqrt(b^^^2 - 0))/(2*1)))"
113.303 + (* d2_abcformula8_neg not need b^2 never less zero in R *)
113.304 + d2_abcformula9
113.305 + "[|0<=1 - 0|] ==> ( bdv+a*bdv^^^2=0) =
113.306 + ((bdv=( -1 + sqrt(1 - 0))/(2*a))
113.307 + | (bdv=( -1 - sqrt(1 - 0))/(2*a)))"
113.308 + (* d2_abcformula9_neg not need, because 1<0 ==> False*)
113.309 + d2_abcformula10
113.310 + "[|0<=1 - 0|] ==> ( bdv+ bdv^^^2=0) =
113.311 + ((bdv=( -1 + sqrt(1 - 0))/(2*1))
113.312 + | (bdv=( -1 - sqrt(1 - 0))/(2*1)))"
113.313 + (* d2_abcformula10_neg not need, because 1<0 ==> False*)
113.314 +
113.315 +(* ---- degree 3 ----*)
113.316 + d3_reduce_equation1
113.317 + "(a*bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + b*bdv + c*bdv^^^2=0))"
113.318 + d3_reduce_equation2
113.319 + "( bdv + b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + b*bdv + c*bdv^^^2=0))"
113.320 + d3_reduce_equation3
113.321 + "(a*bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (a + bdv + c*bdv^^^2=0))"
113.322 + d3_reduce_equation4
113.323 + "( bdv + bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | (1 + bdv + c*bdv^^^2=0))"
113.324 + d3_reduce_equation5
113.325 + "(a*bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (a + b*bdv + bdv^^^2=0))"
113.326 + d3_reduce_equation6
113.327 + "( bdv + b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + b*bdv + bdv^^^2=0))"
113.328 + d3_reduce_equation7
113.329 + "(a*bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))"
113.330 + d3_reduce_equation8
113.331 + "( bdv + bdv^^^2 + bdv^^^3=0) = (bdv=0 | (1 + bdv + bdv^^^2=0))"
113.332 + d3_reduce_equation9
113.333 + "(a*bdv + c*bdv^^^3=0) = (bdv=0 | (a + c*bdv^^^2=0))"
113.334 + d3_reduce_equation10
113.335 + "( bdv + c*bdv^^^3=0) = (bdv=0 | (1 + c*bdv^^^2=0))"
113.336 + d3_reduce_equation11
113.337 + "(a*bdv + bdv^^^3=0) = (bdv=0 | (a + bdv^^^2=0))"
113.338 + d3_reduce_equation12
113.339 + "( bdv + bdv^^^3=0) = (bdv=0 | (1 + bdv^^^2=0))"
113.340 + d3_reduce_equation13
113.341 + "( b*bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( b*bdv + c*bdv^^^2=0))"
113.342 + d3_reduce_equation14
113.343 + "( bdv^^^2 + c*bdv^^^3=0) = (bdv=0 | ( bdv + c*bdv^^^2=0))"
113.344 + d3_reduce_equation15
113.345 + "( b*bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( b*bdv + bdv^^^2=0))"
113.346 + d3_reduce_equation16
113.347 + "( bdv^^^2 + bdv^^^3=0) = (bdv=0 | ( bdv + bdv^^^2=0))"
113.348 + d3_isolate_add1
113.349 + "[|Not(bdv occurs_in a)|] ==> (a + b*bdv^^^3=0) = (b*bdv^^^3= (-1)*a)"
113.350 + d3_isolate_add2
113.351 + "[|Not(bdv occurs_in a)|] ==> (a + bdv^^^3=0) = ( bdv^^^3= (-1)*a)"
113.352 + d3_isolate_div
113.353 + "[|Not(b=0);Not(bdv occurs_in a)|] ==> (b*bdv^^^3=c) = (bdv^^^3=c/b)"
113.354 + d3_root_equation2
113.355 + "(bdv^^^3=0) = (bdv=0)"
113.356 + d3_root_equation1
113.357 + "(bdv^^^3=c) = (bdv = nroot 3 c)"
113.358 +
113.359 +(* ---- degree 4 ----*)
113.360 + (* RL03.FIXME es wir nicht getestet ob u>0 *)
113.361 + d4_sub_u1
113.362 + "(c+b*bdv^^^2+a*bdv^^^4=0) =
113.363 + ((a*u^^^2+b*u+c=0) & (bdv^^^2=u))"
113.364 +
113.365 +(* ---- 7.3.02 von Termorder ---- *)
113.366 +
113.367 + bdv_collect_1 "l * bdv + m * bdv = (l + m) * bdv"
113.368 + bdv_collect_2 "bdv + m * bdv = (1 + m) * bdv"
113.369 + bdv_collect_3 "l * bdv + bdv = (l + 1) * bdv"
113.370 +
113.371 +(* bdv_collect_assoc0_1 "l * bdv + m * bdv + k = (l + m) * bdv + k"
113.372 + bdv_collect_assoc0_2 "bdv + m * bdv + k = (1 + m) * bdv + k"
113.373 + bdv_collect_assoc0_3 "l * bdv + bdv + k = (l + 1) * bdv + k"
113.374 +*)
113.375 + bdv_collect_assoc1_1 "l * bdv + (m * bdv + k) = (l + m) * bdv + k"
113.376 + bdv_collect_assoc1_2 "bdv + (m * bdv + k) = (1 + m) * bdv + k"
113.377 + bdv_collect_assoc1_3 "l * bdv + (bdv + k) = (l + 1) * bdv + k"
113.378 +
113.379 + bdv_collect_assoc2_1 "k + l * bdv + m * bdv = k + (l + m) * bdv"
113.380 + bdv_collect_assoc2_2 "k + bdv + m * bdv = k + (1 + m) * bdv"
113.381 + bdv_collect_assoc2_3 "k + l * bdv + bdv = k + (l + 1) * bdv"
113.382 +
113.383 +
113.384 + bdv_n_collect_1 "l * bdv^^^n + m * bdv^^^n = (l + m) * bdv^^^n"
113.385 + bdv_n_collect_2 " bdv^^^n + m * bdv^^^n = (1 + m) * bdv^^^n"
113.386 + bdv_n_collect_3 "l * bdv^^^n + bdv^^^n = (l + 1) * bdv^^^n" (*order!*)
113.387 +
113.388 + bdv_n_collect_assoc1_1 "l * bdv^^^n + (m * bdv^^^n + k) = (l + m) * bdv^^^n + k"
113.389 + bdv_n_collect_assoc1_2 "bdv^^^n + (m * bdv^^^n + k) = (1 + m) * bdv^^^n + k"
113.390 + bdv_n_collect_assoc1_3 "l * bdv^^^n + (bdv^^^n + k) = (l + 1) * bdv^^^n + k"
113.391 +
113.392 + bdv_n_collect_assoc2_1 "k + l * bdv^^^n + m * bdv^^^n = k + (l + m) * bdv^^^n"
113.393 + bdv_n_collect_assoc2_2 "k + bdv^^^n + m * bdv^^^n = k + (1 + m) * bdv^^^n"
113.394 + bdv_n_collect_assoc2_3 "k + l * bdv^^^n + bdv^^^n = k + (l + 1) * bdv^^^n"
113.395 +
113.396 +(*WN.14.3.03*)
113.397 + real_minus_div "- (a / b) = (-1 * a) / b"
113.398 +
113.399 + separate_bdv "(a * bdv) / b = (a / b) * bdv"
113.400 + separate_bdv_n "(a * bdv ^^^ n) / b = (a / b) * bdv ^^^ n"
113.401 + separate_1_bdv "bdv / b = (1 / b) * bdv"
113.402 + separate_1_bdv_n "bdv ^^^ n / b = (1 / b) * bdv ^^^ n"
113.403 +
113.404 +end
113.405 +
113.406 +
113.407 +
113.408 +
113.409 +
113.410 +
114.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
114.2 +++ b/src/Tools/isac/Knowledge/PolyMinus.ML Wed Aug 25 16:20:07 2010 +0200
114.3 @@ -0,0 +1,521 @@
114.4 +(* questionable attempts to perserve binary minus as wanted by teachers
114.5 + WN071207
114.6 + (c) due to copyright terms
114.7 +remove_thy"PolyMinus";
114.8 +use_thy"Knowledge/PolyMinus";
114.9 +
114.10 +use_thy"Knowledge/Isac";
114.11 +use"Knowledge/PolyMinus.ML";
114.12 +*)
114.13 +
114.14 +(** interface isabelle -- isac **)
114.15 +theory' := overwritel (!theory', [("PolyMinus.thy",PolyMinus.thy)]);
114.16 +
114.17 +(** eval functions **)
114.18 +
114.19 +(*. get the identifier from specific monomials; see fun ist_monom .*)
114.20 +(*HACK.WN080107*)
114.21 +fun increase str =
114.22 + let val s::ss = explode str
114.23 + in implode ((chr (ord s + 1))::ss) end;
114.24 +fun identifier (Free (id,_)) = id (* 2, a *)
114.25 + | identifier (Const ("op *", _) $ Free (num, _) $ Free (id, _)) =
114.26 + id (* 2*a, a*b *)
114.27 + | identifier (Const ("op *", _) $ (* 3*a*b *)
114.28 + (Const ("op *", _) $
114.29 + Free (num, _) $ Free _) $ Free (id, _)) =
114.30 + if is_numeral num then id
114.31 + else "|||||||||||||"
114.32 + | identifier (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) =
114.33 + if is_numeral base then "|||||||||||||" (* a^2 *)
114.34 + else (*increase*) base
114.35 + | identifier (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *)
114.36 + (Const ("Atools.pow", _) $
114.37 + Free (base, _) $ Free (exp, _))) =
114.38 + if is_numeral num andalso not (is_numeral base) then (*increase*) base
114.39 + else "|||||||||||||"
114.40 + | identifier _ = "|||||||||||||"(*the "largest" string*);
114.41 +
114.42 +(*("kleiner", ("PolyMinus.kleiner", eval_kleiner ""))*)
114.43 +(* order "by alphabet" w.r.t. var: num < (var | num*var) > (var*var | ..) *)
114.44 +fun eval_kleiner _ _ (p as (Const ("PolyMinus.kleiner",_) $ a $ b)) _ =
114.45 + if is_num b then
114.46 + if is_num a then (*123 kleiner 32 = True !!!*)
114.47 + if int_of_Free a < int_of_Free b then
114.48 + SOME ((term2str p) ^ " = True",
114.49 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
114.50 + else SOME ((term2str p) ^ " = False",
114.51 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
114.52 + else (* -1 * -2 kleiner 0 *)
114.53 + SOME ((term2str p) ^ " = False",
114.54 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
114.55 + else
114.56 + if identifier a < identifier b then
114.57 + SOME ((term2str p) ^ " = True",
114.58 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
114.59 + else SOME ((term2str p) ^ " = False",
114.60 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
114.61 + | eval_kleiner _ _ _ _ = NONE;
114.62 +
114.63 +fun ist_monom (Free (id,_)) = true
114.64 + | ist_monom (Const ("op *", _) $ Free (num, _) $ Free (id, _)) =
114.65 + if is_numeral num then true else false
114.66 + | ist_monom _ = false;
114.67 +(*. this function only accepts the most simple monoms vvvvvvvvvv .*)
114.68 +fun ist_monom (Free (id,_)) = true (* 2, a *)
114.69 + | ist_monom (Const ("op *", _) $ Free _ $ Free (id, _)) = (* 2*a, a*b *)
114.70 + if is_numeral id then false else true
114.71 + | ist_monom (Const ("op *", _) $ (* 3*a*b *)
114.72 + (Const ("op *", _) $
114.73 + Free (num, _) $ Free _) $ Free (id, _)) =
114.74 + if is_numeral num andalso not (is_numeral id) then true else false
114.75 + | ist_monom (Const ("Atools.pow", _) $ Free (base, _) $ Free (exp, _)) =
114.76 + true (* a^2 *)
114.77 + | ist_monom (Const ("op *", _) $ Free (num, _) $ (* 3*a^2 *)
114.78 + (Const ("Atools.pow", _) $
114.79 + Free (base, _) $ Free (exp, _))) =
114.80 + if is_numeral num then true else false
114.81 + | ist_monom _ = false;
114.82 +
114.83 +(* is this a univariate monomial ? *)
114.84 +(*("ist_monom", ("PolyMinus.ist'_monom", eval_ist_monom ""))*)
114.85 +fun eval_ist_monom _ _ (p as (Const ("PolyMinus.ist'_monom",_) $ a)) _ =
114.86 + if ist_monom a then
114.87 + SOME ((term2str p) ^ " = True",
114.88 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
114.89 + else SOME ((term2str p) ^ " = False",
114.90 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
114.91 + | eval_ist_monom _ _ _ _ = NONE;
114.92 +
114.93 +
114.94 +(** rewrite order **)
114.95 +
114.96 +(** rulesets **)
114.97 +
114.98 +val erls_ordne_alphabetisch =
114.99 + append_rls "erls_ordne_alphabetisch" e_rls
114.100 + [Calc ("PolyMinus.kleiner", eval_kleiner ""),
114.101 + Calc ("PolyMinus.ist'_monom", eval_ist_monom "")
114.102 + ];
114.103 +
114.104 +val ordne_alphabetisch =
114.105 + Rls{id = "ordne_alphabetisch", preconds = [],
114.106 + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [],
114.107 + erls = erls_ordne_alphabetisch,
114.108 + rules = [Thm ("tausche_plus",num_str tausche_plus),
114.109 + (*"b kleiner a ==> (b + a) = (a + b)"*)
114.110 + Thm ("tausche_minus",num_str tausche_minus),
114.111 + (*"b kleiner a ==> (b - a) = (-a + b)"*)
114.112 + Thm ("tausche_vor_plus",num_str tausche_vor_plus),
114.113 + (*"[| b ist_monom; a kleiner b |] ==> (- b + a) = (a - b)"*)
114.114 + Thm ("tausche_vor_minus",num_str tausche_vor_minus),
114.115 + (*"[| b ist_monom; a kleiner b |] ==> (- b - a) = (-a - b)"*)
114.116 + Thm ("tausche_plus_plus",num_str tausche_plus_plus),
114.117 + (*"c kleiner b ==> (a + c + b) = (a + b + c)"*)
114.118 + Thm ("tausche_plus_minus",num_str tausche_plus_minus),
114.119 + (*"c kleiner b ==> (a + c - b) = (a - b + c)"*)
114.120 + Thm ("tausche_minus_plus",num_str tausche_minus_plus),
114.121 + (*"c kleiner b ==> (a - c + b) = (a + b - c)"*)
114.122 + Thm ("tausche_minus_minus",num_str tausche_minus_minus)
114.123 + (*"c kleiner b ==> (a - c - b) = (a - b - c)"*)
114.124 + ], scr = EmptyScr}:rls;
114.125 +
114.126 +val fasse_zusammen =
114.127 + Rls{id = "fasse_zusammen", preconds = [],
114.128 + rew_ord = ("dummy_ord", dummy_ord),
114.129 + erls = append_rls "erls_fasse_zusammen" e_rls
114.130 + [Calc ("Atools.is'_const",eval_const "#is_const_")],
114.131 + srls = Erls, calc = [],
114.132 + rules =
114.133 + [Thm ("real_num_collect",num_str real_num_collect),
114.134 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
114.135 + Thm ("real_num_collect_assoc_r",num_str real_num_collect_assoc_r),
114.136 + (*"[| l is_const; m..|] ==> (k + m * n) + l * n = k + (l + m)*n"*)
114.137 + Thm ("real_one_collect",num_str real_one_collect),
114.138 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
114.139 + Thm ("real_one_collect_assoc_r",num_str real_one_collect_assoc_r),
114.140 + (*"m is_const ==> (k + n) + m * n = k + (m + 1) * n"*)
114.141 +
114.142 +
114.143 + Thm ("subtrahiere",num_str subtrahiere),
114.144 + (*"[| l is_const; m is_const |] ==> m * v - l * v = (m - l) * v"*)
114.145 + Thm ("subtrahiere_von_1",num_str subtrahiere_von_1),
114.146 + (*"[| l is_const |] ==> v - l * v = (1 - l) * v"*)
114.147 + Thm ("subtrahiere_1",num_str subtrahiere_1),
114.148 + (*"[| l is_const; m is_const |] ==> m * v - v = (m - 1) * v"*)
114.149 +
114.150 + Thm ("subtrahiere_x_plus_minus",num_str subtrahiere_x_plus_minus),
114.151 + (*"[| l is_const; m..|] ==> (k + m * n) - l * n = k + ( m - l) * n"*)
114.152 + Thm ("subtrahiere_x_plus1_minus",num_str subtrahiere_x_plus1_minus),
114.153 + (*"[| l is_const |] ==> (x + v) - l * v = x + (1 - l) * v"*)
114.154 + Thm ("subtrahiere_x_plus_minus1",num_str subtrahiere_x_plus_minus1),
114.155 + (*"[| m is_const |] ==> (x + m * v) - v = x + (m - 1) * v"*)
114.156 +
114.157 + Thm ("subtrahiere_x_minus_plus",num_str subtrahiere_x_minus_plus),
114.158 + (*"[| l is_const; m..|] ==> (k - m * n) + l * n = k + (-m + l) * n"*)
114.159 + Thm ("subtrahiere_x_minus1_plus",num_str subtrahiere_x_minus1_plus),
114.160 + (*"[| l is_const |] ==> (x - v) + l * v = x + (-1 + l) * v"*)
114.161 + Thm ("subtrahiere_x_minus_plus1",num_str subtrahiere_x_minus_plus1),
114.162 + (*"[| m is_const |] ==> (x - m * v) + v = x + (-m + 1) * v"*)
114.163 +
114.164 + Thm ("subtrahiere_x_minus_minus",num_str subtrahiere_x_minus_minus),
114.165 + (*"[| l is_const; m..|] ==> (k - m * n) - l * n = k + (-m - l) * n"*)
114.166 + Thm ("subtrahiere_x_minus1_minus",num_str subtrahiere_x_minus1_minus),
114.167 + (*"[| l is_const |] ==> (x - v) - l * v = x + (-1 - l) * v"*)
114.168 + Thm ("subtrahiere_x_minus_minus1",num_str subtrahiere_x_minus_minus1),
114.169 + (*"[| m is_const |] ==> (x - m * v) - v = x + (-m - 1) * v"*)
114.170 +
114.171 + Calc ("op +", eval_binop "#add_"),
114.172 + Calc ("op -", eval_binop "#subtr_"),
114.173 +
114.174 + (*MG: Reihenfolge der folgenden 2 Thm muss so bleiben, wegen
114.175 + (a+a)+a --> a + 2*a --> 3*a and not (a+a)+a --> 2*a + a *)
114.176 + Thm ("real_mult_2_assoc_r",num_str real_mult_2_assoc_r),
114.177 + (*"(k + z1) + z1 = k + 2 * z1"*)
114.178 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
114.179 + (*"z1 + z1 = 2 * z1"*)
114.180 +
114.181 + Thm ("addiere_vor_minus",num_str addiere_vor_minus),
114.182 + (*"[| l is_const; m is_const |] ==> -(l * v) + m * v = (-l + m) *v"*)
114.183 + Thm ("addiere_eins_vor_minus",num_str addiere_eins_vor_minus),
114.184 + (*"[| m is_const |] ==> - v + m * v = (-1 + m) * v"*)
114.185 + Thm ("subtrahiere_vor_minus",num_str subtrahiere_vor_minus),
114.186 + (*"[| l is_const; m is_const |] ==> -(l * v) - m * v = (-l - m) *v"*)
114.187 + Thm ("subtrahiere_eins_vor_minus",num_str subtrahiere_eins_vor_minus)
114.188 + (*"[| m is_const |] ==> - v - m * v = (-1 - m) * v"*)
114.189 +
114.190 + ], scr = EmptyScr}:rls;
114.191 +
114.192 +val verschoenere =
114.193 + Rls{id = "verschoenere", preconds = [],
114.194 + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [],
114.195 + erls = append_rls "erls_verschoenere" e_rls
114.196 + [Calc ("PolyMinus.kleiner", eval_kleiner "")],
114.197 + rules = [Thm ("vorzeichen_minus_weg1",num_str vorzeichen_minus_weg1),
114.198 + (*"l kleiner 0 ==> a + l * b = a - -l * b"*)
114.199 + Thm ("vorzeichen_minus_weg2",num_str vorzeichen_minus_weg2),
114.200 + (*"l kleiner 0 ==> a - l * b = a + -l * b"*)
114.201 + Thm ("vorzeichen_minus_weg3",num_str vorzeichen_minus_weg3),
114.202 + (*"l kleiner 0 ==> k + a - l * b = k + a + -l * b"*)
114.203 + Thm ("vorzeichen_minus_weg4",num_str vorzeichen_minus_weg4),
114.204 + (*"l kleiner 0 ==> k - a - l * b = k - a + -l * b"*)
114.205 +
114.206 + Calc ("op *", eval_binop "#mult_"),
114.207 +
114.208 + Thm ("real_mult_0",num_str real_mult_0),
114.209 + (*"0 * z = 0"*)
114.210 + Thm ("real_mult_1",num_str real_mult_1),
114.211 + (*"1 * z = z"*)
114.212 + Thm ("real_add_zero_left",num_str real_add_zero_left),
114.213 + (*"0 + z = z"*)
114.214 + Thm ("null_minus",num_str null_minus),
114.215 + (*"0 - a = -a"*)
114.216 + Thm ("vor_minus_mal",num_str vor_minus_mal)
114.217 + (*"- a * b = (-a) * b"*)
114.218 +
114.219 + (*Thm ("",num_str ),*)
114.220 + (**)
114.221 + ], scr = EmptyScr}:rls (*end verschoenere*);
114.222 +
114.223 +val klammern_aufloesen =
114.224 + Rls{id = "klammern_aufloesen", preconds = [],
114.225 + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls,
114.226 + rules = [Thm ("sym_real_add_assoc",num_str (real_add_assoc RS sym)),
114.227 + (*"a + (b + c) = (a + b) + c"*)
114.228 + Thm ("klammer_plus_minus",num_str klammer_plus_minus),
114.229 + (*"a + (b - c) = (a + b) - c"*)
114.230 + Thm ("klammer_minus_plus",num_str klammer_minus_plus),
114.231 + (*"a - (b + c) = (a - b) - c"*)
114.232 + Thm ("klammer_minus_minus",num_str klammer_minus_minus)
114.233 + (*"a - (b - c) = (a - b) + c"*)
114.234 + ], scr = EmptyScr}:rls;
114.235 +
114.236 +val klammern_ausmultiplizieren =
114.237 + Rls{id = "klammern_ausmultiplizieren", preconds = [],
114.238 + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [], erls = Erls,
114.239 + rules = [Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
114.240 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
114.241 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
114.242 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
114.243 +
114.244 + Thm ("klammer_mult_minus",num_str klammer_mult_minus),
114.245 + (*"a * (b - c) = a * b - a * c"*)
114.246 + Thm ("klammer_minus_mult",num_str klammer_minus_mult)
114.247 + (*"(b - c) * a = b * a - c * a"*)
114.248 +
114.249 + (*Thm ("",num_str ),
114.250 + (*""*)*)
114.251 + ], scr = EmptyScr}:rls;
114.252 +
114.253 +val ordne_monome =
114.254 + Rls{id = "ordne_monome", preconds = [],
114.255 + rew_ord = ("dummy_ord", dummy_ord), srls = Erls, calc = [],
114.256 + erls = append_rls "erls_ordne_monome" e_rls
114.257 + [Calc ("PolyMinus.kleiner", eval_kleiner ""),
114.258 + Calc ("Atools.is'_atom", eval_is_atom "")
114.259 + ],
114.260 + rules = [Thm ("tausche_mal",num_str tausche_mal),
114.261 + (*"[| b is_atom; a kleiner b |] ==> (b * a) = (a * b)"*)
114.262 + Thm ("tausche_vor_mal",num_str tausche_vor_mal),
114.263 + (*"[| b is_atom; a kleiner b |] ==> (-b * a) = (-a * b)"*)
114.264 + Thm ("tausche_mal_mal",num_str tausche_mal_mal),
114.265 + (*"[| c is_atom; b kleiner c |] ==> (a * c * b) = (a * b *c)"*)
114.266 + Thm ("x_quadrat",num_str x_quadrat)
114.267 + (*"(x * a) * a = x * a ^^^ 2"*)
114.268 +
114.269 + (*Thm ("",num_str ),
114.270 + (*""*)*)
114.271 + ], scr = EmptyScr}:rls;
114.272 +
114.273 +
114.274 +val rls_p_33 =
114.275 + append_rls "rls_p_33" e_rls
114.276 + [Rls_ ordne_alphabetisch,
114.277 + Rls_ fasse_zusammen,
114.278 + Rls_ verschoenere
114.279 + ];
114.280 +val rls_p_34 =
114.281 + append_rls "rls_p_34" e_rls
114.282 + [Rls_ klammern_aufloesen,
114.283 + Rls_ ordne_alphabetisch,
114.284 + Rls_ fasse_zusammen,
114.285 + Rls_ verschoenere
114.286 + ];
114.287 +val rechnen =
114.288 + append_rls "rechnen" e_rls
114.289 + [Calc ("op *", eval_binop "#mult_"),
114.290 + Calc ("op +", eval_binop "#add_"),
114.291 + Calc ("op -", eval_binop "#subtr_")
114.292 + ];
114.293 +
114.294 +ruleset' :=
114.295 +overwritelthy thy (!ruleset',
114.296 + [("ordne_alphabetisch", prep_rls ordne_alphabetisch),
114.297 + ("fasse_zusammen", prep_rls fasse_zusammen),
114.298 + ("verschoenere", prep_rls verschoenere),
114.299 + ("ordne_monome", prep_rls ordne_monome),
114.300 + ("klammern_aufloesen", prep_rls klammern_aufloesen),
114.301 + ("klammern_ausmultiplizieren",
114.302 + prep_rls klammern_ausmultiplizieren)
114.303 + ]);
114.304 +
114.305 +(** problems **)
114.306 +
114.307 +store_pbt
114.308 + (prep_pbt PolyMinus.thy "pbl_vereinf_poly" [] e_pblID
114.309 + (["polynom","vereinfachen"],
114.310 + [], Erls, NONE, []));
114.311 +
114.312 +store_pbt
114.313 + (prep_pbt PolyMinus.thy "pbl_vereinf_poly_minus" [] e_pblID
114.314 + (["plus_minus","polynom","vereinfachen"],
114.315 + [("#Given" ,["term t_"]),
114.316 + ("#Where" ,["t_ is_polyexp",
114.317 + "Not (matchsub (?a + (?b + ?c)) t_ | \
114.318 + \ matchsub (?a + (?b - ?c)) t_ | \
114.319 + \ matchsub (?a - (?b + ?c)) t_ | \
114.320 + \ matchsub (?a + (?b - ?c)) t_ )",
114.321 + "Not (matchsub (?a * (?b + ?c)) t_ | \
114.322 + \ matchsub (?a * (?b - ?c)) t_ | \
114.323 + \ matchsub ((?b + ?c) * ?a) t_ | \
114.324 + \ matchsub ((?b - ?c) * ?a) t_ )"]),
114.325 + ("#Find" ,["normalform n_"])
114.326 + ],
114.327 + append_rls "prls_pbl_vereinf_poly" e_rls
114.328 + [Calc ("Poly.is'_polyexp", eval_is_polyexp ""),
114.329 + Calc ("Tools.matchsub", eval_matchsub ""),
114.330 + Thm ("or_true",or_true),
114.331 + (*"(?a | True) = True"*)
114.332 + Thm ("or_false",or_false),
114.333 + (*"(?a | False) = ?a"*)
114.334 + Thm ("not_true",num_str not_true),
114.335 + (*"(~ True) = False"*)
114.336 + Thm ("not_false",num_str not_false)
114.337 + (*"(~ False) = True"*)],
114.338 + SOME "Vereinfache t_",
114.339 + [["simplification","for_polynomials","with_minus"]]));
114.340 +
114.341 +store_pbt
114.342 + (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer" [] e_pblID
114.343 + (["klammer","polynom","vereinfachen"],
114.344 + [("#Given" ,["term t_"]),
114.345 + ("#Where" ,["t_ is_polyexp",
114.346 + "Not (matchsub (?a * (?b + ?c)) t_ | \
114.347 + \ matchsub (?a * (?b - ?c)) t_ | \
114.348 + \ matchsub ((?b + ?c) * ?a) t_ | \
114.349 + \ matchsub ((?b - ?c) * ?a) t_ )"]),
114.350 + ("#Find" ,["normalform n_"])
114.351 + ],
114.352 + append_rls "prls_pbl_vereinf_poly_klammer" e_rls [Calc ("Poly.is'_polyexp", eval_is_polyexp ""),
114.353 + Calc ("Tools.matchsub", eval_matchsub ""),
114.354 + Thm ("or_true",or_true),
114.355 + (*"(?a | True) = True"*)
114.356 + Thm ("or_false",or_false),
114.357 + (*"(?a | False) = ?a"*)
114.358 + Thm ("not_true",num_str not_true),
114.359 + (*"(~ True) = False"*)
114.360 + Thm ("not_false",num_str not_false)
114.361 + (*"(~ False) = True"*)],
114.362 + SOME "Vereinfache t_",
114.363 + [["simplification","for_polynomials","with_parentheses"]]));
114.364 +
114.365 +store_pbt
114.366 + (prep_pbt PolyMinus.thy "pbl_vereinf_poly_klammer_mal" [] e_pblID
114.367 + (["binom_klammer","polynom","vereinfachen"],
114.368 + [("#Given" ,["term t_"]),
114.369 + ("#Where" ,["t_ is_polyexp"]),
114.370 + ("#Find" ,["normalform n_"])
114.371 + ],
114.372 + append_rls "e_rls" e_rls [(*for preds in where_*)
114.373 + Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
114.374 + SOME "Vereinfache t_",
114.375 + [["simplification","for_polynomials","with_parentheses_mult"]]));
114.376 +
114.377 +store_pbt
114.378 + (prep_pbt PolyMinus.thy "pbl_probe" [] e_pblID
114.379 + (["probe"],
114.380 + [], Erls, NONE, []));
114.381 +
114.382 +store_pbt
114.383 + (prep_pbt PolyMinus.thy "pbl_probe_poly" [] e_pblID
114.384 + (["polynom","probe"],
114.385 + [("#Given" ,["Pruefe e_", "mitWert ws_"]),
114.386 + ("#Where" ,["e_ is_polyexp"]),
114.387 + ("#Find" ,["Geprueft p_"])
114.388 + ],
114.389 + append_rls "prls_pbl_probe_poly"
114.390 + e_rls [(*for preds in where_*)
114.391 + Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
114.392 + SOME "Probe e_ ws_",
114.393 + [["probe","fuer_polynom"]]));
114.394 +
114.395 +store_pbt
114.396 + (prep_pbt PolyMinus.thy "pbl_probe_bruch" [] e_pblID
114.397 + (["bruch","probe"],
114.398 + [("#Given" ,["Pruefe e_", "mitWert ws_"]),
114.399 + ("#Where" ,["e_ is_ratpolyexp"]),
114.400 + ("#Find" ,["Geprueft p_"])
114.401 + ],
114.402 + append_rls "prls_pbl_probe_bruch"
114.403 + e_rls [(*for preds in where_*)
114.404 + Calc ("Rational.is'_ratpolyexp", eval_is_ratpolyexp "")],
114.405 + SOME "Probe e_ ws_",
114.406 + [["probe","fuer_bruch"]]));
114.407 +
114.408 +
114.409 +(** methods **)
114.410 +
114.411 +store_met
114.412 + (prep_met PolyMinus.thy "met_simp_poly_minus" [] e_metID
114.413 + (["simplification","for_polynomials","with_minus"],
114.414 + [("#Given" ,["term t_"]),
114.415 + ("#Where" ,["t_ is_polyexp",
114.416 + "Not (matchsub (?a + (?b + ?c)) t_ | \
114.417 + \ matchsub (?a + (?b - ?c)) t_ | \
114.418 + \ matchsub (?a - (?b + ?c)) t_ | \
114.419 + \ matchsub (?a + (?b - ?c)) t_ )"]),
114.420 + ("#Find" ,["normalform n_"])
114.421 + ],
114.422 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
114.423 + prls = append_rls "prls_met_simp_poly_minus" e_rls
114.424 + [Calc ("Poly.is'_polyexp", eval_is_polyexp ""),
114.425 + Calc ("Tools.matchsub", eval_matchsub ""),
114.426 + Thm ("and_true",and_true),
114.427 + (*"(?a & True) = ?a"*)
114.428 + Thm ("and_false",and_false),
114.429 + (*"(?a & False) = False"*)
114.430 + Thm ("not_true",num_str not_true),
114.431 + (*"(~ True) = False"*)
114.432 + Thm ("not_false",num_str not_false)
114.433 + (*"(~ False) = True"*)],
114.434 + crls = e_rls, nrls = rls_p_33},
114.435 +"Script SimplifyScript (t_::real) = \
114.436 +\ ((Repeat((Try (Rewrite_Set ordne_alphabetisch False)) @@ \
114.437 +\ (Try (Rewrite_Set fasse_zusammen False)) @@ \
114.438 +\ (Try (Rewrite_Set verschoenere False)))) t_)"
114.439 + ));
114.440 +
114.441 +store_met
114.442 + (prep_met PolyMinus.thy "met_simp_poly_parenth" [] e_metID
114.443 + (["simplification","for_polynomials","with_parentheses"],
114.444 + [("#Given" ,["term t_"]),
114.445 + ("#Where" ,["t_ is_polyexp"]),
114.446 + ("#Find" ,["normalform n_"])
114.447 + ],
114.448 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
114.449 + prls = append_rls "simplification_for_polynomials_prls" e_rls
114.450 + [(*for preds in where_*)
114.451 + Calc("Poly.is'_polyexp",eval_is_polyexp"")],
114.452 + crls = e_rls, nrls = rls_p_34},
114.453 +"Script SimplifyScript (t_::real) = \
114.454 +\ ((Repeat((Try (Rewrite_Set klammern_aufloesen False)) @@ \
114.455 +\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \
114.456 +\ (Try (Rewrite_Set fasse_zusammen False)) @@ \
114.457 +\ (Try (Rewrite_Set verschoenere False)))) t_)"
114.458 + ));
114.459 +
114.460 +store_met
114.461 + (prep_met PolyMinus.thy "met_simp_poly_parenth_mult" [] e_metID
114.462 + (["simplification","for_polynomials","with_parentheses_mult"],
114.463 + [("#Given" ,["term t_"]),
114.464 + ("#Where" ,["t_ is_polyexp"]),
114.465 + ("#Find" ,["normalform n_"])
114.466 + ],
114.467 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
114.468 + prls = append_rls "simplification_for_polynomials_prls" e_rls
114.469 + [(*for preds in where_*)
114.470 + Calc("Poly.is'_polyexp",eval_is_polyexp"")],
114.471 + crls = e_rls, nrls = rls_p_34},
114.472 +"Script SimplifyScript (t_::real) = \
114.473 +\ ((Repeat((Try (Rewrite_Set klammern_ausmultiplizieren False)) @@ \
114.474 +\ (Try (Rewrite_Set discard_parentheses False)) @@ \
114.475 +\ (Try (Rewrite_Set ordne_monome False)) @@ \
114.476 +\ (Try (Rewrite_Set klammern_aufloesen False)) @@ \
114.477 +\ (Try (Rewrite_Set ordne_alphabetisch False)) @@ \
114.478 +\ (Try (Rewrite_Set fasse_zusammen False)) @@ \
114.479 +\ (Try (Rewrite_Set verschoenere False)))) t_)"
114.480 + ));
114.481 +
114.482 +store_met
114.483 + (prep_met PolyMinus.thy "met_probe" [] e_metID
114.484 + (["probe"],
114.485 + [],
114.486 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
114.487 + prls = Erls, crls = e_rls, nrls = Erls},
114.488 + "empty_script"));
114.489 +
114.490 +store_met
114.491 + (prep_met PolyMinus.thy "met_probe_poly" [] e_metID
114.492 + (["probe","fuer_polynom"],
114.493 + [("#Given" ,["Pruefe e_", "mitWert ws_"]),
114.494 + ("#Where" ,["e_ is_polyexp"]),
114.495 + ("#Find" ,["Geprueft p_"])
114.496 + ],
114.497 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
114.498 + prls = append_rls "prls_met_probe_bruch"
114.499 + e_rls [(*for preds in where_*)
114.500 + Calc ("Rational.is'_ratpolyexp",
114.501 + eval_is_ratpolyexp "")],
114.502 + crls = e_rls, nrls = rechnen},
114.503 +"Script ProbeScript (e_::bool) (ws_::bool list) = \
114.504 +\ (let e_ = Take e_; \
114.505 +\ e_ = Substitute ws_ e_ \
114.506 +\ in (Repeat((Try (Repeat (Calculate times))) @@ \
114.507 +\ (Try (Repeat (Calculate plus ))) @@ \
114.508 +\ (Try (Repeat (Calculate minus))))) e_)"
114.509 +));
114.510 +
114.511 +store_met
114.512 + (prep_met PolyMinus.thy "met_probe_bruch" [] e_metID
114.513 + (["probe","fuer_bruch"],
114.514 + [("#Given" ,["Pruefe e_", "mitWert ws_"]),
114.515 + ("#Where" ,["e_ is_ratpolyexp"]),
114.516 + ("#Find" ,["Geprueft p_"])
114.517 + ],
114.518 + {rew_ord'="tless_true", rls' = e_rls, calc = [], srls = e_rls,
114.519 + prls = append_rls "prls_met_probe_bruch"
114.520 + e_rls [(*for preds in where_*)
114.521 + Calc ("Rational.is'_ratpolyexp",
114.522 + eval_is_ratpolyexp "")],
114.523 + crls = e_rls, nrls = Erls},
114.524 + "empty_script"));
115.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
115.2 +++ b/src/Tools/isac/Knowledge/PolyMinus.thy Wed Aug 25 16:20:07 2010 +0200
115.3 @@ -0,0 +1,114 @@
115.4 +(* attempts to perserve binary minus as wanted by Austrian teachers
115.5 + WN071207
115.6 + (c) due to copyright terms
115.7 +remove_thy"PolyMinus";
115.8 +use_thy_only"Knowledge/PolyMinus";
115.9 +use_thy"Knowledge/Isac";
115.10 +*)
115.11 +
115.12 +PolyMinus = (*Poly// due to "is_ratpolyexp" in...*) Rational +
115.13 +
115.14 +consts
115.15 +
115.16 + (*predicates for conditions in rewriting*)
115.17 + kleiner :: "['a, 'a] => bool" ("_ kleiner _")
115.18 + ist'_monom :: "'a => bool" ("_ ist'_monom")
115.19 +
115.20 + (*the CAS-command*)
115.21 + Probe :: "[bool, bool list] => bool"
115.22 + (*"Probe (3*a+2*b+a = 4*a+2*b) [a=1,b=2]"*)
115.23 +
115.24 + (*descriptions for the pbl and met*)
115.25 + Pruefe :: bool => una
115.26 + mitWert :: bool list => tobooll
115.27 + Geprueft :: bool => una
115.28 +
115.29 + (*Script-name*)
115.30 + ProbeScript :: "[bool, bool list, bool] \
115.31 + \=> bool"
115.32 + ("((Script ProbeScript (_ _ =))// (_))" 9)
115.33 +
115.34 +rules
115.35 +
115.36 + null_minus "0 - a = -a"
115.37 + vor_minus_mal "- a * b = (-a) * b"
115.38 +
115.39 + (*commute with invariant (a.b).c -association*)
115.40 + tausche_plus "[| b ist_monom; a kleiner b |] ==> \
115.41 + \(b + a) = (a + b)"
115.42 + tausche_minus "[| b ist_monom; a kleiner b |] ==> \
115.43 + \(b - a) = (-a + b)"
115.44 + tausche_vor_plus "[| b ist_monom; a kleiner b |] ==> \
115.45 + \(- b + a) = (a - b)"
115.46 + tausche_vor_minus "[| b ist_monom; a kleiner b |] ==> \
115.47 + \(- b - a) = (-a - b)"
115.48 + tausche_plus_plus "b kleiner c ==> (a + c + b) = (a + b + c)"
115.49 + tausche_plus_minus "b kleiner c ==> (a + c - b) = (a - b + c)"
115.50 + tausche_minus_plus "b kleiner c ==> (a - c + b) = (a + b - c)"
115.51 + tausche_minus_minus "b kleiner c ==> (a - c - b) = (a - b - c)"
115.52 +
115.53 + (*commute with invariant (a.b).c -association*)
115.54 + tausche_mal "[| b is_atom; a kleiner b |] ==> \
115.55 + \(b * a) = (a * b)"
115.56 + tausche_vor_mal "[| b is_atom; a kleiner b |] ==> \
115.57 + \(-b * a) = (-a * b)"
115.58 + tausche_mal_mal "[| c is_atom; b kleiner c |] ==> \
115.59 + \(x * c * b) = (x * b * c)"
115.60 + x_quadrat "(x * a) * a = x * a ^^^ 2"
115.61 +
115.62 +
115.63 + subtrahiere "[| l is_const; m is_const |] ==> \
115.64 + \m * v - l * v = (m - l) * v"
115.65 + subtrahiere_von_1 "[| l is_const |] ==> \
115.66 + \v - l * v = (1 - l) * v"
115.67 + subtrahiere_1 "[| l is_const; m is_const |] ==> \
115.68 + \m * v - v = (m - 1) * v"
115.69 +
115.70 + subtrahiere_x_plus_minus "[| l is_const; m is_const |] ==> \
115.71 + \(x + m * v) - l * v = x + (m - l) * v"
115.72 + subtrahiere_x_plus1_minus "[| l is_const |] ==> \
115.73 + \(x + v) - l * v = x + (1 - l) * v"
115.74 + subtrahiere_x_plus_minus1 "[| m is_const |] ==> \
115.75 + \(x + m * v) - v = x + (m - 1) * v"
115.76 +
115.77 + subtrahiere_x_minus_plus "[| l is_const; m is_const |] ==> \
115.78 + \(x - m * v) + l * v = x + (-m + l) * v"
115.79 + subtrahiere_x_minus1_plus "[| l is_const |] ==> \
115.80 + \(x - v) + l * v = x + (-1 + l) * v"
115.81 + subtrahiere_x_minus_plus1 "[| m is_const |] ==> \
115.82 + \(x - m * v) + v = x + (-m + 1) * v"
115.83 +
115.84 + subtrahiere_x_minus_minus "[| l is_const; m is_const |] ==> \
115.85 + \(x - m * v) - l * v = x + (-m - l) * v"
115.86 + subtrahiere_x_minus1_minus"[| l is_const |] ==> \
115.87 + \(x - v) - l * v = x + (-1 - l) * v"
115.88 + subtrahiere_x_minus_minus1"[| m is_const |] ==> \
115.89 + \(x - m * v) - v = x + (-m - 1) * v"
115.90 +
115.91 +
115.92 + addiere_vor_minus "[| l is_const; m is_const |] ==> \
115.93 + \- (l * v) + m * v = (-l + m) * v"
115.94 + addiere_eins_vor_minus "[| m is_const |] ==> \
115.95 + \- v + m * v = (-1 + m) * v"
115.96 + subtrahiere_vor_minus "[| l is_const; m is_const |] ==> \
115.97 + \- (l * v) - m * v = (-l - m) * v"
115.98 + subtrahiere_eins_vor_minus"[| m is_const |] ==> \
115.99 + \- v - m * v = (-1 - m) * v"
115.100 +
115.101 + vorzeichen_minus_weg1 "l kleiner 0 ==> a + l * b = a - -1*l * b"
115.102 + vorzeichen_minus_weg2 "l kleiner 0 ==> a - l * b = a + -1*l * b"
115.103 + vorzeichen_minus_weg3 "l kleiner 0 ==> k + a - l * b = k + a + -1*l * b"
115.104 + vorzeichen_minus_weg4 "l kleiner 0 ==> k - a - l * b = k - a + -1*l * b"
115.105 +
115.106 + (*klammer_plus_plus = (real_add_assoc RS sym)*)
115.107 + klammer_plus_minus "a + (b - c) = (a + b) - c"
115.108 + klammer_minus_plus "a - (b + c) = (a - b) - c"
115.109 + klammer_minus_minus "a - (b - c) = (a - b) + c"
115.110 +
115.111 + klammer_mult_minus "a * (b - c) = a * b - a * c"
115.112 + klammer_minus_mult "(b - c) * a = b * a - c * a"
115.113 +
115.114 +
115.115 +
115.116 +end
115.117 +
116.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
116.2 +++ b/src/Tools/isac/Knowledge/RatEq.ML Wed Aug 25 16:20:07 2010 +0200
116.3 @@ -0,0 +1,203 @@
116.4 +(*.(c) by Richard Lang, 2003 .*)
116.5 +(* collecting all knowledge for RationalEquations
116.6 + created by: rlang
116.7 + date: 02.09
116.8 + changed by: rlang
116.9 + last change by: rlang
116.10 + date: 02.11.29
116.11 +*)
116.12 +
116.13 +(* use"Knowledge/RatEq.ML";
116.14 + use"RatEq.ML";
116.15 + remove_thy"RatEq";
116.16 + use_thy"Isac";
116.17 +
116.18 + use"ROOT.ML";
116.19 + cd"IsacKnowledge";
116.20 + *)
116.21 +"******* RatEq.ML begin *******";
116.22 +
116.23 +theory' := overwritel (!theory', [("RatEq.thy",RatEq.thy)]);
116.24 +
116.25 +(*-------------------------functions-----------------------*)
116.26 +(* is_rateqation_in becomes true, if a bdv is in the denominator of a fraction*)
116.27 +fun is_rateqation_in t v =
116.28 + let
116.29 + fun coeff_in c v = member op = (vars c) v;
116.30 + fun finddivide (_ $ _ $ _ $ _) v = raise error("is_rateqation_in:")
116.31 + (* at the moment there is no term like this, but ....*)
116.32 + | finddivide (t as (Const ("HOL.divide",_) $ _ $ b)) v = coeff_in b v
116.33 + | finddivide (_ $ t1 $ t2) v = (finddivide t1 v)
116.34 + orelse (finddivide t2 v)
116.35 + | finddivide (_ $ t1) v = (finddivide t1 v)
116.36 + | finddivide _ _ = false;
116.37 + in
116.38 + finddivide t v
116.39 + end;
116.40 +
116.41 +fun eval_is_ratequation_in _ _ (p as (Const ("RatEq.is'_ratequation'_in",_) $ t $ v)) _ =
116.42 + if is_rateqation_in t v then
116.43 + SOME ((term2str p) ^ " = True",
116.44 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
116.45 + else SOME ((term2str p) ^ " = True",
116.46 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
116.47 + | eval_is_ratequation_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
116.48 +
116.49 +(*-------------------------rulse-----------------------*)
116.50 +val RatEq_prls = (*15.10.02:just the following order due to subterm evaluation*)
116.51 + append_rls "RatEq_prls" e_rls
116.52 + [Calc ("Atools.ident",eval_ident "#ident_"),
116.53 + Calc ("Tools.matches",eval_matches ""),
116.54 + Calc ("Tools.lhs" ,eval_lhs ""),
116.55 + Calc ("Tools.rhs" ,eval_rhs ""),
116.56 + Calc ("RatEq.is'_ratequation'_in",eval_is_ratequation_in ""),
116.57 + Calc ("op =",eval_equal "#equal_"),
116.58 + Thm ("not_true",num_str not_true),
116.59 + Thm ("not_false",num_str not_false),
116.60 + Thm ("and_true",num_str and_true),
116.61 + Thm ("and_false",num_str and_false),
116.62 + Thm ("or_true",num_str or_true),
116.63 + Thm ("or_false",num_str or_false)
116.64 + ];
116.65 +
116.66 +
116.67 +(*rls = merge_rls erls Poly_erls *)
116.68 +val rateq_erls =
116.69 + remove_rls "rateq_erls" (*WN: ein Hack*)
116.70 + (merge_rls "is_ratequation_in" calculate_Rational
116.71 + (append_rls "is_ratequation_in"
116.72 + Poly_erls
116.73 + [(*Calc ("HOL.divide", eval_cancel "#divide_"),*)
116.74 + Calc ("RatEq.is'_ratequation'_in",
116.75 + eval_is_ratequation_in "")
116.76 +
116.77 + ]))
116.78 + [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*)
116.79 + Thm ("or_commute",num_str or_commute) (*WN: ein Hack*)
116.80 + ];
116.81 +ruleset' := overwritelthy thy (!ruleset',
116.82 + [("rateq_erls",rateq_erls)(*FIXXXME:del with rls.rls'*)
116.83 + ]);
116.84 +
116.85 +
116.86 +val RatEq_crls =
116.87 + remove_rls "RatEq_crls" (*WN: ein Hack*)
116.88 + (merge_rls "is_ratequation_in" calculate_Rational
116.89 + (append_rls "is_ratequation_in"
116.90 + Poly_erls
116.91 + [(*Calc ("HOL.divide", eval_cancel "#divide_"),*)
116.92 + Calc ("RatEq.is'_ratequation'_in",
116.93 + eval_is_ratequation_in "")
116.94 + ]))
116.95 + [Thm ("and_commute",num_str and_commute), (*WN: ein Hack*)
116.96 + Thm ("or_commute",num_str or_commute) (*WN: ein Hack*)
116.97 + ];
116.98 +
116.99 +val RatEq_eliminate = prep_rls(
116.100 + Rls {id = "RatEq_eliminate", preconds = [], rew_ord = ("termlessI",termlessI),
116.101 + erls = rateq_erls, srls = Erls, calc = [],
116.102 + (*asm_thm = [("rat_mult_denominator_both",""),("rat_mult_denominator_left",""),
116.103 + ("rat_mult_denominator_right","")],*)
116.104 + rules = [
116.105 + Thm("rat_mult_denominator_both",num_str rat_mult_denominator_both),
116.106 + (* a/b=c/d -> ad=cb *)
116.107 + Thm("rat_mult_denominator_left",num_str rat_mult_denominator_left),
116.108 + (* a =c/d -> ad=c *)
116.109 + Thm("rat_mult_denominator_right",num_str rat_mult_denominator_right)
116.110 + (* a/b=c -> a=cb *)
116.111 + ],
116.112 + scr = Script ((term_of o the o (parse thy)) "empty_script")
116.113 + }:rls);
116.114 +ruleset' := overwritelthy thy (!ruleset',
116.115 + [("RatEq_eliminate",RatEq_eliminate)
116.116 + ]);
116.117 +
116.118 +
116.119 +
116.120 +
116.121 +val RatEq_simplify = prep_rls(
116.122 + Rls {id = "RatEq_simplify", preconds = [], rew_ord = ("termlessI",termlessI),
116.123 + erls = rateq_erls, srls = Erls, calc = [],
116.124 + (*asm_thm = [("rat_double_rat_1",""),("rat_double_rat_2",""),
116.125 + ("rat_double_rat_3","")],*)
116.126 + rules = [
116.127 + Thm("real_rat_mult_1",num_str real_rat_mult_1),
116.128 + (*a*(b/c) = (a*b)/c*)
116.129 + Thm("real_rat_mult_2",num_str real_rat_mult_2),
116.130 + (*(a/b)*(c/d) = (a*c)/(b*d)*)
116.131 + Thm("real_rat_mult_3",num_str real_rat_mult_3),
116.132 + (* (a/b)*c = (a*c)/b*)
116.133 + Thm("real_rat_pow",num_str real_rat_pow),
116.134 + (*(a/b)^^^2 = a^^^2/b^^^2*)
116.135 + Thm("real_diff_minus",num_str real_diff_minus),
116.136 + (* a - b = a + (-1) * b *)
116.137 + Thm("rat_double_rat_1",num_str rat_double_rat_1),
116.138 + (* (a / (c/d) = (a*d) / c) *)
116.139 + Thm("rat_double_rat_2",num_str rat_double_rat_2),
116.140 + (* ((a/b) / (c/d) = (a*d) / (b*c)) *)
116.141 + Thm("rat_double_rat_3",num_str rat_double_rat_3)
116.142 + (* ((a/b) / c = a / (b*c) ) *)
116.143 + ],
116.144 + scr = Script ((term_of o the o (parse thy)) "empty_script")
116.145 + }:rls);
116.146 +ruleset' := overwritelthy thy (!ruleset',
116.147 + [("RatEq_simplify",RatEq_simplify)
116.148 + ]);
116.149 +
116.150 +(*-------------------------Problem-----------------------*)
116.151 +(*
116.152 +(get_pbt ["rational","univariate","equation"]);
116.153 +show_ptyps();
116.154 +*)
116.155 +store_pbt
116.156 + (prep_pbt RatEq.thy "pbl_equ_univ_rat" [] e_pblID
116.157 + (["rational","univariate","equation"],
116.158 + [("#Given" ,["equality e_","solveFor v_"]),
116.159 + ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]),
116.160 + ("#Find" ,["solutions v_i_"])
116.161 + ],
116.162 +
116.163 + RatEq_prls, SOME "solve (e_::bool, v_)",
116.164 + [["RatEq","solve_rat_equation"]]));
116.165 +
116.166 +
116.167 +(*-------------------------methods-----------------------*)
116.168 +store_met
116.169 + (prep_met RatEq.thy "met_rateq" [] e_metID
116.170 + (["RatEq"],
116.171 + [],
116.172 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
116.173 + crls=RatEq_crls, nrls=norm_Rational
116.174 + (*, asm_rls=[],asm_thm=[]*)}, "empty_script"));
116.175 +store_met
116.176 + (prep_met RatEq.thy "met_rat_eq" [] e_metID
116.177 + (["RatEq","solve_rat_equation"],
116.178 + [("#Given" ,["equality e_","solveFor v_"]),
116.179 + ("#Where" ,["(e_::bool) is_ratequation_in (v_::real)"]),
116.180 + ("#Find" ,["solutions v_i_"])
116.181 + ],
116.182 + {rew_ord'="termlessI",
116.183 + rls'=rateq_erls,
116.184 + srls=e_rls,
116.185 + prls=RatEq_prls,
116.186 + calc=[],
116.187 + crls=RatEq_crls, nrls=norm_Rational(*,
116.188 + asm_rls=[],
116.189 + asm_thm=[("rat_double_rat_1",""),("rat_double_rat_2",""),("rat_double_rat_3",""),
116.190 + ("rat_mult_denominator_both",""),("rat_mult_denominator_left",""),
116.191 + ("rat_mult_denominator_right","")]*)},
116.192 + "Script Solve_rat_equation (e_::bool) (v_::real) = \
116.193 + \(let e_ = ((Repeat(Try (Rewrite_Set RatEq_simplify True))) @@ \
116.194 + \ (Repeat(Try (Rewrite_Set norm_Rational False))) @@ \
116.195 + \ (Repeat(Try (Rewrite_Set common_nominator_p False))) @@ \
116.196 + \ (Repeat(Try (Rewrite_Set RatEq_eliminate True)))) e_;\
116.197 + \ (L_::bool list) = (SubProblem (RatEq_,[univariate,equation], \
116.198 + \ [no_met]) [bool_ e_, real_ v_]) \
116.199 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
116.200 + ));
116.201 +
116.202 +calclist':= overwritel (!calclist',
116.203 + [("is_ratequation_in", ("RatEq.is_ratequation_in",
116.204 + eval_is_ratequation_in ""))
116.205 + ]);
116.206 +"******* RatEq.ML end *******";
117.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
117.2 +++ b/src/Tools/isac/Knowledge/RatEq.thy Wed Aug 25 16:20:07 2010 +0200
117.3 @@ -0,0 +1,67 @@
117.4 +(*.(c) by Richard Lang, 2003 .*)
117.5 +(* theory collecting all knowledge for RationalEquations
117.6 + created by: rlang
117.7 + date: 02.08.12
117.8 + changed by: rlang
117.9 + last change by: rlang
117.10 + date: 02.11.28
117.11 +*)
117.12 +
117.13 +(*
117.14 + RL.020812
117.15 + use_thy"knowledge/RatEq";
117.16 + use_thy"RatEq";
117.17 + use_thy_only"RatEq";
117.18 +
117.19 + remove_thy"RatEq";
117.20 + use_thy"Isac";
117.21 +
117.22 + use"ROOT.ML";
117.23 + cd"knowledge";
117.24 + *)
117.25 +RatEq = Rational +
117.26 +
117.27 +(*-------------------- consts------------------------------------------------*)
117.28 +consts
117.29 +
117.30 + is'_ratequation'_in :: "[bool, real] => bool" ("_ is'_ratequation'_in _")
117.31 +
117.32 + (*----------------------scripts-----------------------*)
117.33 + Solve'_rat'_equation
117.34 + :: "[bool,real, \
117.35 + \ bool list] => bool list"
117.36 + ("((Script Solve'_rat'_equation (_ _ =))// \
117.37 + \ (_))" 9)
117.38 +
117.39 +(*-------------------- rules------------------------------------------------*)
117.40 +rules
117.41 + (* FIXME also in Poly.thy def. --> FIXED*)
117.42 + (*real_diff_minus
117.43 + "a - b = a + (-1) * b"*)
117.44 + real_rat_mult_1
117.45 + "a*(b/c) = (a*b)/c"
117.46 + real_rat_mult_2
117.47 + "(a/b)*(c/d) = (a*c)/(b*d)"
117.48 + real_rat_mult_3
117.49 + "(a/b)*c = (a*c)/b"
117.50 + real_rat_pow
117.51 + "(a/b)^^^2 = a^^^2/b^^^2"
117.52 +
117.53 + rat_double_rat_1
117.54 + "[|Not(c=0); Not(d=0)|] ==> (a / (c/d) = (a*d) / c)"
117.55 + rat_double_rat_2
117.56 + "[|Not(b=0);Not(c=0); Not(d=0)|] ==> ((a/b) / (c/d) = (a*d) / (b*c))"
117.57 + rat_double_rat_3
117.58 + "[|Not(b=0);Not(c=0)|] ==> ((a/b) / c = a / (b*c))"
117.59 +
117.60 +
117.61 + (* equation to same denominator *)
117.62 + rat_mult_denominator_both
117.63 + "[|Not(b=0); Not(d=0)|] ==> ((a::real) / b = c / d) = (a*d = c*b)"
117.64 + rat_mult_denominator_left
117.65 + "[|Not(d=0)|] ==> ((a::real) = c / d) = (a*d = c)"
117.66 + rat_mult_denominator_right
117.67 + "[|Not(b=0)|] ==> ((a::real) / b = c) = (a = c*b)"
117.68 +
117.69 +
117.70 +end
118.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
118.2 +++ b/src/Tools/isac/Knowledge/Rational-WN.sml Wed Aug 25 16:20:07 2010 +0200
118.3 @@ -0,0 +1,257 @@
118.4 +(*Stefan K.*)
118.5 +
118.6 +(*protokoll 14.3.02 --------------------------------------------------
118.7 +val ct = parse thy "(a + #1)//(#2*a^^^#2 - #2)";
118.8 +val t = (term_of o the) ct;
118.9 +atomt t;
118.10 +val ct = parse thy "not (#1+a)"; (*HOL.thy ?*)
118.11 +val t = (term_of o the) ct;
118.12 +atomt t;
118.13 +val ct = parse thy "x"; (*momentan ist alles 'real'*)
118.14 +val t = (term_of o the) ct;
118.15 +atomty t;
118.16 +val ct = parse thy "(x::int)"; (* !!! *)
118.17 +val t = (term_of o the) ct;
118.18 +atomty t;
118.19 +
118.20 +val ct = parse thy "(x::int)*(y::real)"; (*momentan ist alles 'real'*)
118.21 +
118.22 +val Const ("RatArith.cancel",_) $ zaehler $ nenner = t;
118.23 +---------------------------------------------------------------------*)
118.24 +
118.25 +
118.26 +(*diese vvv funktionen kommen nach src/Isa99/term.sml -------------*)
118.27 +fun term2str t =
118.28 + let fun ato (Const(a,T)) n =
118.29 + "\n"^indent n^"Const ( "^a^")"
118.30 + | ato (Free (a,T)) n =
118.31 + "\n"^indent n^"Free ( "^a^", "^")"
118.32 + | ato (Var ((a,ix),T)) n =
118.33 + "\n"^indent n^"Var (("^a^", "^string_of_int ix^"), "^")"
118.34 + | ato (Bound ix) n =
118.35 + "\n"^indent n^"Bound "^string_of_int ix
118.36 + | ato (Abs(a,T,body)) n =
118.37 + "\n"^indent n^"Abs( "^a^",.."^ato body (n+1)
118.38 + | ato (f$t') n = ato f n^ato t' (n+1)
118.39 + in "\n-------------"^ato t 0^"\n" end;
118.40 +fun free2int (t as Free (s, _)) = (((the o int_of_str) s)
118.41 + handle _ => raise error ("free2int: "^term2str t))
118.42 + | free2int t = raise error ("free2int: "^term2str t);
118.43 +(*diese ^^^ funktionen kommen nach src/Isa99/term.sml -------------*)
118.44 +
118.45 +
118.46 +(* remark on exceptions: 'error' is implemented by Isabelle
118.47 + as the typical system error *)
118.48 +
118.49 +
118.50 +type poly = int list;
118.51 +
118.52 +(* transform a Isabelle-term t into internal polynomial format
118.53 + preconditions for t:
118.54 + a-b -> a+(-b)
118.55 + x^1 -> x
118.56 + term ordered ascending
118.57 + parentheses right side (caused by 'ordered rewriting')
118.58 + variable as power (not as product) *)
118.59 +
118.60 +fun mono (Const ("RatArith.pow",_) $ t1 $ t2) v g =
118.61 + if t1 = v then ((replicate ((free2int t2) - g) 0) @ [1]) : poly
118.62 + else raise error ("term2poly.1 "^term2str t1)
118.63 + | mono (t as Const ("op *",_) $ t1 $
118.64 + (Const ("RatArith.pow",_) $ t2 $ t3)) v g =
118.65 + if t2 = v then (replicate ((free2int t3) - g) 0) @ [free2int t1]
118.66 + else raise error ("term2poly.2 "^term2str t)
118.67 + | mono t _ _ = raise error ("term2poly.3 "^term2str t);
118.68 +
118.69 +fun poly (Const ("op +",_) $ t1 $ t2) v g =
118.70 + let val l = mono t1 v g
118.71 + in (l @ (poly t2 v ((length l) + g))) end
118.72 + | poly t v g = mono t v g;
118.73 +
118.74 +fun term2poly (t as Free (s, _)) v =
118.75 + if t = v then SOME ([0,1] : poly) else (SOME [(the o int_of_str) s]
118.76 + handle _ => NONE)
118.77 + | term2poly (Const ("op *",_) $ (Free (s1,_)) $ (t as Free (s2,_))) v =
118.78 + if t = v then SOME [0, (the o int_of_str) s1] else NONE
118.79 + | term2poly (Const ("op +",_) $ (Free (s1,_)) $ t) v =
118.80 + SOME ([(the o int_of_str) s1] @ (poly t v 1))
118.81 + | term2poly t v =
118.82 + SOME (poly t v 0) handle _ => NONE;
118.83 +
118.84 +(*tests*)
118.85 +val v = (term_of o the o (parse thy)) "x::real";
118.86 +val t = (term_of o the o (parse thy)) "#-1::real";
118.87 +term2poly t v;
118.88 +val t = (term_of o the o (parse thy)) "x::real";
118.89 +term2poly t v;
118.90 +val t = (term_of o the o (parse thy)) "#1 * x::real"; (*FIXME: drop it*)
118.91 +term2poly t v;
118.92 +val t = (term_of o the o (parse thy)) "x^^^#1"; (*FIXME: drop it*)
118.93 +term2poly t v;
118.94 +val t = (term_of o the o (parse thy)) "x^^^#3";
118.95 +term2poly t v;
118.96 +val t = (term_of o the o (parse thy)) "#3 * x^^^#3";
118.97 +term2poly t v;
118.98 +val t = (term_of o the o (parse thy)) "#-1 + #3 * x^^^#3";
118.99 +term2poly t v;
118.100 +val t = (term_of o the o (parse thy)) "#-1 + (#3 * x^^^#3 + #5 * x^^^#5)";
118.101 +term2poly t v;
118.102 +val t = (term_of o the o (parse thy))
118.103 + "#-1 + (#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7))";
118.104 +term2poly t v;
118.105 +val t = (term_of o the o (parse thy))
118.106 + "#3 * x^^^#3 + (#5 * x^^^#5 + #7 * x^^^#7)";
118.107 +term2poly t v;
118.108 +
118.109 +
118.110 +fun is_polynomial_in t v =
118.111 + case term2poly t v of SOME _ => true | NONE => false;
118.112 +
118.113 +(* transform the internal polynomial p into an Isabelle term t
118.114 + where t meets the preconditions of term2poly
118.115 +val mk_mono =
118.116 + fn : typ -> of the coefficients
118.117 + typ -> of the unknown
118.118 + typ -> of the monomial and polynomial
118.119 + typ -> of the exponent of the unknown
118.120 + int -> the coefficient <> 0
118.121 + string -> the unknown
118.122 + int -> the degree, i.e. the value of the exponent
118.123 + term
118.124 +remark: all the typs above are "RealDef.real" due to the typs of * + ^
118.125 +which may change in the future
118.126 +*)
118.127 +fun mk_mono cT vT pT eT c v g =
118.128 + case g of
118.129 + 0 => Free (str_of_int c, cT) (*will cause problems with diff.typs*)
118.130 + | 1 => if c = 1 then Free (v, vT)
118.131 + else Const ("op *", [cT, vT]--->pT) $
118.132 + Free (str_of_int c, cT) $ Free (v, vT)
118.133 + | n => if c = 1 then (Const ("RatArith.pow", [vT, eT]--->pT) $
118.134 + Free (v, vT) $ Free (str_of_int g, eT))
118.135 + else Const ("op *", [cT, vT]--->pT) $
118.136 + Free (str_of_int c, cT) $
118.137 + (Const ("RatArith.pow", [vT, eT]--->pT) $
118.138 + Free (v, vT) $ Free (str_of_int g, eT));
118.139 +(*tests*)
118.140 +val cT = HOLogic.realT; val vT = HOLogic.realT; val pT = HOLogic.realT;
118.141 +val eT = HOLogic.realT;
118.142 +val t = mk_mono cT vT pT eT ~5 "x" 5;
118.143 +(cterm_of thy) t;
118.144 +val t = mk_mono cT vT pT eT ~1 "x" 0;
118.145 +(cterm_of thy) t;
118.146 +val t = mk_mono cT vT pT eT 1 "x" 1;
118.147 +(cterm_of thy) t;
118.148 +
118.149 +
118.150 +fun mk_sum pT t1 t2 = Const ("op +", [pT, pT]--->pT) $ t1 $ t2;
118.151 +
118.152 +
118.153 +fun poly2term cT vT pT eT ([p]:poly) v = mk_mono cT vT pT eT p v 0
118.154 + | poly2term cT vT pT eT (p:poly) v =
118.155 + let
118.156 + fun mk_poly cT vT pT eT [] t v g = t
118.157 + | mk_poly cT vT pT eT [p] t v g =
118.158 + if p = 0 then t
118.159 + else mk_sum pT (mk_mono cT vT pT eT p v g) t
118.160 + | mk_poly cT vT pT eT (p::ps) t v g =
118.161 + if p = 0 then mk_poly cT vT pT eT ps t v (g-1)
118.162 + else mk_poly cT vT pT eT ps
118.163 + (mk_sum pT (mk_mono cT vT pT eT p v g) t) v (g-1)
118.164 + val (p'::ps') = rev p
118.165 + val g = (length p) - 1
118.166 + in mk_poly cT vT pT eT ps' (mk_mono cT vT pT eT p' v g) v (g-1) end;
118.167 +
118.168 +(*tests*)
118.169 +val t = poly2term cT vT pT eT [~1] "x";
118.170 +(cterm_of thy) t;
118.171 +val t = poly2term cT vT pT eT [0,1] "x";
118.172 +(cterm_of thy) t;
118.173 +val t = poly2term cT vT pT eT [0,0,0,1] "x";
118.174 +(cterm_of thy) t;
118.175 +val t = poly2term cT vT pT eT [0,0,0,3] "x";
118.176 +(cterm_of thy) t;
118.177 +val t = poly2term cT vT pT eT [~1,0,0,3] "x";
118.178 +(cterm_of thy) t;
118.179 +val t = poly2term cT vT pT eT [~1,0,0,3,0,5] "x";
118.180 +(cterm_of thy) t;
118.181 +val t = poly2term cT vT pT eT [~1,0,0,3,0,5,0,7] "x";
118.182 +(cterm_of thy) t;
118.183 +val t = poly2term cT vT pT eT [0,0,0,3,0,5,0,7] "x";
118.184 +(cterm_of thy) t;
118.185 +
118.186 +"***************************************************************************";
118.187 +"* reverse-rewriting 12.8.02 *";
118.188 +"***************************************************************************";
118.189 +fun rewrite_set_' thy rls put_asm ruless ct =
118.190 + case ruless of
118.191 + Rrls _ => raise error "rewrite_set_' not for Rrls"
118.192 + | Rls _ =>
118.193 + let
118.194 + datatype switch = Appl | Noap;
118.195 + fun rew_once ruls asm ct Noap [] = (ct,asm)
118.196 + | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls
118.197 + | rew_once ruls asm ct apno (rul::thms) =
118.198 + case rul of
118.199 + Thm (thmid, thm) =>
118.200 + (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
118.201 + rls put_asm (thm_of_thm rul) ct of
118.202 + NONE => rew_once ruls asm ct apno thms
118.203 + | SOME (ct',asm') =>
118.204 + rew_once ruls (asm union asm') ct' Appl (rul::thms))
118.205 + | Calc (cc as (op_,_)) =>
118.206 + (case get_calculation_ thy cc ct of
118.207 + NONE => rew_once ruls asm ct apno thms
118.208 + | SOME (thmid, thm') =>
118.209 + let
118.210 + val pairopt =
118.211 + rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
118.212 + rls put_asm thm' ct;
118.213 + val _ = if pairopt <> NONE then ()
118.214 + else raise error("rewrite_set_, rewrite_ \""^
118.215 + (string_of_thmI thm')^"\" \""^
118.216 + (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE")
118.217 + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end);
118.218 + val ruls = (#rules o rep_rls) ruless;
118.219 + val (ct',asm') = rew_once ruls [] ct Noap ruls;
118.220 + in if ct = ct' then NONE else SOME (ct',asm') end;
118.221 +
118.222 +(*
118.223 +fun reverse_rewrite t1 t2 rls =
118.224 +*)
118.225 +fun rewrite_set_' thy rls put_asm ruless ct =
118.226 + case ruless of
118.227 + Rrls _ => raise error "rewrite_set_' not for Rrls"
118.228 + | Rls _ =>
118.229 + let
118.230 + datatype switch = Appl | Noap;
118.231 + fun rew_once ruls asm ct Noap [] = (ct,asm)
118.232 + | rew_once ruls asm ct Appl [] = rew_once ruls asm ct Noap ruls
118.233 + | rew_once ruls asm ct apno (rul::thms) =
118.234 + case rul of
118.235 + Thm (thmid, thm) =>
118.236 + (case rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
118.237 + rls put_asm (thm_of_thm rul) ct of
118.238 + NONE => rew_once ruls asm ct apno thms
118.239 + | SOME (ct',asm') =>
118.240 + rew_once ruls (asm union asm') ct' Appl (rul::thms))
118.241 + | Calc (cc as (op_,_)) =>
118.242 + (case get_calculation_ thy cc ct of
118.243 + NONE => rew_once ruls asm ct apno thms
118.244 + | SOME (thmid, thm') =>
118.245 + let
118.246 + val pairopt =
118.247 + rewrite_ thy ((snd o #rew_ord o rep_rls) ruless)
118.248 + rls put_asm thm' ct;
118.249 + val _ = if pairopt <> NONE then ()
118.250 + else raise error("rewrite_set_, rewrite_ \""^
118.251 + (string_of_thmI thm')^"\" \""^
118.252 + (Syntax.string_of_term (thy2ctxt thy) ct)^"\" = NONE")
118.253 + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end);
118.254 + val ruls = (#rules o rep_rls) ruless;
118.255 + val (ct',asm') = rew_once ruls [] ct Noap ruls;
118.256 + in if ct = ct' then NONE else SOME (ct',asm') end;
118.257 +
118.258 + realpow_two;
118.259 + real_mult_div_cancel1;
118.260 +
119.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
119.2 +++ b/src/Tools/isac/Knowledge/Rational.ML Wed Aug 25 16:20:07 2010 +0200
119.3 @@ -0,0 +1,3786 @@
119.4 +(*.calculate in rationals: gcd, lcm, etc.
119.5 + (c) Stefan Karnel 2002
119.6 + Institute for Mathematics D and Institute for Software Technology,
119.7 + TU-Graz SS 2002
119.8 + Use is subject to license terms.
119.9 +
119.10 +use"Knowledge/Rational.ML";
119.11 +use"Rational.ML";
119.12 +
119.13 +remove_thy"Rational";
119.14 +use_thy"Knowledge/Isac";
119.15 +****************************************************************.*)
119.16 +
119.17 +(*.*****************************************************************
119.18 + Remark on notions in the documentation below:
119.19 + referring to the remark on 'polynomials' in Poly.sml we use
119.20 + [2] 'polynomial' normalform (Polynom)
119.21 + [3] 'expanded_term' normalform (Ausmultiplizierter Term),
119.22 + where normalform [2] is a special case of [3], i.e. [3] implies [2].
119.23 + Instead of
119.24 + 'fraction with numerator and nominator both in normalform [2]'
119.25 + 'fraction with numerator and nominator both in normalform [3]'
119.26 + we say:
119.27 + 'fraction in normalform [2]'
119.28 + 'fraction in normalform [3]'
119.29 + or
119.30 + 'fraction [2]'
119.31 + 'fraction [3]'.
119.32 + a 'simple fraction' is a term with '/' as outmost operator and
119.33 + numerator and nominator in normalform [2] or [3].
119.34 +****************************************************************.*)
119.35 +
119.36 +signature RATIONALI =
119.37 +sig
119.38 + type mv_monom
119.39 + type mv_poly
119.40 + val add_fraction_ : theory -> term -> (term * term list) option
119.41 + val add_fraction_p_ : theory -> term -> (term * term list) option
119.42 + val calculate_Rational : rls
119.43 + val calc_rat_erls:rls
119.44 + val cancel : rls
119.45 + val cancel_ : theory -> term -> (term * term list) option
119.46 + val cancel_p : rls
119.47 + val cancel_p_ : theory -> term -> (term * term list) option
119.48 + val common_nominator : rls
119.49 + val common_nominator_ : theory -> term -> (term * term list) option
119.50 + val common_nominator_p : rls
119.51 + val common_nominator_p_ : theory -> term -> (term * term list) option
119.52 + val eval_is_expanded : string -> 'a -> term -> theory ->
119.53 + (string * term) option
119.54 + val expanded2polynomial : term -> term option
119.55 + val factout_ : theory -> term -> (term * term list) option
119.56 + val factout_p_ : theory -> term -> (term * term list) option
119.57 + val is_expanded : term -> bool
119.58 + val is_polynomial : term -> bool
119.59 +
119.60 + val mv_gcd : (int * int list) list -> mv_poly -> mv_poly
119.61 + val mv_lcm : mv_poly -> mv_poly -> mv_poly
119.62 +
119.63 + val norm_expanded_rat_ : theory -> term -> (term * term list) option
119.64 +(*WN0602.2.6.pull into struct !!!
119.65 + val norm_Rational : rls(*.normalizes an arbitrary rational term without
119.66 + roots into a simple and canceled fraction
119.67 + with normalform [2].*)
119.68 +*)
119.69 +(*val norm_rational_p : 19.10.02 missing FIXXXXXXXXXXXXME
119.70 + rls (*.normalizes an rational term [2] without
119.71 + roots into a simple and canceled fraction
119.72 + with normalform [2].*)
119.73 +*)
119.74 + val norm_rational_ : theory -> term -> (term * term list) option
119.75 + val polynomial2expanded : term -> term option
119.76 + val rational_erls :
119.77 + rls (*.evaluates an arbitrary rational term with numerals.*)
119.78 +
119.79 +(*WN0210???SK: fehlen Funktionen, die exportiert werden sollen ? *)
119.80 +end
119.81 +
119.82 +(*.**************************************************************************
119.83 +survey on the functions
119.84 +~~~~~~~~~~~~~~~~~~~~~~~
119.85 + [2] 'polynomial' :rls | [3]'expanded_term':rls
119.86 +--------------------:------------------+-------------------:-----------------
119.87 + factout_p_ : | factout_ :
119.88 + cancel_p_ : | cancel_ :
119.89 + :cancel_p | :cancel
119.90 +--------------------:------------------+-------------------:-----------------
119.91 + common_nominator_p_: | common_nominator_ :
119.92 + :common_nominator_p| :common_nominator
119.93 + add_fraction_p_ : | add_fraction_ :
119.94 +--------------------:------------------+-------------------:-----------------
119.95 +???SK :norm_rational_p | :norm_rational
119.96 +
119.97 +This survey shows only the principal functions for reuse, and the identifiers
119.98 +of the rls exported. The list below shows some more useful functions.
119.99 +
119.100 +
119.101 +conversion from Isabelle-term to internal representation
119.102 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
119.103 +
119.104 +... BITTE FORTSETZEN ...
119.105 +
119.106 +polynomial2expanded = ...
119.107 +expanded2polynomial = ...
119.108 +
119.109 +remark: polynomial2expanded o expanded2polynomial = I,
119.110 + where 'o' is function chaining, and 'I' is identity WN0210???SK
119.111 +
119.112 +functions for greatest common divisor and canceling
119.113 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
119.114 +mv_gcd
119.115 +factout_
119.116 +factout_p_
119.117 +cancel_
119.118 +cancel_p_
119.119 +
119.120 +functions for least common multiple and addition of fractions
119.121 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
119.122 +mv_lcm
119.123 +common_nominator_
119.124 +common_nominator_p_
119.125 +add_fraction_ (*.add 2 or more fractions.*)
119.126 +add_fraction_p_ (*.add 2 or more fractions.*)
119.127 +
119.128 +functions for normalform of rationals
119.129 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
119.130 +WN0210???SK interne Funktionen f"ur norm_rational:
119.131 + schaffen diese SML-Funktionen wirklich ganz allgemeine Terme ?
119.132 +
119.133 +norm_rational_
119.134 +norm_expanded_rat_
119.135 +
119.136 +**************************************************************************.*)
119.137 +
119.138 +
119.139 +(*##*)
119.140 +structure RationalI : RATIONALI =
119.141 +struct
119.142 +(*##*)
119.143 +
119.144 +infix mem ins union; (*WN100819 updating to Isabelle2009-2*)
119.145 +fun x mem [] = false
119.146 + | x mem (y :: ys) = x = y orelse x mem ys;
119.147 +fun (x ins xs) = if x mem xs then xs else x :: xs;
119.148 +fun xs union [] = xs
119.149 + | [] union ys = ys
119.150 + | (x :: xs) union ys = xs union (x ins ys);
119.151 +
119.152 +(*. gcd of integers .*)
119.153 +(* die gcd Funktion von Isabelle funktioniert nicht richtig !!! *)
119.154 +fun gcd_int a b = if b=0 then a
119.155 + else gcd_int b (a mod b);
119.156 +
119.157 +(*. univariate polynomials (uv) .*)
119.158 +(*. univariate polynomials are represented as a list of the coefficent in reverse maximum degree order .*)
119.159 +(*. 5 * x^5 + 4 * x^3 + 2 * x^2 + x + 19 => [19,1,2,4,0,5] .*)
119.160 +type uv_poly = int list;
119.161 +
119.162 +(*. adds two uv polynomials .*)
119.163 +fun uv_mod_add_poly ([]:uv_poly,p2:uv_poly) = p2:uv_poly
119.164 + | uv_mod_add_poly (p1,[]) = p1
119.165 + | uv_mod_add_poly (x::p1,y::p2) = (x+y)::(uv_mod_add_poly(p1,p2));
119.166 +
119.167 +(*. multiplies a uv polynomial with a skalar s .*)
119.168 +fun uv_mod_smul_poly ([]:uv_poly,s:int) = []:uv_poly
119.169 + | uv_mod_smul_poly (x::p,s) = (x*s)::(uv_mod_smul_poly(p,s));
119.170 +
119.171 +(*. calculates the remainder of a polynomial divided by a skalar s .*)
119.172 +fun uv_mod_rem_poly ([]:uv_poly,s) = []:uv_poly
119.173 + | uv_mod_rem_poly (x::p,s) = (x mod s)::(uv_mod_smul_poly(p,s));
119.174 +
119.175 +(*. calculates the degree of a uv polynomial .*)
119.176 +fun uv_mod_deg ([]:uv_poly) = 0
119.177 + | uv_mod_deg p = length(p)-1;
119.178 +
119.179 +(*. calculates the remainder of x/p and represents it as value between -p/2 and p/2 .*)
119.180 +fun uv_mod_mod2(x,p)=
119.181 + let
119.182 + val y=(x mod p);
119.183 + in
119.184 + if (y)>(p div 2) then (y)-p else
119.185 + (
119.186 + if (y)<(~p div 2) then p+(y) else (y)
119.187 + )
119.188 + end;
119.189 +
119.190 +(*.calculates the remainder for each element of a integer list divided by p.*)
119.191 +fun uv_mod_list_modp [] p = []
119.192 + | uv_mod_list_modp (x::xs) p = (uv_mod_mod2(x,p))::(uv_mod_list_modp xs p);
119.193 +
119.194 +(*. appends an integer at the end of a integer list .*)
119.195 +fun uv_mod_null (p1:int list,0) = p1
119.196 + | uv_mod_null (p1:int list,n1:int) = uv_mod_null(p1,n1-1) @ [0];
119.197 +
119.198 +(*. uv polynomial division, result is (quotient, remainder) .*)
119.199 +(*. only for uv_mod_divides .*)
119.200 +(* FIXME: Division von x^9+x^5+1 durch x-1000 funktioniert nicht integer zu klein *)
119.201 +fun uv_mod_pdiv (p1:uv_poly) ([]:uv_poly) = raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero")
119.202 + | uv_mod_pdiv p1 [x] =
119.203 + let
119.204 + val xs=ref [];
119.205 + in
119.206 + if x<>0 then
119.207 + (
119.208 + xs:=(uv_mod_rem_poly(p1,x));
119.209 + while length(!xs)>0 andalso hd(!xs)=0 do xs:=tl(!xs)
119.210 + )
119.211 + else raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: division by zero");
119.212 + ([]:uv_poly,!xs:uv_poly)
119.213 + end
119.214 + | uv_mod_pdiv p1 p2 =
119.215 + let
119.216 + val n= uv_mod_deg(p2);
119.217 + val m= ref (uv_mod_deg(p1));
119.218 + val p1'=ref (rev(p1));
119.219 + val p2'=(rev(p2));
119.220 + val lc2=hd(p2');
119.221 + val q=ref [];
119.222 + val c=ref 0;
119.223 + val output=ref ([],[]);
119.224 + in
119.225 + (
119.226 + if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIV_EXCEPTION: Division by zero")
119.227 + else
119.228 + (
119.229 + if (!m)<n then
119.230 + (
119.231 + output:=([0],p1)
119.232 + )
119.233 + else
119.234 + (
119.235 + while (!m)>=n do
119.236 + (
119.237 + c:=hd(!p1') div hd(p2');
119.238 + if !c<>0 then
119.239 + (
119.240 + p1':=uv_mod_add_poly(!p1',uv_mod_null(uv_mod_smul_poly(p2',~(!c)),!m-n));
119.241 + while length(!p1')>0 andalso hd(!p1')=0 do p1':= tl(!p1');
119.242 + m:=uv_mod_deg(!p1')
119.243 + )
119.244 + else m:=0
119.245 + );
119.246 + output:=(rev(!q),rev(!p1'))
119.247 + )
119.248 + );
119.249 + !output
119.250 + )
119.251 + end;
119.252 +
119.253 +(*. divides p1 by p2 in Zp .*)
119.254 +fun uv_mod_pdivp (p1:uv_poly) (p2:uv_poly) p =
119.255 + let
119.256 + val n=uv_mod_deg(p2);
119.257 + val m=ref (uv_mod_deg(uv_mod_list_modp p1 p));
119.258 + val p1'=ref (rev(p1));
119.259 + val p2'=(rev(uv_mod_list_modp p2 p));
119.260 + val lc2=hd(p2');
119.261 + val q=ref [];
119.262 + val c=ref 0;
119.263 + val output=ref ([],[]);
119.264 + in
119.265 + (
119.266 + if (!m)=0 orelse p2=[0] then raise error ("RATIONALS_UV_MOD_PDIVP_EXCEPTION: Division by zero")
119.267 + else
119.268 + (
119.269 + if (!m)<n then
119.270 + (
119.271 + output:=([0],p1)
119.272 + )
119.273 + else
119.274 + (
119.275 + while (!m)>=n do
119.276 + (
119.277 + c:=uv_mod_mod2(hd(!p1')*(power lc2 1), p);
119.278 + q:=(!c)::(!q);
119.279 + p1':=uv_mod_list_modp(tl(uv_mod_add_poly(uv_mod_smul_poly(!p1',lc2),
119.280 + uv_mod_smul_poly(uv_mod_smul_poly(p2',hd(!p1')),~1)))) p;
119.281 + m:=(!m)-1
119.282 + );
119.283 +
119.284 + while !p1'<>[] andalso hd(!p1')=0 do
119.285 + (
119.286 + p1':=tl(!p1')
119.287 + );
119.288 +
119.289 + output:=(rev(uv_mod_list_modp (!q) (p)),rev(!p1'))
119.290 + )
119.291 + );
119.292 + !output:uv_poly * uv_poly
119.293 + )
119.294 + end;
119.295 +
119.296 +(*. calculates the remainder of p1/p2 .*)
119.297 +fun uv_mod_prest (p1:uv_poly) ([]:uv_poly) = raise error("UV_MOD_PREST_EXCEPTION: Division by zero")
119.298 + | uv_mod_prest [] p2 = []:uv_poly
119.299 + | uv_mod_prest p1 p2 = (#2(uv_mod_pdiv p1 p2));
119.300 +
119.301 +(*. calculates the remainder of p1/p2 in Zp .*)
119.302 +fun uv_mod_prestp (p1:uv_poly) ([]:uv_poly) p= raise error("UV_MOD_PRESTP_EXCEPTION: Division by zero")
119.303 + | uv_mod_prestp [] p2 p= []:uv_poly
119.304 + | uv_mod_prestp p1 p2 p = #2(uv_mod_pdivp p1 p2 p);
119.305 +
119.306 +(*. calculates the content of a uv polynomial .*)
119.307 +fun uv_mod_cont ([]:uv_poly) = 0
119.308 + | uv_mod_cont (x::p)= gcd_int x (uv_mod_cont(p));
119.309 +
119.310 +(*. divides each coefficient of a uv polynomial by y .*)
119.311 +fun uv_mod_div_list (p:uv_poly,0) = raise error("UV_MOD_DIV_LIST_EXCEPTION: Division by zero")
119.312 + | uv_mod_div_list ([],y) = []:uv_poly
119.313 + | uv_mod_div_list (x::p,y) = (x div y)::uv_mod_div_list(p,y);
119.314 +
119.315 +(*. calculates the primitiv part of a uv polynomial .*)
119.316 +fun uv_mod_pp ([]:uv_poly) = []:uv_poly
119.317 + | uv_mod_pp p =
119.318 + let
119.319 + val c=ref 0;
119.320 + in
119.321 + (
119.322 + c:=uv_mod_cont(p);
119.323 +
119.324 + if !c=0 then raise error ("RATIONALS_UV_MOD_PP_EXCEPTION: content is 0")
119.325 + else uv_mod_div_list(p,!c)
119.326 + )
119.327 + end;
119.328 +
119.329 +(*. gets the leading coefficient of a uv polynomial .*)
119.330 +fun uv_mod_lc ([]:uv_poly) = 0
119.331 + | uv_mod_lc p = hd(rev(p));
119.332 +
119.333 +(*. calculates the euklidean polynomial remainder sequence in Zp .*)
119.334 +fun uv_mod_prs_euklid_p(p1:uv_poly,p2:uv_poly,p)=
119.335 + let
119.336 + val f =ref [];
119.337 + val f'=ref p2;
119.338 + val fi=ref [];
119.339 + in
119.340 + (
119.341 + f:=p2::p1::[];
119.342 + while uv_mod_deg(!f')>0 do
119.343 + (
119.344 + f':=uv_mod_prestp (hd(tl(!f))) (hd(!f)) p;
119.345 + if (!f')<>[] then
119.346 + (
119.347 + fi:=(!f');
119.348 + f:=(!fi)::(!f)
119.349 + )
119.350 + else ()
119.351 + );
119.352 + (!f)
119.353 +
119.354 + )
119.355 + end;
119.356 +
119.357 +(*. calculates the gcd of p1 and p2 in Zp .*)
119.358 +fun uv_mod_gcd_modp ([]:uv_poly) (p2:uv_poly) p = p2:uv_poly
119.359 + | uv_mod_gcd_modp p1 [] p= p1
119.360 + | uv_mod_gcd_modp p1 p2 p=
119.361 + let
119.362 + val p1'=ref[];
119.363 + val p2'=ref[];
119.364 + val pc=ref[];
119.365 + val g=ref [];
119.366 + val d=ref 0;
119.367 + val prs=ref [];
119.368 + in
119.369 + (
119.370 + if uv_mod_deg(p1)>=uv_mod_deg(p2) then
119.371 + (
119.372 + p1':=uv_mod_list_modp (uv_mod_pp(p1)) p;
119.373 + p2':=uv_mod_list_modp (uv_mod_pp(p2)) p
119.374 + )
119.375 + else
119.376 + (
119.377 + p1':=uv_mod_list_modp (uv_mod_pp(p2)) p;
119.378 + p2':=uv_mod_list_modp (uv_mod_pp(p1)) p
119.379 + );
119.380 + d:=uv_mod_mod2((gcd_int (uv_mod_cont(p1))) (uv_mod_cont(p2)), p) ;
119.381 + if !d>(p div 2) then d:=(!d)-p else ();
119.382 +
119.383 + prs:=uv_mod_prs_euklid_p(!p1',!p2',p);
119.384 +
119.385 + if hd(!prs)=[] then pc:=hd(tl(!prs))
119.386 + else pc:=hd(!prs);
119.387 +
119.388 + g:=uv_mod_smul_poly(uv_mod_pp(!pc),!d);
119.389 + !g
119.390 + )
119.391 + end;
119.392 +
119.393 +(*. calculates the minimum of two real values x and y .*)
119.394 +fun uv_mod_r_min(x,y):BasisLibrary.Real.real = if x>y then y else x;
119.395 +
119.396 +(*. calculates the minimum of two integer values x and y .*)
119.397 +fun uv_mod_min(x,y) = if x>y then y else x;
119.398 +
119.399 +(*. adds the squared values of a integer list .*)
119.400 +fun uv_mod_add_qu [] = 0.0
119.401 + | uv_mod_add_qu (x::p) = BasisLibrary.Real.fromInt(x)*BasisLibrary.Real.fromInt(x) + uv_mod_add_qu p;
119.402 +
119.403 +(*. calculates the euklidean norm .*)
119.404 +fun uv_mod_norm ([]:uv_poly) = 0.0
119.405 + | uv_mod_norm p = Math.sqrt(uv_mod_add_qu(p));
119.406 +
119.407 +(*. multipies two values a and b .*)
119.408 +fun uv_mod_multi a b = a * b;
119.409 +
119.410 +(*. decides if x is a prim, the list contains all primes which are lower then x .*)
119.411 +fun uv_mod_prim(x,[])= false
119.412 + | uv_mod_prim(x,[y])=if ((x mod y) <> 0) then true
119.413 + else false
119.414 + | uv_mod_prim(x,y::ys) = if uv_mod_prim(x,[y])
119.415 + then
119.416 + if uv_mod_prim(x,ys) then true
119.417 + else false
119.418 + else false;
119.419 +
119.420 +(*. gets the first prime, which is greater than p and does not divide g .*)
119.421 +fun uv_mod_nextprime(g,p)=
119.422 + let
119.423 + val list=ref [2];
119.424 + val exit=ref 0;
119.425 + val i = ref 2
119.426 + in
119.427 + while (!i<p) do (* calculates the primes lower then p *)
119.428 + (
119.429 + if uv_mod_prim(!i,!list) then
119.430 + (
119.431 + if (p mod !i <> 0)
119.432 + then
119.433 + (
119.434 + list:= (!i)::(!list);
119.435 + i:= (!i)+1
119.436 + )
119.437 + else i:=(!i)+1
119.438 + )
119.439 + else i:= (!i)+1
119.440 + );
119.441 + i:=(p+1);
119.442 + while (!exit=0) do (* calculate next prime which does not divide g *)
119.443 + (
119.444 + if uv_mod_prim(!i,!list) then
119.445 + (
119.446 + if (g mod !i <> 0)
119.447 + then
119.448 + (
119.449 + list:= (!i)::(!list);
119.450 + exit:= (!i)
119.451 + )
119.452 + else i:=(!i)+1
119.453 + )
119.454 + else i:= (!i)+1
119.455 + );
119.456 + !exit
119.457 + end;
119.458 +
119.459 +(*. decides if p1 is a factor of p2 in Zp .*)
119.460 +fun uv_mod_dividesp ([]:uv_poly) (p2:uv_poly) p= raise error("UV_MOD_DIVIDESP: Division by zero")
119.461 + | uv_mod_dividesp p1 p2 p= if uv_mod_prestp p2 p1 p = [] then true else false;
119.462 +
119.463 +(*. decides if p1 is a factor of p2 .*)
119.464 +fun uv_mod_divides ([]:uv_poly) (p2:uv_poly) = raise error("UV_MOD_DIVIDES: Division by zero")
119.465 + | uv_mod_divides p1 p2 = if uv_mod_prest p2 p1 = [] then true else false;
119.466 +
119.467 +(*. chinese remainder algorithm .*)
119.468 +fun uv_mod_cra2(r1,r2,m1,m2)=
119.469 + let
119.470 + val c=ref 0;
119.471 + val r1'=ref 0;
119.472 + val d=ref 0;
119.473 + val a=ref 0;
119.474 + in
119.475 + (
119.476 + while (uv_mod_mod2((!c)*m1,m2))<>1 do
119.477 + (
119.478 + c:=(!c)+1
119.479 + );
119.480 + r1':= uv_mod_mod2(r1,m1);
119.481 + d:=uv_mod_mod2(((r2-(!r1'))*(!c)),m2);
119.482 + !r1'+(!d)*m1
119.483 + )
119.484 + end;
119.485 +
119.486 +(*. applies the chinese remainder algorithmen to the coefficients of x1 and x2 .*)
119.487 +fun uv_mod_cra_2 ([],[],m1,m2) = []
119.488 + | uv_mod_cra_2 ([],x2,m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x1")
119.489 + | uv_mod_cra_2 (x1,[],m1,m2) = raise error("UV_MOD_CRA_2_EXCEPTION: invalid call x2")
119.490 + | uv_mod_cra_2 (x1::x1s,x2::x2s,m1,m2) = (uv_mod_cra2(x1,x2,m1,m2))::(uv_mod_cra_2(x1s,x2s,m1,m2));
119.491 +
119.492 +(*. calculates the gcd of two uv polynomials p1' and p2' with the modular algorithm .*)
119.493 +fun uv_mod_gcd (p1':uv_poly) (p2':uv_poly) =
119.494 + let
119.495 + val p1=ref (uv_mod_pp(p1'));
119.496 + val p2=ref (uv_mod_pp(p2'));
119.497 + val c=gcd_int (uv_mod_cont(p1')) (uv_mod_cont(p2'));
119.498 + val temp=ref [];
119.499 + val cp=ref [];
119.500 + val qp=ref [];
119.501 + val q=ref[];
119.502 + val pn=ref 0;
119.503 + val d=ref 0;
119.504 + val g1=ref 0;
119.505 + val p=ref 0;
119.506 + val m=ref 0;
119.507 + val exit=ref 0;
119.508 + val i=ref 1;
119.509 + in
119.510 + if length(!p1)>length(!p2) then ()
119.511 + else
119.512 + (
119.513 + temp:= !p1;
119.514 + p1:= !p2;
119.515 + p2:= !temp
119.516 + );
119.517 +
119.518 +
119.519 + d:=gcd_int (uv_mod_lc(!p1)) (uv_mod_lc(!p2));
119.520 + g1:=uv_mod_lc(!p1)*uv_mod_lc(!p2);
119.521 + p:=4;
119.522 +
119.523 + m:=BasisLibrary.Real.ceil(2.0 *
119.524 + BasisLibrary.Real.fromInt(!d) *
119.525 + BasisLibrary.Real.fromInt(power 2 (uv_mod_min(uv_mod_deg(!p2),uv_mod_deg(!p1)))) *
119.526 + BasisLibrary.Real.fromInt(!d) *
119.527 + uv_mod_r_min(uv_mod_norm(!p1) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p1))),
119.528 + uv_mod_norm(!p2) / BasisLibrary.Real.fromInt(abs(uv_mod_lc(!p2)))));
119.529 +
119.530 + while (!exit=0) do
119.531 + (
119.532 + p:=uv_mod_nextprime(!d,!p);
119.533 + cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p)) ;
119.534 + if abs(uv_mod_lc(!cp))<>1 then (* leading coefficient = 1 ? *)
119.535 + (
119.536 + i:=1;
119.537 + while (!i)<(!p) andalso (abs(uv_mod_mod2((uv_mod_lc(!cp)*(!i)),(!p)))<>1) do
119.538 + (
119.539 + i:=(!i)+1
119.540 + );
119.541 + cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p)
119.542 + )
119.543 + else ();
119.544 +
119.545 + qp:= ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp));
119.546 +
119.547 + if uv_mod_deg(!qp)=0 then (q:=[1]; exit:=1) else ();
119.548 +
119.549 + pn:=(!p);
119.550 + q:=(!qp);
119.551 +
119.552 + while !pn<= !m andalso !m>(!p) andalso !exit=0 do
119.553 + (
119.554 + p:=uv_mod_nextprime(!d,!p);
119.555 + cp:=(uv_mod_gcd_modp (uv_mod_list_modp(!p1) (!p)) (uv_mod_list_modp(!p2) (!p)) (!p));
119.556 + if uv_mod_lc(!cp)<>1 then (* leading coefficient = 1 ? *)
119.557 + (
119.558 + i:=1;
119.559 + while (!i)<(!p) andalso ((uv_mod_mod2((uv_mod_lc(!q)*(!i)),(!p)))<>1) do
119.560 + (
119.561 + i:=(!i)+1
119.562 + );
119.563 + cp:=uv_mod_list_modp (map (uv_mod_multi (!i)) (!cp)) (!p)
119.564 + )
119.565 + else ();
119.566 +
119.567 + qp:=uv_mod_list_modp ((map (uv_mod_multi (uv_mod_mod2(!d,!p)))) (!cp) ) (!p);
119.568 + if uv_mod_deg(!qp)>uv_mod_deg(!q) then
119.569 + (
119.570 + (*print("degree to high!!!\n")*)
119.571 + )
119.572 + else
119.573 + (
119.574 + if uv_mod_deg(!qp)=uv_mod_deg(!q) then
119.575 + (
119.576 + q:=uv_mod_cra_2(!q,!qp,!pn,!p);
119.577 + pn:=(!pn) * !p;
119.578 + q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn)); (* found already gcd ? *)
119.579 + if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then (exit:=1) else ()
119.580 + )
119.581 + else
119.582 + (
119.583 + if uv_mod_deg(!qp)<uv_mod_deg(!q) then
119.584 + (
119.585 + pn:= !p;
119.586 + q:= !qp
119.587 + )
119.588 + else ()
119.589 + )
119.590 + )
119.591 + );
119.592 + q:=uv_mod_pp(uv_mod_list_modp (!q) (!pn));
119.593 + if (uv_mod_divides (!q) (p1')) andalso (uv_mod_divides (!q) (p2')) then exit:=1 else ()
119.594 + );
119.595 + uv_mod_smul_poly(!q,c):uv_poly
119.596 + end;
119.597 +
119.598 +(*. multivariate polynomials .*)
119.599 +(*. multivariate polynomials are represented as a list of the pairs,
119.600 + first is the coefficent and the second is a list of the exponents .*)
119.601 +(*. 5 * x^5 * y^3 + 4 * x^3 * z^2 + 2 * x^2 * y * z^3 - z - 19
119.602 + => [(5,[5,3,0]),(4,[3,0,2]),(2,[2,1,3]),(~1,[0,0,1]),(~19,[0,0,0])] .*)
119.603 +
119.604 +(*. global variables .*)
119.605 +(*. order indicators .*)
119.606 +val LEX_=0; (* lexicographical term order *)
119.607 +val GGO_=1; (* greatest degree order *)
119.608 +
119.609 +(*. datatypes for internal representation.*)
119.610 +type mv_monom = (int * (*.coefficient or the monom.*)
119.611 + int list); (*.list of exponents) .*)
119.612 +fun mv_monom2str (i, is) = "("^ int2str i^"," ^ ints2str' is ^ ")";
119.613 +
119.614 +type mv_poly = mv_monom list;
119.615 +fun mv_poly2str p = (strs2str' o (map mv_monom2str)) p;
119.616 +
119.617 +(*. help function for monom_greater and geq .*)
119.618 +fun mv_mg_hlp([]) = EQUAL
119.619 + | mv_mg_hlp(x::list)=if x<0 then LESS
119.620 + else if x>0 then GREATER
119.621 + else mv_mg_hlp(list);
119.622 +
119.623 +(*. adds a list of values .*)
119.624 +fun mv_addlist([]) = 0
119.625 + | mv_addlist(p1) = hd(p1)+mv_addlist(tl(p1));
119.626 +
119.627 +(*. tests if the monomial M1 is greater as the monomial M2 and returns a boolean value .*)
119.628 +(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*)
119.629 +fun mv_monom_greater((M1x,M1l):mv_monom,(M2x,M2l):mv_monom,order)=
119.630 + if order=LEX_ then
119.631 + (
119.632 + if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error")
119.633 + else if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true
119.634 + )
119.635 + else
119.636 + if order=GGO_ then
119.637 + (
119.638 + if length(M1l)<>length(M2l) then raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Order error")
119.639 + else
119.640 + if mv_addlist(M1l)=mv_addlist(M2l) then if (mv_mg_hlp((map op- (M1l~~M2l)))<>GREATER) then false else true
119.641 + else if mv_addlist(M1l)>mv_addlist(M2l) then true else false
119.642 + )
119.643 + else raise error ("RATIONALS_MV_MONOM_GREATER_EXCEPTION: Wrong Order");
119.644 +
119.645 +(*. tests if the monomial X is greater as the monomial Y and returns a order value (GREATER,EQUAL,LESS) .*)
119.646 +(*. 2 orders are implemented LEX_/GGO_ (lexigraphical/greatest degree order) .*)
119.647 +fun mv_geq order ((x1,x):mv_monom,(x2,y):mv_monom) =
119.648 +let
119.649 + val temp=ref EQUAL;
119.650 +in
119.651 + if order=LEX_ then
119.652 + (
119.653 + if length(x)<>length(y) then
119.654 + raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error")
119.655 + else
119.656 + (
119.657 + temp:=mv_mg_hlp((map op- (x~~y)));
119.658 + if !temp=EQUAL then
119.659 + ( if x1=x2 then EQUAL
119.660 + else if x1>x2 then GREATER
119.661 + else LESS
119.662 + )
119.663 + else (!temp)
119.664 + )
119.665 + )
119.666 + else
119.667 + if order=GGO_ then
119.668 + (
119.669 + if length(x)<>length(y) then
119.670 + raise error ("RATIONALS_MV_GEQ_EXCEPTION: Order error")
119.671 + else
119.672 + if mv_addlist(x)=mv_addlist(y) then
119.673 + (mv_mg_hlp((map op- (x~~y))))
119.674 + else if mv_addlist(x)>mv_addlist(y) then GREATER else LESS
119.675 + )
119.676 + else raise error ("RATIONALS_MV_GEQ_EXCEPTION: Wrong Order")
119.677 +end;
119.678 +
119.679 +(*. cuts the first variable from a polynomial .*)
119.680 +fun mv_cut([]:mv_poly)=[]:mv_poly
119.681 + | mv_cut((x,[])::list) = raise error ("RATIONALS_MV_CUT_EXCEPTION: Invalid list ")
119.682 + | mv_cut((x,y::ys)::list)=(x,ys)::mv_cut(list);
119.683 +
119.684 +(*. leading power product .*)
119.685 +fun mv_lpp([]:mv_poly,order) = []
119.686 + | mv_lpp([(x,y)],order) = y
119.687 + | mv_lpp(p1,order) = #2(hd(rev(sort (mv_geq order) p1)));
119.688 +
119.689 +(*. leading monomial .*)
119.690 +fun mv_lm([]:mv_poly,order) = (0,[]):mv_monom
119.691 + | mv_lm([x],order) = x
119.692 + | mv_lm(p1,order) = hd(rev(sort (mv_geq order) p1));
119.693 +
119.694 +(*. leading coefficient in term order .*)
119.695 +fun mv_lc2([]:mv_poly,order) = 0
119.696 + | mv_lc2([(x,y)],order) = x
119.697 + | mv_lc2(p1,order) = #1(hd(rev(sort (mv_geq order) p1)));
119.698 +
119.699 +
119.700 +(*. reverse the coefficients in mv polynomial .*)
119.701 +fun mv_rev_to([]:mv_poly) = []:mv_poly
119.702 + | mv_rev_to((c,e)::xs) = (c,rev(e))::mv_rev_to(xs);
119.703 +
119.704 +(*. leading coefficient in reverse term order .*)
119.705 +fun mv_lc([]:mv_poly,order) = []:mv_poly
119.706 + | mv_lc([(x,y)],order) = mv_rev_to(mv_cut(mv_rev_to([(x,y)])))
119.707 + | mv_lc(p1,order) =
119.708 + let
119.709 + val p1o=ref (rev(sort (mv_geq order) (mv_rev_to(p1))));
119.710 + val lp=hd(#2(hd(!p1o)));
119.711 + val lc=ref [];
119.712 + in
119.713 + (
119.714 + while (length(!p1o)>0 andalso hd(#2(hd(!p1o)))=lp) do
119.715 + (
119.716 + lc:=hd(mv_cut([hd(!p1o)]))::(!lc);
119.717 + p1o:=tl(!p1o)
119.718 + );
119.719 + if !lc=[] then raise error ("RATIONALS_MV_LC_EXCEPTION: lc is empty") else ();
119.720 + mv_rev_to(!lc)
119.721 + )
119.722 + end;
119.723 +
119.724 +(*. compares two powerproducts .*)
119.725 +fun mv_monom_equal((_,xlist):mv_monom,(_,ylist):mv_monom) = (foldr and_) (((map op=) (xlist~~ylist)),true);
119.726 +
119.727 +(*. help function for mv_add .*)
119.728 +fun mv_madd([]:mv_poly,[]:mv_poly,order) = []:mv_poly
119.729 + | mv_madd([(0,_)],p2,order) = p2
119.730 + | mv_madd(p1,[(0,_)],order) = p1
119.731 + | mv_madd([],p2,order) = p2
119.732 + | mv_madd(p1,[],order) = p1
119.733 + | mv_madd(p1,p2,order) =
119.734 + (
119.735 + if mv_monom_greater(hd(p1),hd(p2),order)
119.736 + then hd(p1)::mv_madd(tl(p1),p2,order)
119.737 + else if mv_monom_equal(hd(p1),hd(p2))
119.738 + then if mv_lc2(p1,order)+mv_lc2(p2,order)<>0
119.739 + then (mv_lc2(p1,order)+mv_lc2(p2,order),mv_lpp(p1,order))::mv_madd(tl(p1),tl(p2),order)
119.740 + else mv_madd(tl(p1),tl(p2),order)
119.741 + else hd(p2)::mv_madd(p1,tl(p2),order)
119.742 + )
119.743 +
119.744 +(*. adds two multivariate polynomials .*)
119.745 +fun mv_add([]:mv_poly,p2:mv_poly,order) = p2
119.746 + | mv_add(p1,[],order) = p1
119.747 + | mv_add(p1,p2,order) = mv_madd(rev(sort (mv_geq order) p1),rev(sort (mv_geq order) p2), order);
119.748 +
119.749 +(*. monom multiplication .*)
119.750 +fun mv_mmul((x1,y1):mv_monom,(x2,y2):mv_monom)=(x1*x2,(map op+) (y1~~y2)):mv_monom;
119.751 +
119.752 +(*. deletes all monomials with coefficient 0 .*)
119.753 +fun mv_shorten([]:mv_poly,order) = []:mv_poly
119.754 + | mv_shorten(x::xs,order)=mv_madd([x],mv_shorten(xs,order),order);
119.755 +
119.756 +(*. zeros a list .*)
119.757 +fun mv_null2([])=[]
119.758 + | mv_null2(x::l)=0::mv_null2(l);
119.759 +
119.760 +(*. multiplies two multivariate polynomials .*)
119.761 +fun mv_mul([]:mv_poly,[]:mv_poly,_) = []:mv_poly
119.762 + | mv_mul([],y::p2,_) = [(0,mv_null2(#2(y)))]
119.763 + | mv_mul(x::p1,[],_) = [(0,mv_null2(#2(x)))]
119.764 + | mv_mul(x::p1,y::p2,order) = mv_shorten(rev(sort (mv_geq order) (mv_mmul(x,y) :: (mv_mul(p1,y::p2,order) @
119.765 + mv_mul([x],p2,order)))),order);
119.766 +
119.767 +(*. gets the maximum value of a list .*)
119.768 +fun mv_getmax([])=0
119.769 + | mv_getmax(x::p1)= let
119.770 + val m=mv_getmax(p1);
119.771 + in
119.772 + if m>x then m
119.773 + else x
119.774 + end;
119.775 +(*. calculates the maximum degree of an multivariate polynomial .*)
119.776 +fun mv_grad([]:mv_poly) = 0
119.777 + | mv_grad(p1:mv_poly)= mv_getmax((map mv_addlist) ((map #2) p1));
119.778 +
119.779 +(*. converts the sign of a value .*)
119.780 +fun mv_minus(x)=(~1) * x;
119.781 +
119.782 +(*. converts the sign of all coefficients of a polynomial .*)
119.783 +fun mv_minus2([]:mv_poly)=[]:mv_poly
119.784 + | mv_minus2(p1)=(mv_minus(#1(hd(p1))),#2(hd(p1)))::(mv_minus2(tl(p1)));
119.785 +
119.786 +(*. searches for a negativ value in a list .*)
119.787 +fun mv_is_negativ([])=false
119.788 + | mv_is_negativ(x::xs)=if x<0 then true else mv_is_negativ(xs);
119.789 +
119.790 +(*. division of monomials .*)
119.791 +fun mv_mdiv((0,[]):mv_monom,_:mv_monom)=(0,[]):mv_monom
119.792 + | mv_mdiv(_,(0,[]))= raise error ("RATIONALS_MV_MDIV_EXCEPTION Division by 0 ")
119.793 + | mv_mdiv(p1:mv_monom,p2:mv_monom)=
119.794 + let
119.795 + val c=ref (#1(p2));
119.796 + val pp=ref [];
119.797 + in
119.798 + (
119.799 + if !c=0 then raise error("MV_MDIV_EXCEPTION Dividing by zero")
119.800 + else c:=(#1(p1) div #1(p2));
119.801 + if #1(p2)<>0 then
119.802 + (
119.803 + pp:=(#2(mv_mmul((1,#2(p1)),(1,(map mv_minus) (#2(p2))))));
119.804 + if mv_is_negativ(!pp) then (0,!pp)
119.805 + else (!c,!pp)
119.806 + )
119.807 + else raise error("MV_MDIV_EXCEPTION Dividing by empty Polynom")
119.808 + )
119.809 + end;
119.810 +
119.811 +(*. prints a polynom for (internal use only) .*)
119.812 +fun mv_print_poly([]:mv_poly)=print("[]\n")
119.813 + | mv_print_poly((x,y)::[])= print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^")\n")
119.814 + | mv_print_poly((x,y)::p1) = (print("("^BasisLibrary.Int.toString(x)^","^ints2str(y)^"),");mv_print_poly(p1));
119.815 +
119.816 +
119.817 +(*. division of two multivariate polynomials .*)
119.818 +fun mv_division([]:mv_poly,g:mv_poly,order)=([]:mv_poly,[]:mv_poly)
119.819 + | mv_division(f,[],order)= raise error ("RATIONALS_MV_DIVISION_EXCEPTION Division by zero")
119.820 + | mv_division(f,g,order)=
119.821 + let
119.822 + val r=ref [];
119.823 + val q=ref [];
119.824 + val g'=ref [];
119.825 + val k=ref 0;
119.826 + val m=ref (0,[0]);
119.827 + val exit=ref 0;
119.828 + in
119.829 + r := rev(sort (mv_geq order) (mv_shorten(f,order)));
119.830 + g':= rev(sort (mv_geq order) (mv_shorten(g,order)));
119.831 + if #1(hd(!g'))=0 then raise error("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero") else ();
119.832 + if (mv_monom_greater (hd(!g'),hd(!r),order)) then ([(0,mv_null2(#2(hd(f))))],(!r))
119.833 + else
119.834 + (
119.835 + exit:=0;
119.836 + while (if (!exit)=0 then not(mv_monom_greater (hd(!g'),hd(!r),order)) else false) do
119.837 + (
119.838 + if (#1(mv_lm(!g',order)))<>0 then m:=mv_mdiv(mv_lm(!r,order),mv_lm(!g',order))
119.839 + else raise error ("RATIONALS_MV_DIVISION_EXCEPTION: Dividing by zero");
119.840 + if #1(!m)<>0 then
119.841 + (
119.842 + q:=(!m)::(!q);
119.843 + r:=mv_add((!r),mv_minus2(mv_mul(!g',[!m],order)),order)
119.844 + )
119.845 + else exit:=1;
119.846 + if (if length(!r)<>0 then length(!g')<>0 else false) then ()
119.847 + else (exit:=1)
119.848 + );
119.849 + (rev(!q),!r)
119.850 + )
119.851 + end;
119.852 +
119.853 +(*. multiplies a polynomial with an integer .*)
119.854 +fun mv_skalar_mul([]:mv_poly,c) = []:mv_poly
119.855 + | mv_skalar_mul((x,y)::p1,c) = ((x * c),y)::mv_skalar_mul(p1,c);
119.856 +
119.857 +(*. inserts the a first variable into an polynomial with exponent v .*)
119.858 +fun mv_correct([]:mv_poly,v:int)=[]:mv_poly
119.859 + | mv_correct((x,y)::list,v:int)=(x,v::y)::mv_correct(list,v);
119.860 +
119.861 +(*. multivariate case .*)
119.862 +
119.863 +(*. decides if x is a factor of y .*)
119.864 +fun mv_divides([]:mv_poly,[]:mv_poly)= raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero")
119.865 + | mv_divides(x,[]) = raise error("RATIONALS_MV_DIVIDES_EXCEPTION: division by zero")
119.866 + | mv_divides(x:mv_poly,y:mv_poly) = #2(mv_division(y,x,LEX_))=[];
119.867 +
119.868 +(*. gets the maximum of a and b .*)
119.869 +fun mv_max(a,b) = if a>b then a else b;
119.870 +
119.871 +(*. gets the maximum exponent of a mv polynomial in the lexicographic term order .*)
119.872 +fun mv_deg([]:mv_poly) = 0
119.873 + | mv_deg(p1)=
119.874 + let
119.875 + val p1'=mv_shorten(p1,LEX_);
119.876 + in
119.877 + if length(p1')=0 then 0
119.878 + else mv_max(hd(#2(hd(p1'))),mv_deg(tl(p1')))
119.879 + end;
119.880 +
119.881 +(*. gets the maximum exponent of a mv polynomial in the reverse lexicographic term order .*)
119.882 +fun mv_deg2([]:mv_poly) = 0
119.883 + | mv_deg2(p1)=
119.884 + let
119.885 + val p1'=mv_shorten(p1,LEX_);
119.886 + in
119.887 + if length(p1')=0 then 0
119.888 + else mv_max(hd(rev(#2(hd(p1')))),mv_deg2(tl(p1')))
119.889 + end;
119.890 +
119.891 +(*. evaluates the mv polynomial at the value v of the main variable .*)
119.892 +fun mv_subs([]:mv_poly,v) = []:mv_poly
119.893 + | mv_subs((c,e)::p1:mv_poly,v) = mv_skalar_mul(mv_cut([(c,e)]),power v (hd(e))) @ mv_subs(p1,v);
119.894 +
119.895 +(*. calculates the content of a uv-polynomial in mv-representation .*)
119.896 +fun uv_content2([]:mv_poly) = 0
119.897 + | uv_content2((c,e)::p1) = (gcd_int c (uv_content2(p1)));
119.898 +
119.899 +(*. converts a uv-polynomial from mv-representation to uv-representation .*)
119.900 +fun uv_to_list ([]:mv_poly)=[]:uv_poly
119.901 + | uv_to_list ((c1,e1)::others) =
119.902 + let
119.903 + val count=ref 0;
119.904 + val max=mv_grad((c1,e1)::others);
119.905 + val help=ref ((c1,e1)::others);
119.906 + val list=ref [];
119.907 + in
119.908 + if length(e1)>1 then raise error ("RATIONALS_TO_LIST_EXCEPTION: not univariate")
119.909 + else if length(e1)=0 then [c1]
119.910 + else
119.911 + (
119.912 + count:=0;
119.913 + while (!count)<=max do
119.914 + (
119.915 + if length(!help)>0 andalso hd(#2(hd(!help)))=max-(!count) then
119.916 + (
119.917 + list:=(#1(hd(!help)))::(!list);
119.918 + help:=tl(!help)
119.919 + )
119.920 + else
119.921 + (
119.922 + list:= 0::(!list)
119.923 + );
119.924 + count := (!count) + 1
119.925 + );
119.926 + (!list)
119.927 + )
119.928 + end;
119.929 +
119.930 +(*. converts a uv-polynomial from uv-representation to mv-representation .*)
119.931 +fun uv_to_poly ([]:uv_poly) = []:mv_poly
119.932 + | uv_to_poly p1 =
119.933 + let
119.934 + val count=ref 0;
119.935 + val help=ref p1;
119.936 + val list=ref [];
119.937 + in
119.938 + while length(!help)>0 do
119.939 + (
119.940 + if hd(!help)=0 then ()
119.941 + else list:=(hd(!help),[!count])::(!list);
119.942 + count:=(!count)+1;
119.943 + help:=tl(!help)
119.944 + );
119.945 + (!list)
119.946 + end;
119.947 +
119.948 +(*. univariate gcd calculation from polynomials in multivariate representation .*)
119.949 +fun uv_gcd ([]:mv_poly) p2 = p2
119.950 + | uv_gcd p1 ([]:mv_poly) = p1
119.951 + | uv_gcd p1 [(c,[e])] =
119.952 + let
119.953 + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_))));
119.954 + val min=uv_mod_min(e,(hd(#2(hd(rev(!list))))));
119.955 + in
119.956 + [(gcd_int (uv_content2(p1)) c,[min])]
119.957 + end
119.958 + | uv_gcd [(c,[e])] p2 =
119.959 + let
119.960 + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p2,LEX_))));
119.961 + val min=uv_mod_min(e,(hd(#2(hd(rev(!list))))));
119.962 + in
119.963 + [(gcd_int (uv_content2(p2)) c,[min])]
119.964 + end
119.965 + | uv_gcd p11 p22 = uv_to_poly(uv_mod_gcd (uv_to_list(mv_shorten(p11,LEX_))) (uv_to_list(mv_shorten(p22,LEX_))));
119.966 +
119.967 +(*. help function for the newton interpolation .*)
119.968 +fun mv_newton_help ([]:mv_poly list,k:int) = []:mv_poly list
119.969 + | mv_newton_help (pl:mv_poly list,k) =
119.970 + let
119.971 + val x=ref (rev(pl));
119.972 + val t=ref [];
119.973 + val y=ref [];
119.974 + val n=ref 1;
119.975 + val n1=ref[];
119.976 + in
119.977 + (
119.978 + while length(!x)>1 do
119.979 + (
119.980 + if length(hd(!x))>0 then n1:=mv_null2(#2(hd(hd(!x))))
119.981 + else if length(hd(tl(!x)))>0 then n1:=mv_null2(#2(hd(hd(tl(!x)))))
119.982 + else n1:=[];
119.983 + t:= #1(mv_division(mv_add(hd(!x),mv_skalar_mul(hd(tl(!x)),~1),LEX_),[(k,!n1)],LEX_));
119.984 + y:=(!t)::(!y);
119.985 + x:=tl(!x)
119.986 + );
119.987 + (!y)
119.988 + )
119.989 + end;
119.990 +
119.991 +(*. help function for the newton interpolation .*)
119.992 +fun mv_newton_add ([]:mv_poly list) t = []:mv_poly
119.993 + | mv_newton_add [x:mv_poly] t = x
119.994 + | mv_newton_add (pl:mv_poly list) t =
119.995 + let
119.996 + val expos=ref [];
119.997 + val pll=ref pl;
119.998 + in
119.999 + (
119.1000 +
119.1001 + while length(!pll)>0 andalso hd(!pll)=[] do
119.1002 + (
119.1003 + pll:=tl(!pll)
119.1004 + );
119.1005 + if length(!pll)>0 then expos:= #2(hd(hd(!pll))) else expos:=[];
119.1006 + mv_add(hd(pl),
119.1007 + mv_mul(
119.1008 + mv_add(mv_correct(mv_cut([(1,mv_null2(!expos))]),1),[(~t,mv_null2(!expos))],LEX_),
119.1009 + mv_newton_add (tl(pl)) (t+1),
119.1010 + LEX_
119.1011 + ),
119.1012 + LEX_)
119.1013 + )
119.1014 + end;
119.1015 +
119.1016 +(*. calculates the newton interpolation with polynomial coefficients .*)
119.1017 +(*. step-depth is 1 and if the result is not an integerpolynomial .*)
119.1018 +(*. this function returns [] .*)
119.1019 +fun mv_newton ([]:(mv_poly) list) = []:mv_poly
119.1020 + | mv_newton ([mp]:(mv_poly) list) = mp:mv_poly
119.1021 + | mv_newton pl =
119.1022 + let
119.1023 + val c=ref pl;
119.1024 + val c1=ref [];
119.1025 + val n=length(pl);
119.1026 + val k=ref 1;
119.1027 + val i=ref n;
119.1028 + val ppl=ref [];
119.1029 + in
119.1030 + c1:=hd(pl)::[];
119.1031 + c:=mv_newton_help(!c,!k);
119.1032 + c1:=(hd(!c))::(!c1);
119.1033 + while(length(!c)>1 andalso !k<n) do
119.1034 + (
119.1035 + k:=(!k)+1;
119.1036 + while length(!c)>0 andalso hd(!c)=[] do c:=tl(!c);
119.1037 + if !c=[] then () else c:=mv_newton_help(!c,!k);
119.1038 + ppl:= !c;
119.1039 + if !c=[] then () else c1:=(hd(!c))::(!c1)
119.1040 + );
119.1041 + while hd(!c1)=[] do c1:=tl(!c1);
119.1042 + c1:=rev(!c1);
119.1043 + ppl:= !c1;
119.1044 + mv_newton_add (!c1) 1
119.1045 + end;
119.1046 +
119.1047 +(*. sets the exponents of the first variable to zero .*)
119.1048 +fun mv_null3([]:mv_poly) = []:mv_poly
119.1049 + | mv_null3((x,y)::xs) = (x,0::tl(y))::mv_null3(xs);
119.1050 +
119.1051 +(*. calculates the minimum exponents of a multivariate polynomial .*)
119.1052 +fun mv_min_pp([]:mv_poly)=[]
119.1053 + | mv_min_pp((c,e)::xs)=
119.1054 + let
119.1055 + val y=ref xs;
119.1056 + val x=ref [];
119.1057 + in
119.1058 + (
119.1059 + x:=e;
119.1060 + while length(!y)>0 do
119.1061 + (
119.1062 + x:=(map uv_mod_min) ((!x) ~~ (#2(hd(!y))));
119.1063 + y:=tl(!y)
119.1064 + );
119.1065 + !x
119.1066 + )
119.1067 + end;
119.1068 +
119.1069 +(*. checks if all elements of the list have value zero .*)
119.1070 +fun list_is_null [] = true
119.1071 + | list_is_null (x::xs) = (x=0 andalso list_is_null(xs));
119.1072 +
119.1073 +(* check if main variable is zero*)
119.1074 +fun main_zero (ms : mv_poly) = (list_is_null o (map (hd o #2))) ms;
119.1075 +
119.1076 +(*. calculates the content of an polynomial .*)
119.1077 +fun mv_content([]:mv_poly) = []:mv_poly
119.1078 + | mv_content(p1) =
119.1079 + let
119.1080 + val list=ref (rev(sort (mv_geq LEX_) (mv_shorten(p1,LEX_))));
119.1081 + val test=ref (hd(#2(hd(!list))));
119.1082 + val result=ref [];
119.1083 + val min=(hd(#2(hd(rev(!list)))));
119.1084 + in
119.1085 + (
119.1086 + if length(!list)>1 then
119.1087 + (
119.1088 + while (if length(!list)>0 then (hd(#2(hd(!list)))=(!test)) else false) do
119.1089 + (
119.1090 + result:=(#1(hd(!list)),tl(#2(hd(!list))))::(!result);
119.1091 +
119.1092 + if length(!list)<1 then list:=[]
119.1093 + else list:=tl(!list)
119.1094 +
119.1095 + );
119.1096 + if length(!list)>0 then
119.1097 + (
119.1098 + list:=mv_gcd (!result) (mv_cut(mv_content(!list)))
119.1099 + )
119.1100 + else list:=(!result);
119.1101 + list:=mv_correct(!list,0);
119.1102 + (!list)
119.1103 + )
119.1104 + else
119.1105 + (
119.1106 + mv_null3(!list)
119.1107 + )
119.1108 + )
119.1109 + end
119.1110 +
119.1111 +(*. calculates the primitiv part of a polynomial .*)
119.1112 +and mv_pp([]:mv_poly) = []:mv_poly
119.1113 + | mv_pp(p1) = let
119.1114 + val cont=ref [];
119.1115 + val pp=ref[];
119.1116 + in
119.1117 + cont:=mv_content(p1);
119.1118 + pp:=(#1(mv_division(p1,!cont,LEX_)));
119.1119 + if !pp=[]
119.1120 + then raise error("RATIONALS_MV_PP_EXCEPTION: Invalid Content ")
119.1121 + else (!pp)
119.1122 + end
119.1123 +
119.1124 +(*. calculates the gcd of two multivariate polynomials with a modular approach .*)
119.1125 +and mv_gcd ([]:mv_poly) ([]:mv_poly) :mv_poly= []:mv_poly
119.1126 + | mv_gcd ([]:mv_poly) (p2) :mv_poly= p2:mv_poly
119.1127 + | mv_gcd (p1:mv_poly) ([]) :mv_poly= p1:mv_poly
119.1128 + | mv_gcd ([(x,xs)]:mv_poly) ([(y,ys)]):mv_poly =
119.1129 + let
119.1130 + val xpoly:mv_poly = [(x,xs)];
119.1131 + val ypoly:mv_poly = [(y,ys)];
119.1132 + in
119.1133 + (
119.1134 + if xs=ys then [((gcd_int x y),xs)]
119.1135 + else [((gcd_int x y),(map uv_mod_min)(xs~~ys))]:mv_poly
119.1136 + )
119.1137 + end
119.1138 + | mv_gcd (p1:mv_poly) ([(y,ys)]) :mv_poly=
119.1139 + (
119.1140 + [(gcd_int (uv_content2(p1)) (y),(map uv_mod_min)(mv_min_pp(p1)~~ys))]:mv_poly
119.1141 + )
119.1142 + | mv_gcd ([(y,ys)]:mv_poly) (p2):mv_poly =
119.1143 + (
119.1144 + [(gcd_int (uv_content2(p2)) (y),(map uv_mod_min)(mv_min_pp(p2)~~ys))]:mv_poly
119.1145 + )
119.1146 + | mv_gcd (p1':mv_poly) (p2':mv_poly):mv_poly=
119.1147 + let
119.1148 + val vc=length(#2(hd(p1')));
119.1149 + val cont =
119.1150 + (
119.1151 + if main_zero(mv_content(p1')) andalso
119.1152 + (main_zero(mv_content(p2'))) then
119.1153 + mv_correct((mv_gcd (mv_cut(mv_content(p1'))) (mv_cut(mv_content(p2')))),0)
119.1154 + else
119.1155 + mv_gcd (mv_content(p1')) (mv_content(p2'))
119.1156 + );
119.1157 + val p1= #1(mv_division(p1',mv_content(p1'),LEX_));
119.1158 + val p2= #1(mv_division(p2',mv_content(p2'),LEX_));
119.1159 + val gcd=ref [];
119.1160 + val candidate=ref [];
119.1161 + val interpolation_list=ref [];
119.1162 + val delta=ref [];
119.1163 + val p1r = ref [];
119.1164 + val p2r = ref [];
119.1165 + val p1r' = ref [];
119.1166 + val p2r' = ref [];
119.1167 + val factor=ref [];
119.1168 + val r=ref 0;
119.1169 + val gcd_r=ref [];
119.1170 + val d=ref 0;
119.1171 + val exit=ref 0;
119.1172 + val current_degree=ref 99999; (*. FIXME: unlimited ! .*)
119.1173 + in
119.1174 + (
119.1175 + if vc<2 then (* areUnivariate(p1',p2') *)
119.1176 + (
119.1177 + gcd:=uv_gcd (mv_shorten(p1',LEX_)) (mv_shorten(p2',LEX_))
119.1178 + )
119.1179 + else
119.1180 + (
119.1181 + while !exit=0 do
119.1182 + (
119.1183 + r:=(!r)+1;
119.1184 + p1r := mv_lc(p1,LEX_);
119.1185 + p2r := mv_lc(p2,LEX_);
119.1186 + if main_zero(!p1r) andalso
119.1187 + main_zero(!p2r)
119.1188 + then
119.1189 + (
119.1190 + delta := mv_correct((mv_gcd (mv_cut (!p1r)) (mv_cut (!p2r))),0)
119.1191 + )
119.1192 + else
119.1193 + (
119.1194 + delta := mv_gcd (!p1r) (!p2r)
119.1195 + );
119.1196 + (*if mv_shorten(mv_subs(!p1r,!r),LEX_)=[] andalso
119.1197 + mv_shorten(mv_subs(!p2r,!r),LEX_)=[] *)
119.1198 + if mv_lc2(mv_shorten(mv_subs(!p1r,!r),LEX_),LEX_)=0 andalso
119.1199 + mv_lc2(mv_shorten(mv_subs(!p2r,!r),LEX_),LEX_)=0
119.1200 + then
119.1201 + (
119.1202 + )
119.1203 + else
119.1204 + (
119.1205 + gcd_r:=mv_shorten(mv_gcd (mv_shorten(mv_subs(p1,!r),LEX_))
119.1206 + (mv_shorten(mv_subs(p2,!r),LEX_)) ,LEX_);
119.1207 + gcd_r:= #1(mv_division(mv_mul(mv_correct(mv_subs(!delta,!r),0),!gcd_r,LEX_),
119.1208 + mv_correct(mv_lc(!gcd_r,LEX_),0),LEX_));
119.1209 + d:=mv_deg2(!gcd_r); (* deg(gcd_r,z) *)
119.1210 + if (!d < !current_degree) then
119.1211 + (
119.1212 + current_degree:= !d;
119.1213 + interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list)
119.1214 + )
119.1215 + else
119.1216 + (
119.1217 + if (!d = !current_degree) then
119.1218 + (
119.1219 + interpolation_list:=mv_correct(!gcd_r,0)::(!interpolation_list)
119.1220 + )
119.1221 + else ()
119.1222 + )
119.1223 + );
119.1224 + if length(!interpolation_list)> uv_mod_min(mv_deg(p1),mv_deg(p2)) then
119.1225 + (
119.1226 + candidate := mv_newton(rev(!interpolation_list));
119.1227 + if !candidate=[] then ()
119.1228 + else
119.1229 + (
119.1230 + candidate:=mv_pp(!candidate);
119.1231 + if mv_divides(!candidate,p1) andalso mv_divides(!candidate,p2) then
119.1232 + (
119.1233 + gcd:= mv_mul(!candidate,cont,LEX_);
119.1234 + exit:=1
119.1235 + )
119.1236 + else ()
119.1237 + );
119.1238 + interpolation_list:=[mv_correct(!gcd_r,0)]
119.1239 + )
119.1240 + else ()
119.1241 + )
119.1242 + );
119.1243 + (!gcd):mv_poly
119.1244 + )
119.1245 + end;
119.1246 +
119.1247 +
119.1248 +(*. calculates the least common divisor of two polynomials .*)
119.1249 +fun mv_lcm (p1:mv_poly) (p2:mv_poly) :mv_poly =
119.1250 + (
119.1251 + #1(mv_division(mv_mul(p1,p2,LEX_),mv_gcd p1 p2,LEX_))
119.1252 + );
119.1253 +
119.1254 +(*. gets the variables (strings) of a term .*)
119.1255 +fun get_vars(term1) = (map free2str) (vars term1); (*["a","b","c"]; *)
119.1256 +
119.1257 +(*. counts the negative coefficents in a polynomial .*)
119.1258 +fun count_neg ([]:mv_poly) = 0
119.1259 + | count_neg ((c,e)::xs) = if c<0 then 1+count_neg xs
119.1260 + else count_neg xs;
119.1261 +
119.1262 +(*. help function for is_polynomial
119.1263 + checks the order of the operators .*)
119.1264 +fun test_polynomial (Const ("uminus",_) $ Free (str,_)) _ = true (*WN.13.3.03*)
119.1265 + | test_polynomial (t as Free(str,_)) v = true
119.1266 + | test_polynomial (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false
119.1267 + else (test_polynomial t1 "*") andalso (test_polynomial t2 "*")
119.1268 + | test_polynomial (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
119.1269 + else (test_polynomial t1 " ") andalso (test_polynomial t2 " ")
119.1270 + | test_polynomial (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_polynomial t1 "^") andalso (test_polynomial t2 "^")
119.1271 + | test_polynomial _ v = false;
119.1272 +
119.1273 +(*. tests if a term is a polynomial .*)
119.1274 +fun is_polynomial t = test_polynomial t " ";
119.1275 +
119.1276 +(*. help function for is_expanded
119.1277 + checks the order of the operators .*)
119.1278 +fun test_exp (t as Free(str,_)) v = true
119.1279 + | test_exp (t as Const ("op *",_) $ t1 $ t2) v = if v="^" then false
119.1280 + else (test_exp t1 "*") andalso (test_exp t2 "*")
119.1281 + | test_exp (t as Const ("op +",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
119.1282 + else (test_exp t1 " ") andalso (test_exp t2 " ")
119.1283 + | test_exp (t as Const ("op -",_) $ t1 $ t2) v = if v="*" orelse v="^" then false
119.1284 + else (test_exp t1 " ") andalso (test_exp t2 " ")
119.1285 + | test_exp (t as Const ("Atools.pow",_) $ t1 $ t2) v = (test_exp t1 "^") andalso (test_exp t2 "^")
119.1286 + | test_exp _ v = false;
119.1287 +
119.1288 +
119.1289 +(*. help function for check_coeff:
119.1290 + converts the term to a list of coefficients .*)
119.1291 +fun term2coef' (t as Free(str,_(*typ*))) v :mv_poly option =
119.1292 + let
119.1293 + val x=ref NONE;
119.1294 + val len=ref 0;
119.1295 + val vl=ref [];
119.1296 + val vh=ref [];
119.1297 + val i=ref 0;
119.1298 + in
119.1299 + if is_numeral str then
119.1300 + (
119.1301 + SOME [(((the o int_of_str) str),mv_null2(v))] handle _ => NONE
119.1302 + )
119.1303 + else (* variable *)
119.1304 + (
119.1305 + len:=length(v);
119.1306 + vh:=v;
119.1307 + while ((!len)>(!i)) do
119.1308 + (
119.1309 + if str=hd((!vh)) then
119.1310 + (
119.1311 + vl:=1::(!vl)
119.1312 + )
119.1313 + else
119.1314 + (
119.1315 + vl:=0::(!vl)
119.1316 + );
119.1317 + vh:=tl(!vh);
119.1318 + i:=(!i)+1
119.1319 + );
119.1320 + SOME [(1,rev(!vl))] handle _ => NONE
119.1321 + )
119.1322 + end
119.1323 + | term2coef' (Const ("op *",_) $ t1 $ t2) v :mv_poly option=
119.1324 + let
119.1325 + val t1pp=ref [];
119.1326 + val t2pp=ref [];
119.1327 + val t1c=ref 0;
119.1328 + val t2c=ref 0;
119.1329 + in
119.1330 + (
119.1331 + t1pp:=(#2(hd(the(term2coef' t1 v))));
119.1332 + t2pp:=(#2(hd(the(term2coef' t2 v))));
119.1333 + t1c:=(#1(hd(the(term2coef' t1 v))));
119.1334 + t2c:=(#1(hd(the(term2coef' t2 v))));
119.1335 +
119.1336 + SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )] handle _ => NONE
119.1337 +
119.1338 + )
119.1339 + end
119.1340 + | term2coef' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $ (t2 as Free (str2,_))) v :mv_poly option=
119.1341 + let
119.1342 + val x=ref NONE;
119.1343 + val len=ref 0;
119.1344 + val vl=ref [];
119.1345 + val vh=ref [];
119.1346 + val vtemp=ref [];
119.1347 + val i=ref 0;
119.1348 + in
119.1349 + (
119.1350 + if (not o is_numeral) str1 andalso is_numeral str2 then
119.1351 + (
119.1352 + len:=length(v);
119.1353 + vh:=v;
119.1354 +
119.1355 + while ((!len)>(!i)) do
119.1356 + (
119.1357 + if str1=hd((!vh)) then
119.1358 + (
119.1359 + vl:=((the o int_of_str) str2)::(!vl)
119.1360 + )
119.1361 + else
119.1362 + (
119.1363 + vl:=0::(!vl)
119.1364 + );
119.1365 + vh:=tl(!vh);
119.1366 + i:=(!i)+1
119.1367 + );
119.1368 + SOME [(1,rev(!vl))] handle _ => NONE
119.1369 + )
119.1370 + else raise error ("RATIONALS_TERM2COEF_EXCEPTION 1: Invalid term")
119.1371 + )
119.1372 + end
119.1373 + | term2coef' (Const ("op +",_) $ t1 $ t2) v :mv_poly option=
119.1374 + (
119.1375 + SOME ((the(term2coef' t1 v)) @ (the(term2coef' t2 v))) handle _ => NONE
119.1376 + )
119.1377 + | term2coef' (Const ("op -",_) $ t1 $ t2) v :mv_poly option=
119.1378 + (
119.1379 + SOME ((the(term2coef' t1 v)) @ mv_skalar_mul((the(term2coef' t2 v)),1)) handle _ => NONE
119.1380 + )
119.1381 + | term2coef' (term) v = raise error ("RATIONALS_TERM2COEF_EXCEPTION 2: Invalid term");
119.1382 +
119.1383 +(*. checks if all coefficients of a polynomial are positiv (except the first) .*)
119.1384 +fun check_coeff t = (* erste Koeffizient kann <0 sein !!! *)
119.1385 + if count_neg(tl(the(term2coef' t (get_vars(t)))))=0 then true
119.1386 + else false;
119.1387 +
119.1388 +(*. checks for expanded term [3] .*)
119.1389 +fun is_expanded t = test_exp t " " andalso check_coeff(t);
119.1390 +
119.1391 +(*WN.7.3.03 Hilfsfunktion f"ur term2poly'*)
119.1392 +fun mk_monom v' p vs =
119.1393 + let fun conv p (v: string) = if v'= v then p else 0
119.1394 + in map (conv p) vs end;
119.1395 +(* mk_monom "y" 5 ["a","b","x","y","z"];
119.1396 +val it = [0,0,0,5,0] : int list*)
119.1397 +
119.1398 +(*. this function converts the term representation into the internal representation mv_poly .*)
119.1399 +fun term2poly' (Const ("uminus",_) $ Free (str,_)) v = (*WN.7.3.03*)
119.1400 + if is_numeral str
119.1401 + then SOME [((the o int_of_str) ("-"^str), mk_monom "#" 0 v)]
119.1402 + else SOME [(~1, mk_monom str 1 v)]
119.1403 +
119.1404 + | term2poly' (Free(str,_)) v :mv_poly option =
119.1405 + let
119.1406 + val x=ref NONE;
119.1407 + val len=ref 0;
119.1408 + val vl=ref [];
119.1409 + val vh=ref [];
119.1410 + val i=ref 0;
119.1411 + in
119.1412 + if is_numeral str then
119.1413 + (
119.1414 + SOME [(((the o int_of_str) str),mv_null2 v)] handle _ => NONE
119.1415 + )
119.1416 + else (* variable *)
119.1417 + (
119.1418 + len:=length v;
119.1419 + vh:= v;
119.1420 + while ((!len)>(!i)) do
119.1421 + (
119.1422 + if str=hd((!vh)) then
119.1423 + (
119.1424 + vl:=1::(!vl)
119.1425 + )
119.1426 + else
119.1427 + (
119.1428 + vl:=0::(!vl)
119.1429 + );
119.1430 + vh:=tl(!vh);
119.1431 + i:=(!i)+1
119.1432 + );
119.1433 + SOME [(1,rev(!vl))] handle _ => NONE
119.1434 + )
119.1435 + end
119.1436 + | term2poly' (Const ("op *",_) $ t1 $ t2) v :mv_poly option=
119.1437 + let
119.1438 + val t1pp=ref [];
119.1439 + val t2pp=ref [];
119.1440 + val t1c=ref 0;
119.1441 + val t2c=ref 0;
119.1442 + in
119.1443 + (
119.1444 + t1pp:=(#2(hd(the(term2poly' t1 v))));
119.1445 + t2pp:=(#2(hd(the(term2poly' t2 v))));
119.1446 + t1c:=(#1(hd(the(term2poly' t1 v))));
119.1447 + t2c:=(#1(hd(the(term2poly' t2 v))));
119.1448 +
119.1449 + SOME [( (!t1c)*(!t2c) ,( (map op+) ((!t1pp)~~(!t2pp)) ) )]
119.1450 + handle _ => NONE
119.1451 +
119.1452 + )
119.1453 + end
119.1454 + | term2poly' (Const ("Atools.pow",_) $ (t1 as Free (str1,_)) $
119.1455 + (t2 as Free (str2,_))) v :mv_poly option=
119.1456 + let
119.1457 + val x=ref NONE;
119.1458 + val len=ref 0;
119.1459 + val vl=ref [];
119.1460 + val vh=ref [];
119.1461 + val vtemp=ref [];
119.1462 + val i=ref 0;
119.1463 + in
119.1464 + (
119.1465 + if (not o is_numeral) str1 andalso is_numeral str2 then
119.1466 + (
119.1467 + len:=length(v);
119.1468 + vh:=v;
119.1469 +
119.1470 + while ((!len)>(!i)) do
119.1471 + (
119.1472 + if str1=hd((!vh)) then
119.1473 + (
119.1474 + vl:=((the o int_of_str) str2)::(!vl)
119.1475 + )
119.1476 + else
119.1477 + (
119.1478 + vl:=0::(!vl)
119.1479 + );
119.1480 + vh:=tl(!vh);
119.1481 + i:=(!i)+1
119.1482 + );
119.1483 + SOME [(1,rev(!vl))] handle _ => NONE
119.1484 + )
119.1485 + else raise error ("RATIONALS_TERM2POLY_EXCEPTION 1: Invalid term")
119.1486 + )
119.1487 + end
119.1488 + | term2poly' (Const ("op +",_) $ t1 $ t2) v :mv_poly option =
119.1489 + (
119.1490 + SOME ((the(term2poly' t1 v)) @ (the(term2poly' t2 v))) handle _ => NONE
119.1491 + )
119.1492 + | term2poly' (Const ("op -",_) $ t1 $ t2) v :mv_poly option =
119.1493 + (
119.1494 + SOME ((the(term2poly' t1 v)) @ mv_skalar_mul((the(term2poly' t2 v)),~1)) handle _ => NONE
119.1495 + )
119.1496 + | term2poly' (term) v = raise error ("RATIONALS_TERM2POLY_EXCEPTION 2: Invalid term");
119.1497 +
119.1498 +(*. translates an Isabelle term into internal representation.
119.1499 + term2poly
119.1500 + fn : term -> (*normalform [2] *)
119.1501 + string list -> (*for ...!!! BITTE DIE ERKLÄRUNG,
119.1502 + DIE DU MIR LETZTES MAL GEGEBEN HAST*)
119.1503 + mv_monom list (*internal representation *)
119.1504 + option (*the translation may fail with NONE*)
119.1505 +.*)
119.1506 +fun term2poly (t:term) v =
119.1507 + if is_polynomial t then term2poly' t v
119.1508 + else raise error ("term2poly: invalid = "^(term2str t));
119.1509 +
119.1510 +(*. same as term2poly with automatic detection of the variables .*)
119.1511 +fun term2polyx t = term2poly t (((map free2str) o vars) t);
119.1512 +
119.1513 +(*. checks if the term is in expanded polynomial form and converts it into the internal representation .*)
119.1514 +fun expanded2poly (t:term) v =
119.1515 + (*if is_expanded t then*) term2poly' t v
119.1516 + (*else raise error ("RATIONALS_EXPANDED2POLY_EXCEPTION: Invalid Polynomial")*);
119.1517 +
119.1518 +(*. same as expanded2poly with automatic detection of the variables .*)
119.1519 +fun expanded2polyx t = expanded2poly t (((map free2str) o vars) t);
119.1520 +
119.1521 +(*. converts a powerproduct into term representation .*)
119.1522 +fun powerproduct2term(xs,v) =
119.1523 + let
119.1524 + val xss=ref xs;
119.1525 + val vv=ref v;
119.1526 + in
119.1527 + (
119.1528 + while hd(!xss)=0 do
119.1529 + (
119.1530 + xss:=tl(!xss);
119.1531 + vv:=tl(!vv)
119.1532 + );
119.1533 +
119.1534 + if list_is_null(tl(!xss)) then
119.1535 + (
119.1536 + if hd(!xss)=1 then Free(hd(!vv), HOLogic.realT)
119.1537 + else
119.1538 + (
119.1539 + Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1540 + Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT)
119.1541 + )
119.1542 + )
119.1543 + else
119.1544 + (
119.1545 + if hd(!xss)=1 then
119.1546 + (
119.1547 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1548 + Free(hd(!vv), HOLogic.realT) $
119.1549 + powerproduct2term(tl(!xss),tl(!vv))
119.1550 + )
119.1551 + else
119.1552 + (
119.1553 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1554 + (
119.1555 + Const("Atools.pow",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1556 + Free(hd(!vv), HOLogic.realT) $ Free(str_of_int (hd(!xss)),HOLogic.realT)
119.1557 + ) $
119.1558 + powerproduct2term(tl(!xss),tl(!vv))
119.1559 + )
119.1560 + )
119.1561 + )
119.1562 + end;
119.1563 +
119.1564 +(*. converts a monom into term representation .*)
119.1565 +(*fun monom2term ((c,e):mv_monom, v:string list) =
119.1566 + if c=0 then Free(str_of_int 0,HOLogic.realT)
119.1567 + else
119.1568 + (
119.1569 + if list_is_null(e) then
119.1570 + (
119.1571 + Free(str_of_int c,HOLogic.realT)
119.1572 + )
119.1573 + else
119.1574 + (
119.1575 + if c=1 then
119.1576 + (
119.1577 + powerproduct2term(e,v)
119.1578 + )
119.1579 + else
119.1580 + (
119.1581 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1582 + Free(str_of_int c,HOLogic.realT) $
119.1583 + powerproduct2term(e,v)
119.1584 + )
119.1585 + )
119.1586 + );*)
119.1587 +
119.1588 +
119.1589 +(*fun monom2term ((i, is):mv_monom, v) =
119.1590 + if list_is_null is
119.1591 + then
119.1592 + if i >= 0
119.1593 + then Free (str_of_int i, HOLogic.realT)
119.1594 + else Const ("uminus", HOLogic.realT --> HOLogic.realT) $
119.1595 + Free ((str_of_int o abs) i, HOLogic.realT)
119.1596 + else
119.1597 + if i > 0
119.1598 + then Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
119.1599 + (Free (str_of_int i, HOLogic.realT)) $
119.1600 + powerproduct2term(is, v)
119.1601 + else Const ("op *", [HOLogic.realT,HOLogic.realT]---> HOLogic.realT) $
119.1602 + (Const ("uminus", HOLogic.realT --> HOLogic.realT) $
119.1603 + Free ((str_of_int o abs) i, HOLogic.realT)) $
119.1604 + powerproduct2term(is, vs);---------------------------*)
119.1605 +fun monom2term ((i, is) : mv_monom, vs) =
119.1606 + if list_is_null is
119.1607 + then Free (str_of_int i, HOLogic.realT)
119.1608 + else if i = 1
119.1609 + then powerproduct2term (is, vs)
119.1610 + else Const ("op *", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $
119.1611 + (Free (str_of_int i, HOLogic.realT)) $
119.1612 + powerproduct2term (is, vs);
119.1613 +
119.1614 +(*. converts the internal polynomial representation into an Isabelle term.*)
119.1615 +fun poly2term' ([] : mv_poly, vs) = Free(str_of_int 0, HOLogic.realT)
119.1616 + | poly2term' ([(c, e) : mv_monom], vs) = monom2term ((c, e), vs)
119.1617 + | poly2term' ((c, e) :: ces, vs) =
119.1618 + Const("op +", [HOLogic.realT, HOLogic.realT] ---> HOLogic.realT) $
119.1619 + poly2term (ces, vs) $ monom2term ((c, e), vs)
119.1620 +and poly2term (xs, vs) = poly2term' (rev (sort (mv_geq LEX_) (xs)), vs);
119.1621 +
119.1622 +
119.1623 +(*. converts a monom into term representation .*)
119.1624 +(*. ignores the sign of the coefficients => use only for exp-poly functions .*)
119.1625 +fun monom2term2((c,e):mv_monom, v:string list) =
119.1626 + if c=0 then Free(str_of_int 0,HOLogic.realT)
119.1627 + else
119.1628 + (
119.1629 + if list_is_null(e) then
119.1630 + (
119.1631 + Free(str_of_int (abs(c)),HOLogic.realT)
119.1632 + )
119.1633 + else
119.1634 + (
119.1635 + if abs(c)=1 then
119.1636 + (
119.1637 + powerproduct2term(e,v)
119.1638 + )
119.1639 + else
119.1640 + (
119.1641 + Const("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1642 + Free(str_of_int (abs(c)),HOLogic.realT) $
119.1643 + powerproduct2term(e,v)
119.1644 + )
119.1645 + )
119.1646 + );
119.1647 +
119.1648 +(*. converts the expanded polynomial representation into the term representation .*)
119.1649 +fun exp2term' ([]:mv_poly,vars) = Free(str_of_int 0,HOLogic.realT)
119.1650 + | exp2term' ([(c,e)],vars) = monom2term((c,e),vars)
119.1651 + | exp2term' ((c1,e1)::others,vars) =
119.1652 + if c1<0 then
119.1653 + Const("op -",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1654 + exp2term'(others,vars) $
119.1655 + (
119.1656 + monom2term2((c1,e1),vars)
119.1657 + )
119.1658 + else
119.1659 + Const("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1660 + exp2term'(others,vars) $
119.1661 + (
119.1662 + monom2term2((c1,e1),vars)
119.1663 + );
119.1664 +
119.1665 +(*. sorts the powerproduct by lexicographic termorder and converts them into
119.1666 + a term in polynomial representation .*)
119.1667 +fun poly2expanded (xs,vars) = exp2term'(rev(sort (mv_geq LEX_) (xs)),vars);
119.1668 +
119.1669 +(*. converts a polynomial into expanded form .*)
119.1670 +fun polynomial2expanded t =
119.1671 + (let
119.1672 + val vars=(((map free2str) o vars) t);
119.1673 + in
119.1674 + SOME (poly2expanded (the (term2poly t vars), vars))
119.1675 + end) handle _ => NONE;
119.1676 +
119.1677 +(*. converts a polynomial into polynomial form .*)
119.1678 +fun expanded2polynomial t =
119.1679 + (let
119.1680 + val vars=(((map free2str) o vars) t);
119.1681 + in
119.1682 + SOME (poly2term (the (expanded2poly t vars), vars))
119.1683 + end) handle _ => NONE;
119.1684 +
119.1685 +
119.1686 +(*. calculates the greatest common divisor of numerator and denominator and seperates it from each .*)
119.1687 +fun step_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) =
119.1688 + let
119.1689 + val p1' = ref [];
119.1690 + val p2' = ref [];
119.1691 + val p3 = ref []
119.1692 + val vars = rev(get_vars(p1) union get_vars(p2));
119.1693 + in
119.1694 + (
119.1695 + p1':= sort (mv_geq LEX_) (the (term2poly p1 vars ));
119.1696 + p2':= sort (mv_geq LEX_) (the (term2poly p2 vars ));
119.1697 + p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
119.1698 + if (!p3)=[(1,mv_null2(vars))] then
119.1699 + (
119.1700 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2
119.1701 + )
119.1702 + else
119.1703 + (
119.1704 +
119.1705 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
119.1706 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
119.1707 +
119.1708 + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
119.1709 + (
119.1710 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1711 + $
119.1712 + (
119.1713 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1714 + poly2term(!p1',vars) $
119.1715 + poly2term(!p3,vars)
119.1716 + )
119.1717 + $
119.1718 + (
119.1719 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1720 + poly2term(!p2',vars) $
119.1721 + poly2term(!p3,vars)
119.1722 + )
119.1723 + )
119.1724 + else
119.1725 + (
119.1726 + p1':=mv_skalar_mul(!p1',~1);
119.1727 + p2':=mv_skalar_mul(!p2',~1);
119.1728 + p3:=mv_skalar_mul(!p3,~1);
119.1729 + (
119.1730 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1731 + $
119.1732 + (
119.1733 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1734 + poly2term(!p1',vars) $
119.1735 + poly2term(!p3,vars)
119.1736 + )
119.1737 + $
119.1738 + (
119.1739 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1740 + poly2term(!p2',vars) $
119.1741 + poly2term(!p3,vars)
119.1742 + )
119.1743 + )
119.1744 + )
119.1745 + )
119.1746 + )
119.1747 + end
119.1748 +| step_cancel _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction");
119.1749 +
119.1750 +
119.1751 +(*. same as step_cancel, this time for expanded forms (input+output) .*)
119.1752 +fun step_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) =
119.1753 + let
119.1754 + val p1' = ref [];
119.1755 + val p2' = ref [];
119.1756 + val p3 = ref []
119.1757 + val vars = rev(get_vars(p1) union get_vars(p2));
119.1758 + in
119.1759 + (
119.1760 + p1':= sort (mv_geq LEX_) (the (expanded2poly p1 vars ));
119.1761 + p2':= sort (mv_geq LEX_) (the (expanded2poly p2 vars ));
119.1762 + p3:= sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
119.1763 + if (!p3)=[(1,mv_null2(vars))] then
119.1764 + (
119.1765 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2
119.1766 + )
119.1767 + else
119.1768 + (
119.1769 +
119.1770 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
119.1771 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
119.1772 +
119.1773 + if #1(hd(sort (mv_geq LEX_) (!p2')))(* mv_lc2(!p2',LEX_)*)>0 then
119.1774 + (
119.1775 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1776 + $
119.1777 + (
119.1778 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1779 + poly2expanded(!p1',vars) $
119.1780 + poly2expanded(!p3,vars)
119.1781 + )
119.1782 + $
119.1783 + (
119.1784 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1785 + poly2expanded(!p2',vars) $
119.1786 + poly2expanded(!p3,vars)
119.1787 + )
119.1788 + )
119.1789 + else
119.1790 + (
119.1791 + p1':=mv_skalar_mul(!p1',~1);
119.1792 + p2':=mv_skalar_mul(!p2',~1);
119.1793 + p3:=mv_skalar_mul(!p3,~1);
119.1794 + (
119.1795 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1796 + $
119.1797 + (
119.1798 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1799 + poly2expanded(!p1',vars) $
119.1800 + poly2expanded(!p3,vars)
119.1801 + )
119.1802 + $
119.1803 + (
119.1804 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.1805 + poly2expanded(!p2',vars) $
119.1806 + poly2expanded(!p3,vars)
119.1807 + )
119.1808 + )
119.1809 + )
119.1810 + )
119.1811 + )
119.1812 + end
119.1813 +| step_cancel_expanded _ = raise error ("RATIONALS_STEP_CANCEL_EXCEPTION: Invalid fraction");
119.1814 +
119.1815 +(*. calculates the greatest common divisor of numerator and denominator and divides each through it .*)
119.1816 +fun direct_cancel (t as Const ("HOL.divide",_) $ p1 $ p2) =
119.1817 + let
119.1818 + val p1' = ref [];
119.1819 + val p2' = ref [];
119.1820 + val p3 = ref []
119.1821 + val vars = rev(get_vars(p1) union get_vars(p2));
119.1822 + in
119.1823 + (
119.1824 + p1':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p1 vars )),LEX_));
119.1825 + p2':=sort (mv_geq LEX_) (mv_shorten((the (term2poly p2 vars )),LEX_));
119.1826 + p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
119.1827 +
119.1828 + if (!p3)=[(1,mv_null2(vars))] then
119.1829 + (
119.1830 + (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[])
119.1831 + )
119.1832 + else
119.1833 + (
119.1834 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
119.1835 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
119.1836 + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
119.1837 + (
119.1838 + (
119.1839 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1840 + $
119.1841 + (
119.1842 + poly2term((!p1'),vars)
119.1843 + )
119.1844 + $
119.1845 + (
119.1846 + poly2term((!p2'),vars)
119.1847 + )
119.1848 + )
119.1849 + ,
119.1850 + if mv_grad(!p3)>0 then
119.1851 + [
119.1852 + (
119.1853 + Const ("Not",[bool]--->bool) $
119.1854 + (
119.1855 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
119.1856 + poly2term((!p3),vars) $
119.1857 + Free("0",HOLogic.realT)
119.1858 + )
119.1859 + )
119.1860 + ]
119.1861 + else
119.1862 + []
119.1863 + )
119.1864 + else
119.1865 + (
119.1866 + p1':=mv_skalar_mul(!p1',~1);
119.1867 + p2':=mv_skalar_mul(!p2',~1);
119.1868 + if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1);
119.1869 + (
119.1870 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1871 + $
119.1872 + (
119.1873 + poly2term((!p1'),vars)
119.1874 + )
119.1875 + $
119.1876 + (
119.1877 + poly2term((!p2'),vars)
119.1878 + )
119.1879 + ,
119.1880 + if mv_grad(!p3)>0 then
119.1881 + [
119.1882 + (
119.1883 + Const ("Not",[bool]--->bool) $
119.1884 + (
119.1885 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
119.1886 + poly2term((!p3),vars) $
119.1887 + Free("0",HOLogic.realT)
119.1888 + )
119.1889 + )
119.1890 + ]
119.1891 + else
119.1892 + []
119.1893 + )
119.1894 + )
119.1895 + )
119.1896 + )
119.1897 + end
119.1898 + | direct_cancel _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction");
119.1899 +
119.1900 +(*. same es direct_cancel, this time for expanded forms (input+output).*)
119.1901 +fun direct_cancel_expanded (t as Const ("HOL.divide",_) $ p1 $ p2) =
119.1902 + let
119.1903 + val p1' = ref [];
119.1904 + val p2' = ref [];
119.1905 + val p3 = ref []
119.1906 + val vars = rev(get_vars(p1) union get_vars(p2));
119.1907 + in
119.1908 + (
119.1909 + p1':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p1 vars )),LEX_));
119.1910 + p2':=sort (mv_geq LEX_) (mv_shorten((the (expanded2poly p2 vars )),LEX_));
119.1911 + p3 :=sort (mv_geq LEX_) (mv_gcd (!p1') (!p2'));
119.1912 +
119.1913 + if (!p3)=[(1,mv_null2(vars))] then
119.1914 + (
119.1915 + (Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $ p1 $ p2,[])
119.1916 + )
119.1917 + else
119.1918 + (
119.1919 + p1':=sort (mv_geq LEX_) (#1(mv_division((!p1'),(!p3),LEX_)));
119.1920 + p2':=sort (mv_geq LEX_) (#1(mv_division((!p2'),(!p3),LEX_)));
119.1921 + if #1(hd(sort (mv_geq LEX_) (!p2'))) (*mv_lc2(!p2',LEX_)*)>0 then
119.1922 + (
119.1923 + (
119.1924 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1925 + $
119.1926 + (
119.1927 + poly2expanded((!p1'),vars)
119.1928 + )
119.1929 + $
119.1930 + (
119.1931 + poly2expanded((!p2'),vars)
119.1932 + )
119.1933 + )
119.1934 + ,
119.1935 + if mv_grad(!p3)>0 then
119.1936 + [
119.1937 + (
119.1938 + Const ("Not",[bool]--->bool) $
119.1939 + (
119.1940 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
119.1941 + poly2expanded((!p3),vars) $
119.1942 + Free("0",HOLogic.realT)
119.1943 + )
119.1944 + )
119.1945 + ]
119.1946 + else
119.1947 + []
119.1948 + )
119.1949 + else
119.1950 + (
119.1951 + p1':=mv_skalar_mul(!p1',~1);
119.1952 + p2':=mv_skalar_mul(!p2',~1);
119.1953 + if length(!p3)> 2*(count_neg(!p3)) then () else p3 :=mv_skalar_mul(!p3,~1);
119.1954 + (
119.1955 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.1956 + $
119.1957 + (
119.1958 + poly2expanded((!p1'),vars)
119.1959 + )
119.1960 + $
119.1961 + (
119.1962 + poly2expanded((!p2'),vars)
119.1963 + )
119.1964 + ,
119.1965 + if mv_grad(!p3)>0 then
119.1966 + [
119.1967 + (
119.1968 + Const ("Not",[bool]--->bool) $
119.1969 + (
119.1970 + Const("op =",[HOLogic.realT,HOLogic.realT]--->bool) $
119.1971 + poly2expanded((!p3),vars) $
119.1972 + Free("0",HOLogic.realT)
119.1973 + )
119.1974 + )
119.1975 + ]
119.1976 + else
119.1977 + []
119.1978 + )
119.1979 + )
119.1980 + )
119.1981 + )
119.1982 + end
119.1983 + | direct_cancel_expanded _ = raise error ("RATIONALS_DIRECT_CANCEL_EXCEPTION: Invalid fraction");
119.1984 +
119.1985 +
119.1986 +(*. adds two fractions .*)
119.1987 +fun add_fract ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) =
119.1988 + let
119.1989 + val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22);
119.1990 + val t11'=ref (the(term2poly t11 vars));
119.1991 +val _= writeln"### add_fract: done t11"
119.1992 + val t12'=ref (the(term2poly t12 vars));
119.1993 +val _= writeln"### add_fract: done t12"
119.1994 + val t21'=ref (the(term2poly t21 vars));
119.1995 +val _= writeln"### add_fract: done t21"
119.1996 + val t22'=ref (the(term2poly t22 vars));
119.1997 +val _= writeln"### add_fract: done t22"
119.1998 + val den=ref [];
119.1999 + val nom=ref [];
119.2000 + val m1=ref [];
119.2001 + val m2=ref [];
119.2002 + in
119.2003 +
119.2004 + (
119.2005 + den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22'));
119.2006 +writeln"### add_fract: done sort mv_lcm";
119.2007 + m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_)));
119.2008 +writeln"### add_fract: done sort mv_division t12";
119.2009 + m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_)));
119.2010 +writeln"### add_fract: done sort mv_division t22";
119.2011 + nom :=sort (mv_geq LEX_)
119.2012 + (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),
119.2013 + mv_mul(!t21',!m2,LEX_),
119.2014 + LEX_),
119.2015 + LEX_));
119.2016 +writeln"### add_fract: done sort mv_add";
119.2017 + (
119.2018 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2019 + $
119.2020 + (
119.2021 + poly2term((!nom),vars)
119.2022 + )
119.2023 + $
119.2024 + (
119.2025 + poly2term((!den),vars)
119.2026 + )
119.2027 + )
119.2028 + )
119.2029 + end
119.2030 + | add_fract (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: Invalid add_fraction call");
119.2031 +
119.2032 +(*. adds two expanded fractions .*)
119.2033 +fun add_fract_exp ((Const("HOL.divide",_) $ t11 $ t12),(Const("HOL.divide",_) $ t21 $ t22)) =
119.2034 + let
119.2035 + val vars=get_vars(t11) union get_vars(t12) union get_vars(t21) union get_vars(t22);
119.2036 + val t11'=ref (the(expanded2poly t11 vars));
119.2037 + val t12'=ref (the(expanded2poly t12 vars));
119.2038 + val t21'=ref (the(expanded2poly t21 vars));
119.2039 + val t22'=ref (the(expanded2poly t22 vars));
119.2040 + val den=ref [];
119.2041 + val nom=ref [];
119.2042 + val m1=ref [];
119.2043 + val m2=ref [];
119.2044 + in
119.2045 +
119.2046 + (
119.2047 + den :=sort (mv_geq LEX_) (mv_lcm (!t12') (!t22'));
119.2048 + m1 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t12',LEX_)));
119.2049 + m2 :=sort (mv_geq LEX_) (#1(mv_division(!den,!t22',LEX_)));
119.2050 + nom :=sort (mv_geq LEX_) (mv_shorten(mv_add(mv_mul(!t11',!m1,LEX_),mv_mul(!t21',!m2,LEX_),LEX_),LEX_));
119.2051 + (
119.2052 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2053 + $
119.2054 + (
119.2055 + poly2expanded((!nom),vars)
119.2056 + )
119.2057 + $
119.2058 + (
119.2059 + poly2expanded((!den),vars)
119.2060 + )
119.2061 + )
119.2062 + )
119.2063 + end
119.2064 + | add_fract_exp (_,_) = raise error ("RATIONALS_ADD_FRACTION_EXP_EXCEPTION: Invalid add_fraction call");
119.2065 +
119.2066 +(*. adds a list of terms .*)
119.2067 +fun add_list_of_fractions []= (Free("0",HOLogic.realT),[])
119.2068 + | add_list_of_fractions [x]= direct_cancel x
119.2069 + | add_list_of_fractions (x::y::xs) =
119.2070 + let
119.2071 + val (t1a,rest1)=direct_cancel(x);
119.2072 +val _= writeln"### add_list_of_fractions xs: has done direct_cancel(x)";
119.2073 + val (t2a,rest2)=direct_cancel(y);
119.2074 +val _= writeln"### add_list_of_fractions xs: has done direct_cancel(y)";
119.2075 + val (t3a,rest3)=(add_list_of_fractions (add_fract(t1a,t2a)::xs));
119.2076 +val _= writeln"### add_list_of_fractions xs: has done add_list_of_fraction xs";
119.2077 + val (t4a,rest4)=direct_cancel(t3a);
119.2078 +val _= writeln"### add_list_of_fractions xs: has done direct_cancel(t3a)";
119.2079 + val rest=rest1 union rest2 union rest3 union rest4;
119.2080 + in
119.2081 + (writeln"### add_list_of_fractions in";
119.2082 + (
119.2083 + (t4a,rest)
119.2084 + )
119.2085 + )
119.2086 + end;
119.2087 +
119.2088 +(*. adds a list of expanded terms .*)
119.2089 +fun add_list_of_fractions_exp []= (Free("0",HOLogic.realT),[])
119.2090 + | add_list_of_fractions_exp [x]= direct_cancel_expanded x
119.2091 + | add_list_of_fractions_exp (x::y::xs) =
119.2092 + let
119.2093 + val (t1a,rest1)=direct_cancel_expanded(x);
119.2094 + val (t2a,rest2)=direct_cancel_expanded(y);
119.2095 + val (t3a,rest3)=(add_list_of_fractions_exp (add_fract_exp(t1a,t2a)::xs));
119.2096 + val (t4a,rest4)=direct_cancel_expanded(t3a);
119.2097 + val rest=rest1 union rest2 union rest3 union rest4;
119.2098 + in
119.2099 + (
119.2100 + (t4a,rest)
119.2101 + )
119.2102 + end;
119.2103 +
119.2104 +(*. calculates the lcm of a list of mv_poly .*)
119.2105 +fun calc_lcm ([x],var)= (x,var)
119.2106 + | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var);
119.2107 +
119.2108 +(*. converts a list of terms to a list of mv_poly .*)
119.2109 +fun t2d([],_)=[]
119.2110 + | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars);
119.2111 +
119.2112 +(*. same as t2d, this time for expanded forms .*)
119.2113 +fun t2d_exp([],_)=[]
119.2114 + | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars);
119.2115 +
119.2116 +(*. converts a list of fract terms to a list of their denominators .*)
119.2117 +fun termlist2denominators [] = ([],[])
119.2118 + | termlist2denominators xs =
119.2119 + let
119.2120 + val xxs=ref xs;
119.2121 + val var=ref [];
119.2122 + in
119.2123 + var:=[];
119.2124 + while length(!xxs)>0 do
119.2125 + (
119.2126 + let
119.2127 + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
119.2128 + in
119.2129 + (
119.2130 + xxs:=tl(!xxs);
119.2131 + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
119.2132 + )
119.2133 + end
119.2134 + );
119.2135 + (t2d(xs,!var),!var)
119.2136 + end;
119.2137 +
119.2138 +(*. calculates the lcm of a list of mv_poly .*)
119.2139 +fun calc_lcm ([x],var)= (x,var)
119.2140 + | calc_lcm ((x::xs),var) = (mv_lcm x (#1(calc_lcm (xs,var))),var);
119.2141 +
119.2142 +(*. converts a list of terms to a list of mv_poly .*)
119.2143 +fun t2d([],_)=[]
119.2144 + | t2d((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(term2poly p2 vars)) :: t2d(xs,vars);
119.2145 +
119.2146 +(*. same as t2d, this time for expanded forms .*)
119.2147 +fun t2d_exp([],_)=[]
119.2148 + | t2d_exp((t as (Const("HOL.divide",_) $ p1 $ p2))::xs,vars)= (the(expanded2poly p2 vars)) :: t2d_exp(xs,vars);
119.2149 +
119.2150 +(*. converts a list of fract terms to a list of their denominators .*)
119.2151 +fun termlist2denominators [] = ([],[])
119.2152 + | termlist2denominators xs =
119.2153 + let
119.2154 + val xxs=ref xs;
119.2155 + val var=ref [];
119.2156 + in
119.2157 + var:=[];
119.2158 + while length(!xxs)>0 do
119.2159 + (
119.2160 + let
119.2161 + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
119.2162 + in
119.2163 + (
119.2164 + xxs:=tl(!xxs);
119.2165 + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
119.2166 + )
119.2167 + end
119.2168 + );
119.2169 + (t2d(xs,!var),!var)
119.2170 + end;
119.2171 +
119.2172 +(*. same as termlist2denminators, this time for expanded forms .*)
119.2173 +fun termlist2denominators_exp [] = ([],[])
119.2174 + | termlist2denominators_exp xs =
119.2175 + let
119.2176 + val xxs=ref xs;
119.2177 + val var=ref [];
119.2178 + in
119.2179 + var:=[];
119.2180 + while length(!xxs)>0 do
119.2181 + (
119.2182 + let
119.2183 + val (t as Const ("HOL.divide",_) $ p1x $ p2x)=hd(!xxs);
119.2184 + in
119.2185 + (
119.2186 + xxs:=tl(!xxs);
119.2187 + var:=((get_vars(p2x)) union (get_vars(p1x)) union (!var))
119.2188 + )
119.2189 + end
119.2190 + );
119.2191 + (t2d_exp(xs,!var),!var)
119.2192 + end;
119.2193 +
119.2194 +(*. reduces all fractions to the least common denominator .*)
119.2195 +fun com_den(x::xs,denom,den,var)=
119.2196 + let
119.2197 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
119.2198 + val p2= sort (mv_geq LEX_) (the(term2poly p2' var));
119.2199 + val p3= #1(mv_division(denom,p2,LEX_));
119.2200 + val p1var=get_vars(p1');
119.2201 + in
119.2202 + if length(xs)>0 then
119.2203 + if p3=[(1,mv_null2(var))] then
119.2204 + (
119.2205 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2206 + $
119.2207 + (
119.2208 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2209 + $
119.2210 + poly2term(the (term2poly p1' p1var),p1var)
119.2211 + $
119.2212 + den
119.2213 + )
119.2214 + $
119.2215 + #1(com_den(xs,denom,den,var))
119.2216 + ,
119.2217 + []
119.2218 + )
119.2219 + else
119.2220 + (
119.2221 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2222 + $
119.2223 + (
119.2224 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2225 + $
119.2226 + (
119.2227 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2228 + poly2term(the (term2poly p1' p1var),p1var) $
119.2229 + poly2term(p3,var)
119.2230 + )
119.2231 + $
119.2232 + (
119.2233 + den
119.2234 + )
119.2235 + )
119.2236 + $
119.2237 + #1(com_den(xs,denom,den,var))
119.2238 + ,
119.2239 + []
119.2240 + )
119.2241 + else
119.2242 + if p3=[(1,mv_null2(var))] then
119.2243 + (
119.2244 + (
119.2245 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2246 + $
119.2247 + poly2term(the (term2poly p1' p1var),p1var)
119.2248 + $
119.2249 + den
119.2250 + )
119.2251 + ,
119.2252 + []
119.2253 + )
119.2254 + else
119.2255 + (
119.2256 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2257 + $
119.2258 + (
119.2259 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2260 + poly2term(the (term2poly p1' p1var),p1var) $
119.2261 + poly2term(p3,var)
119.2262 + )
119.2263 + $
119.2264 + den
119.2265 + ,
119.2266 + []
119.2267 + )
119.2268 + end;
119.2269 +
119.2270 +(*. same as com_den, this time for expanded forms .*)
119.2271 +fun com_den_exp(x::xs,denom,den,var)=
119.2272 + let
119.2273 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
119.2274 + val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var));
119.2275 + val p3= #1(mv_division(denom,p2,LEX_));
119.2276 + val p1var=get_vars(p1');
119.2277 + in
119.2278 + if length(xs)>0 then
119.2279 + if p3=[(1,mv_null2(var))] then
119.2280 + (
119.2281 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2282 + $
119.2283 + (
119.2284 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2285 + $
119.2286 + poly2expanded(the(expanded2poly p1' p1var),p1var)
119.2287 + $
119.2288 + den
119.2289 + )
119.2290 + $
119.2291 + #1(com_den_exp(xs,denom,den,var))
119.2292 + ,
119.2293 + []
119.2294 + )
119.2295 + else
119.2296 + (
119.2297 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2298 + $
119.2299 + (
119.2300 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2301 + $
119.2302 + (
119.2303 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2304 + poly2expanded(the(expanded2poly p1' p1var),p1var) $
119.2305 + poly2expanded(p3,var)
119.2306 + )
119.2307 + $
119.2308 + (
119.2309 + den
119.2310 + )
119.2311 + )
119.2312 + $
119.2313 + #1(com_den_exp(xs,denom,den,var))
119.2314 + ,
119.2315 + []
119.2316 + )
119.2317 + else
119.2318 + if p3=[(1,mv_null2(var))] then
119.2319 + (
119.2320 + (
119.2321 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2322 + $
119.2323 + poly2expanded(the(expanded2poly p1' p1var),p1var)
119.2324 + $
119.2325 + den
119.2326 + )
119.2327 + ,
119.2328 + []
119.2329 + )
119.2330 + else
119.2331 + (
119.2332 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT)
119.2333 + $
119.2334 + (
119.2335 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2336 + poly2expanded(the(expanded2poly p1' p1var),p1var) $
119.2337 + poly2expanded(p3,var)
119.2338 + )
119.2339 + $
119.2340 + den
119.2341 + ,
119.2342 + []
119.2343 + )
119.2344 + end;
119.2345 +
119.2346 +(* wird aktuell nicht mehr gebraucht, bei rückänderung schon
119.2347 +-------------------------------------------------------------
119.2348 +(* WN0210???SK brauch ma des überhaupt *)
119.2349 +fun com_den2(x::xs,denom,den,var)=
119.2350 + let
119.2351 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
119.2352 + val p2= sort (mv_geq LEX_) (the(term2poly p2' var));
119.2353 + val p3= #1(mv_division(denom,p2,LEX_));
119.2354 + val p1var=get_vars(p1');
119.2355 + in
119.2356 + if length(xs)>0 then
119.2357 + if p3=[(1,mv_null2(var))] then
119.2358 + (
119.2359 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2360 + poly2term(the(term2poly p1' p1var),p1var) $
119.2361 + com_den2(xs,denom,den,var)
119.2362 + )
119.2363 + else
119.2364 + (
119.2365 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2366 + (
119.2367 + let
119.2368 + val p3'=poly2term(p3,var);
119.2369 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
119.2370 + in
119.2371 + poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars)
119.2372 + end
119.2373 + ) $
119.2374 + com_den2(xs,denom,den,var)
119.2375 + )
119.2376 + else
119.2377 + if p3=[(1,mv_null2(var))] then
119.2378 + (
119.2379 + poly2term(the(term2poly p1' p1var),p1var)
119.2380 + )
119.2381 + else
119.2382 + (
119.2383 + let
119.2384 + val p3'=poly2term(p3,var);
119.2385 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
119.2386 + in
119.2387 + poly2term(sort (mv_geq LEX_) (mv_mul(the(term2poly p1' vars) ,the(term2poly p3' vars),LEX_)),vars)
119.2388 + end
119.2389 + )
119.2390 + end;
119.2391 +
119.2392 +(* WN0210???SK brauch ma des überhaupt *)
119.2393 +fun com_den_exp2(x::xs,denom,den,var)=
119.2394 + let
119.2395 + val (t as Const ("HOL.divide",_) $ p1' $ p2')=x;
119.2396 + val p2= sort (mv_geq LEX_) (the(expanded2poly p2' var));
119.2397 + val p3= #1(mv_division(denom,p2,LEX_));
119.2398 + val p1var=get_vars p1';
119.2399 + in
119.2400 + if length(xs)>0 then
119.2401 + if p3=[(1,mv_null2(var))] then
119.2402 + (
119.2403 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2404 + poly2expanded(the (expanded2poly p1' p1var),p1var) $
119.2405 + com_den_exp2(xs,denom,den,var)
119.2406 + )
119.2407 + else
119.2408 + (
119.2409 + Const ("op +",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2410 + (
119.2411 + let
119.2412 + val p3'=poly2expanded(p3,var);
119.2413 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
119.2414 + in
119.2415 + poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars)
119.2416 + end
119.2417 + ) $
119.2418 + com_den_exp2(xs,denom,den,var)
119.2419 + )
119.2420 + else
119.2421 + if p3=[(1,mv_null2(var))] then
119.2422 + (
119.2423 + poly2expanded(the (expanded2poly p1' p1var),p1var)
119.2424 + )
119.2425 + else
119.2426 + (
119.2427 + let
119.2428 + val p3'=poly2expanded(p3,var);
119.2429 + val vars= (((map free2str) o vars) p1') union (((map free2str) o vars) p3');
119.2430 + in
119.2431 + poly2expanded(sort (mv_geq LEX_) (mv_mul(the(expanded2poly p1' vars) ,the(expanded2poly p3' vars),LEX_)),vars)
119.2432 + end
119.2433 + )
119.2434 + end;
119.2435 +---------------------------------------------------------*)
119.2436 +
119.2437 +
119.2438 +(*. searches for an element y of a list ys, which has an gcd not 1 with x .*)
119.2439 +fun exists_gcd (x,[]) = false
119.2440 + | exists_gcd (x,y::ys) = if mv_gcd x y = [(1,mv_null2(#2(hd(x))))] then exists_gcd (x,ys)
119.2441 + else true;
119.2442 +
119.2443 +(*. divides each element of the list xs with y .*)
119.2444 +fun list_div ([],y) = []
119.2445 + | list_div (x::xs,y) =
119.2446 + let
119.2447 + val (d,r)=mv_division(x,y,LEX_);
119.2448 + in
119.2449 + if r=[] then
119.2450 + d::list_div(xs,y)
119.2451 + else x::list_div(xs,y)
119.2452 + end;
119.2453 +
119.2454 +(*. checks if x is in the list ys .*)
119.2455 +fun in_list (x,[]) = false
119.2456 + | in_list (x,y::ys) = if x=y then true
119.2457 + else in_list(x,ys);
119.2458 +
119.2459 +(*. deletes all equal elements of the list xs .*)
119.2460 +fun kill_equal [] = []
119.2461 + | kill_equal (x::xs) = if in_list(x,xs) orelse x=[(1,mv_null2(#2(hd(x))))] then kill_equal(xs)
119.2462 + else x::kill_equal(xs);
119.2463 +
119.2464 +(*. searches for new factors .*)
119.2465 +fun new_factors [] = []
119.2466 + | new_factors (list:mv_poly list):mv_poly list =
119.2467 + let
119.2468 + val l = kill_equal list;
119.2469 + val len = length(l);
119.2470 + in
119.2471 + if len>=2 then
119.2472 + (
119.2473 + let
119.2474 + val x::y::xs=l;
119.2475 + val gcd=mv_gcd x y;
119.2476 + in
119.2477 + if gcd=[(1,mv_null2(#2(hd(x))))] then
119.2478 + (
119.2479 + if exists_gcd(x,xs) then new_factors (y::xs @ [x])
119.2480 + else x::new_factors(y::xs)
119.2481 + )
119.2482 + else gcd::new_factors(kill_equal(list_div(x::y::xs,gcd)))
119.2483 + end
119.2484 + )
119.2485 + else
119.2486 + if len=1 then [hd(l)]
119.2487 + else []
119.2488 + end;
119.2489 +
119.2490 +(*. gets the factors of a list .*)
119.2491 +fun get_factors x = new_factors x;
119.2492 +
119.2493 +(*. multiplies the elements of the list .*)
119.2494 +fun multi_list [] = []
119.2495 + | multi_list (x::xs) = if xs=[] then x
119.2496 + else mv_mul(x,multi_list xs,LEX_);
119.2497 +
119.2498 +(*. makes a term out of the elements of the list (polynomial representation) .*)
119.2499 +fun make_term ([],vars) = Free(str_of_int 0,HOLogic.realT)
119.2500 + | make_term ((x::xs),vars) = if length(xs)=0 then poly2term(sort (mv_geq LEX_) (x),vars)
119.2501 + else
119.2502 + (
119.2503 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2504 + poly2term(sort (mv_geq LEX_) (x),vars) $
119.2505 + make_term(xs,vars)
119.2506 + );
119.2507 +
119.2508 +(*. factorizes the denominator (polynomial representation) .*)
119.2509 +fun factorize_den (l,den,vars) =
119.2510 + let
119.2511 + val factor_list=kill_equal( (get_factors l));
119.2512 + val mlist=multi_list(factor_list);
119.2513 + val (last,rest)=mv_division(den,multi_list(factor_list),LEX_);
119.2514 + in
119.2515 + if rest=[] then
119.2516 + (
119.2517 + if last=[(1,mv_null2(vars))] then make_term(factor_list,vars)
119.2518 + else make_term(last::factor_list,vars)
119.2519 + )
119.2520 + else raise error ("RATIONALS_FACTORIZE_DEN_EXCEPTION: Invalid factor by division")
119.2521 + end;
119.2522 +
119.2523 +(*. makes a term out of the elements of the list (expanded polynomial representation) .*)
119.2524 +fun make_exp ([],vars) = Free(str_of_int 0,HOLogic.realT)
119.2525 + | make_exp ((x::xs),vars) = if length(xs)=0 then poly2expanded(sort (mv_geq LEX_) (x),vars)
119.2526 + else
119.2527 + (
119.2528 + Const ("op *",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2529 + poly2expanded(sort (mv_geq LEX_) (x),vars) $
119.2530 + make_exp(xs,vars)
119.2531 + );
119.2532 +
119.2533 +(*. factorizes the denominator (expanded polynomial representation) .*)
119.2534 +fun factorize_den_exp (l,den,vars) =
119.2535 + let
119.2536 + val factor_list=kill_equal( (get_factors l));
119.2537 + val mlist=multi_list(factor_list);
119.2538 + val (last,rest)=mv_division(den,multi_list(factor_list),LEX_);
119.2539 + in
119.2540 + if rest=[] then
119.2541 + (
119.2542 + if last=[(1,mv_null2(vars))] then make_exp(factor_list,vars)
119.2543 + else make_exp(last::factor_list,vars)
119.2544 + )
119.2545 + else raise error ("RATIONALS_FACTORIZE_DEN_EXP_EXCEPTION: Invalid factor by division")
119.2546 + end;
119.2547 +
119.2548 +(*. calculates the common denominator of all elements of the list and multiplies .*)
119.2549 +(*. the nominators and denominators with the correct factor .*)
119.2550 +(*. (polynomial representation) .*)
119.2551 +fun step_add_list_of_fractions []=(Free("0",HOLogic.realT),[]:term list)
119.2552 + | step_add_list_of_fractions [x]= raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXCEPTION: Nothing to add")
119.2553 + | step_add_list_of_fractions (xs) =
119.2554 + let
119.2555 + val den_list=termlist2denominators (xs); (* list of denominators *)
119.2556 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
119.2557 + val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
119.2558 + in
119.2559 + com_den(xs,denom,den,var)
119.2560 + end;
119.2561 +
119.2562 +(*. calculates the common denominator of all elements of the list and multiplies .*)
119.2563 +(*. the nominators and denominators with the correct factor .*)
119.2564 +(*. (expanded polynomial representation) .*)
119.2565 +fun step_add_list_of_fractions_exp [] = (Free("0",HOLogic.realT),[]:term list)
119.2566 + | step_add_list_of_fractions_exp [x] = raise error ("RATIONALS_STEP_ADD_LIST_OF_FRACTIONS_EXP_EXCEPTION: Nothing to add")
119.2567 + | step_add_list_of_fractions_exp (xs)=
119.2568 + let
119.2569 + val den_list=termlist2denominators_exp (xs); (* list of denominators *)
119.2570 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
119.2571 + val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
119.2572 + in
119.2573 + com_den_exp(xs,denom,den,var)
119.2574 + end;
119.2575 +
119.2576 +(* wird aktuell nicht mehr gebraucht, bei rückänderung schon
119.2577 +-------------------------------------------------------------
119.2578 +(* WN0210???SK brauch ma des überhaupt *)
119.2579 +fun step_add_list_of_fractions2 []=(Free("0",HOLogic.realT),[]:term list)
119.2580 + | step_add_list_of_fractions2 [x]=(x,[])
119.2581 + | step_add_list_of_fractions2 (xs) =
119.2582 + let
119.2583 + val den_list=termlist2denominators (xs); (* list of denominators *)
119.2584 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
119.2585 + val den=factorize_den(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
119.2586 + in
119.2587 + (
119.2588 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2589 + com_den2(xs,denom, poly2term(denom,var)(*den*),var) $
119.2590 + poly2term(denom,var)
119.2591 + ,
119.2592 + []
119.2593 + )
119.2594 + end;
119.2595 +
119.2596 +(* WN0210???SK brauch ma des überhaupt *)
119.2597 +fun step_add_list_of_fractions2_exp []=(Free("0",HOLogic.realT),[]:term list)
119.2598 + | step_add_list_of_fractions2_exp [x]=(x,[])
119.2599 + | step_add_list_of_fractions2_exp (xs) =
119.2600 + let
119.2601 + val den_list=termlist2denominators_exp (xs); (* list of denominators *)
119.2602 + val (denom,var)=calc_lcm(den_list); (* common denominator *)
119.2603 + val den=factorize_den_exp(#1(den_list),denom,var); (* faktorisierter Nenner !!! *)
119.2604 + in
119.2605 + (
119.2606 + Const ("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2607 + com_den_exp2(xs,denom, poly2term(denom,var)(*den*),var) $
119.2608 + poly2expanded(denom,var)
119.2609 + ,
119.2610 + []
119.2611 + )
119.2612 + end;
119.2613 +---------------------------------------------- *)
119.2614 +
119.2615 +
119.2616 +(*. converts a term, which contains severel terms seperated by +, into a list of these terms .*)
119.2617 +fun term2list (t as (Const("HOL.divide",_) $ _ $ _)) = [t]
119.2618 + | term2list (t as (Const("Atools.pow",_) $ _ $ _)) =
119.2619 + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2620 + t $ Free("1",HOLogic.realT)
119.2621 + ]
119.2622 + | term2list (t as (Free(_,_))) =
119.2623 + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2624 + t $ Free("1",HOLogic.realT)
119.2625 + ]
119.2626 + | term2list (t as (Const("op *",_) $ _ $ _)) =
119.2627 + [Const("HOL.divide",[HOLogic.realT,HOLogic.realT]--->HOLogic.realT) $
119.2628 + t $ Free("1",HOLogic.realT)
119.2629 + ]
119.2630 + | term2list (Const("op +",_) $ t1 $ t2) = term2list(t1) @ term2list(t2)
119.2631 + | term2list (Const("op -",_) $ t1 $ t2) =
119.2632 + raise error ("RATIONALS_TERM2LIST_EXCEPTION: - not implemented yet")
119.2633 + | term2list _ = raise error ("RATIONALS_TERM2LIST_EXCEPTION: invalid term");
119.2634 +
119.2635 +(*.factors out the gcd of nominator and denominator:
119.2636 + a/b = (a' * gcd)/(b' * gcd), a,b,gcd are poly[2].*)
119.2637 +fun factout_p_ (thy:theory) t = SOME (step_cancel t,[]:term list);
119.2638 +fun factout_ (thy:theory) t = SOME (step_cancel_expanded t,[]:term list);
119.2639 +
119.2640 +(*.cancels a single fraction with normalform [2]
119.2641 + resulting in a canceled fraction [2], see factout_ .*)
119.2642 +fun cancel_p_ (thy:theory) t = (*WN.2.6.03 no rewrite -> NONE !*)
119.2643 + (let val (t',asm) = direct_cancel(*_expanded ... corrected MG.21.8.03*) t
119.2644 + in if t = t' then NONE else SOME (t',asm)
119.2645 + end) handle _ => NONE;
119.2646 +(*.the same as above with normalform [3]
119.2647 + val cancel_ :
119.2648 + theory -> (*10.02 unused *)
119.2649 + term -> (*fraction in normalform [3] *)
119.2650 + (term * (*fraction in normalform [3] *)
119.2651 + term list) (*casual asumptions in normalform [3] *)
119.2652 + option (*NONE: the function is not applicable *).*)
119.2653 +fun cancel_ (thy:theory) t = SOME (direct_cancel_expanded t) handle _ => NONE;
119.2654 +
119.2655 +(*.transforms sums of at least 2 fractions [3] to
119.2656 + sums with the least common multiple as nominator.*)
119.2657 +fun common_nominator_p_ (thy:theory) t =
119.2658 +((*writeln("### common_nominator_p_ called");*)
119.2659 + SOME (step_add_list_of_fractions(term2list(t))) handle _ => NONE
119.2660 +);
119.2661 +fun common_nominator_ (thy:theory) t =
119.2662 + SOME (step_add_list_of_fractions_exp(term2list(t))) handle _ => NONE;
119.2663 +
119.2664 +(*.add 2 or more fractions
119.2665 +val add_fraction_p_ :
119.2666 + theory -> (*10.02 unused *)
119.2667 + term -> (*2 or more fractions with normalform [2] *)
119.2668 + (term * (*one fraction with normalform [2] *)
119.2669 + term list) (*casual assumptions in normalform [2] WN0210???SK *)
119.2670 + option (*NONE: the function is not applicable *).*)
119.2671 +fun add_fraction_p_ (thy:theory) t =
119.2672 +(writeln("### add_fraction_p_ called");
119.2673 + (let val ts = term2list t
119.2674 + in if 1 < length ts
119.2675 + then SOME (add_list_of_fractions ts)
119.2676 + else NONE (*raise error ("RATIONALS_ADD_EXCEPTION: nothing to add")*)
119.2677 + end) handle _ => NONE
119.2678 +);
119.2679 +(*.same as add_fraction_p_ but with normalform [3].*)
119.2680 +(*SOME (step_add_list_of_fractions2(term2list(t))); *)
119.2681 +fun add_fraction_ (thy:theory) t =
119.2682 + if length(term2list(t))>1
119.2683 + then SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE
119.2684 + else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*)
119.2685 + NONE;
119.2686 +fun add_fraction_ (thy:theory) t =
119.2687 + (if 1 < length (term2list t)
119.2688 + then SOME (add_list_of_fractions_exp (term2list t))
119.2689 + else (*raise error ("RATIONALS_ADD_FRACTION_EXCEPTION: nothing to add")*)
119.2690 + NONE) handle _ => NONE;
119.2691 +
119.2692 +(*SOME (step_add_list_of_fractions2_exp(term2list(t))); *)
119.2693 +
119.2694 +(*. brings the term into a normal form .*)
119.2695 +fun norm_rational_ (thy:theory) t =
119.2696 + SOME (add_list_of_fractions(term2list(t))) handle _ => NONE;
119.2697 +fun norm_expanded_rat_ (thy:theory) t =
119.2698 + SOME (add_list_of_fractions_exp(term2list(t))) handle _ => NONE;
119.2699 +
119.2700 +
119.2701 +(*.evaluates conditions in calculate_Rational.*)
119.2702 +(*make local with FIXX@ME result:term *term list*)
119.2703 +val calc_rat_erls = prep_rls(
119.2704 + Rls {id = "calc_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.2705 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [], *)
119.2706 + rules =
119.2707 + [Calc ("op =",eval_equal "#equal_"),
119.2708 + Calc ("Atools.is'_const",eval_const "#is_const_"),
119.2709 + Thm ("not_true",num_str not_true),
119.2710 + Thm ("not_false",num_str not_false)
119.2711 + ],
119.2712 + scr = EmptyScr});
119.2713 +
119.2714 +
119.2715 +(*.simplifies expressions with numerals;
119.2716 + does NOT rearrange the term by AC-rewriting; thus terms with variables
119.2717 + need to have constants to be commuted together respectively.*)
119.2718 +val calculate_Rational = prep_rls(
119.2719 + merge_rls "calculate_Rational"
119.2720 + (Rls {id = "divide", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.2721 + erls = calc_rat_erls, srls = Erls, (*asm_thm = [],*)
119.2722 + calc = [],
119.2723 + rules =
119.2724 + [Calc ("HOL.divide" ,eval_cancel "#divide_"),
119.2725 +
119.2726 + Thm ("sym_real_minus_divide_eq",
119.2727 + num_str (real_minus_divide_eq RS sym)),
119.2728 + (*SYM - ?x / ?y = - (?x / ?y) may come from subst*)
119.2729 +
119.2730 + Thm ("rat_add",num_str rat_add),
119.2731 + (*"[| a is_const; b is_const; c is_const; d is_const |] ==> \
119.2732 + \"a / c + b / d = (a * d) / (c * d) + (b * c ) / (d * c)"*)
119.2733 + Thm ("rat_add1",num_str rat_add1),
119.2734 + (*"[| a is_const; b is_const; c is_const |] ==> \
119.2735 + \"a / c + b / c = (a + b) / c"*)
119.2736 + Thm ("rat_add2",num_str rat_add2),
119.2737 + (*"[| ?a is_const; ?b is_const; ?c is_const |] ==> \
119.2738 + \?a / ?c + ?b = (?a + ?b * ?c) / ?c"*)
119.2739 + Thm ("rat_add3",num_str rat_add3),
119.2740 + (*"[| a is_const; b is_const; c is_const |] ==> \
119.2741 + \"a + b / c = (a * c) / c + b / c"\
119.2742 + \.... is_const to be omitted here FIXME*)
119.2743 +
119.2744 + Thm ("rat_mult",num_str rat_mult),
119.2745 + (*a / b * (c / d) = a * c / (b * d)*)
119.2746 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
119.2747 + (*?x * (?y / ?z) = ?x * ?y / ?z*)
119.2748 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
119.2749 + (*?y / ?z * ?x = ?y * ?x / ?z*)
119.2750 +
119.2751 + Thm ("real_divide_divide1",num_str real_divide_divide1),
119.2752 + (*"?y ~= 0 ==> ?u / ?v / (?y / ?z) = ?u / ?v * (?z / ?y)"*)
119.2753 + Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq),
119.2754 + (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
119.2755 +
119.2756 + Thm ("rat_power", num_str rat_power),
119.2757 + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
119.2758 +
119.2759 + Thm ("mult_cross",num_str mult_cross),
119.2760 + (*"[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)*)
119.2761 + Thm ("mult_cross1",num_str mult_cross1),
119.2762 + (*" b ~= 0 ==> (a / b = c ) = (a = b * c)*)
119.2763 + Thm ("mult_cross2",num_str mult_cross2)
119.2764 + (*" d ~= 0 ==> (a = c / d) = (a * d = c)*)
119.2765 + ], scr = EmptyScr})
119.2766 + calculate_Poly);
119.2767 +
119.2768 +
119.2769 +(*("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))*)
119.2770 +fun eval_is_expanded (thmid:string) _
119.2771 + (t as (Const("Rational.is'_expanded", _) $ arg)) thy =
119.2772 + if is_expanded arg
119.2773 + then SOME (mk_thmid thmid ""
119.2774 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
119.2775 + Trueprop $ (mk_equality (t, HOLogic.true_const)))
119.2776 + else SOME (mk_thmid thmid ""
119.2777 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
119.2778 + Trueprop $ (mk_equality (t, HOLogic.false_const)))
119.2779 + | eval_is_expanded _ _ _ _ = NONE;
119.2780 +
119.2781 +val rational_erls =
119.2782 + merge_rls "rational_erls" calculate_Rational
119.2783 + (append_rls "is_expanded" Atools_erls
119.2784 + [Calc ("Rational.is'_expanded", eval_is_expanded "")
119.2785 + ]);
119.2786 +
119.2787 +
119.2788 +
119.2789 +(*.3 'reverse-rewrite-sets' for symbolic computation on rationals:
119.2790 + =================================================================
119.2791 + A[2] 'cancel_p': .
119.2792 + A[3] 'cancel': .
119.2793 + B[2] 'common_nominator_p': transforms summands in a term [2]
119.2794 + to fractions with the (least) common multiple as nominator.
119.2795 + B[3] 'norm_rational': normalizes arbitrary algebraic terms (without
119.2796 + radicals and transzendental functions) to one canceled fraction,
119.2797 + nominator and denominator in polynomial form.
119.2798 +
119.2799 +In order to meet isac's requirements for interactive and stepwise calculation,
119.2800 +each 'reverse-rewerite-set' consists of an initialization for the interpreter
119.2801 +state and of 4 functions, each of which employs rewriting as much as possible.
119.2802 +The signature of these functions are the same in each 'reverse-rewrite-set'
119.2803 +respectively.*)
119.2804 +
119.2805 +(* ************************************************************************* *)
119.2806 +
119.2807 +
119.2808 +local(*. cancel_p
119.2809 +------------------------
119.2810 +cancels a single fraction consisting of two (uni- or multivariate)
119.2811 +polynomials WN0609???SK[2] into another such a fraction; examples:
119.2812 +
119.2813 + a^2 + -1*b^2 a + b
119.2814 + -------------------- = ---------
119.2815 + a^2 + -2*a*b + b^2 a + -1*b
119.2816 +
119.2817 + a^2 a
119.2818 + --- = ---
119.2819 + a 1
119.2820 +
119.2821 +Remark: the reverse ruleset does _NOT_ work properly with other input !.*)
119.2822 +(*WN020824 wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*)
119.2823 +
119.2824 +val {rules, rew_ord=(_,ro),...} =
119.2825 + rep_rls (assoc_rls "make_polynomial");
119.2826 +(*WN060829 ... make_deriv does not terminate with 1st expl above,
119.2827 + see rational.sml --- investigate rulesets for cancel_p ---*)
119.2828 +val {rules, rew_ord=(_,ro),...} =
119.2829 + rep_rls (assoc_rls "rev_rew_p");
119.2830 +
119.2831 +val thy = Rational.thy;
119.2832 +
119.2833 +(*.init_state = fn : term -> istate
119.2834 +initialzies the state of the script interpreter. The state is:
119.2835 +
119.2836 +type rrlsstate = (*state for reverse rewriting*)
119.2837 + (term * (*the current formula*)
119.2838 + term * (*the final term*)
119.2839 + rule list (*'reverse rule list' (#)*)
119.2840 + list * (*may be serveral, eg. in norm_rational*)
119.2841 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
119.2842 + (term * (*... rewrite with ...*)
119.2843 + term list)) (*... assumptions*)
119.2844 + list); (*derivation from given term to normalform
119.2845 + in reverse order with sym_thm;
119.2846 + (#) could be extracted from here by (map #1)*).*)
119.2847 +(* val {rules, rew_ord=(_,ro),...} =
119.2848 + rep_rls (assoc_rls "rev_rew_p") (*USE ALWAYS, SEE val cancel_p*);
119.2849 + val (thy, eval_rls, ro) =(Rational.thy, Atools_erls, ro) (*..val cancel_p*);
119.2850 + val t = t;
119.2851 + *)
119.2852 +fun init_state thy eval_rls ro t =
119.2853 + let val SOME (t',_) = factout_p_ thy t
119.2854 + val SOME (t'',asm) = cancel_p_ thy t
119.2855 + val der = reverse_deriv thy eval_rls rules ro NONE t'
119.2856 + val der = der @ [(Thm ("real_mult_div_cancel2",
119.2857 + num_str real_mult_div_cancel2),
119.2858 + (t'',asm))]
119.2859 + val rs = (distinct_Thm o (map #1)) der
119.2860 + val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
119.2861 + "sym_real_mult_0",
119.2862 + "sym_real_mult_1"
119.2863 + (*..insufficient,eg.make_Polynomial*)])rs
119.2864 + in (t,t'',[rs(*here only _ONE_ to ease locate_rule*)],der) end;
119.2865 +
119.2866 +(*.locate_rule = fn : rule list -> term -> rule
119.2867 + -> (rule * (term * term list) option) list.
119.2868 + checks a rule R for being a cancel-rule, and if it is,
119.2869 + then return the list of rules (+ the terms they are rewriting to)
119.2870 + which need to be applied before R should be applied.
119.2871 + precondition: the rule is applicable to the argument-term.
119.2872 +arguments:
119.2873 + rule list: the reverse rule list
119.2874 + -> term : ... to which the rule shall be applied
119.2875 + -> rule : ... to be applied to term
119.2876 +value:
119.2877 + -> (rule : a rule rewriting to ...
119.2878 + * (term : ... the resulting term ...
119.2879 + * term list): ... with the assumptions ( //#0).
119.2880 + ) list : there may be several such rules;
119.2881 + the list is empty, if the rule has nothing to do
119.2882 + with cancelation.*)
119.2883 +(* val () = ();
119.2884 + *)
119.2885 +fun locate_rule thy eval_rls ro [rs] t r =
119.2886 + if (id_of_thm r) mem (map (id_of_thm)) rs
119.2887 + then let val ropt =
119.2888 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
119.2889 + in case ropt of
119.2890 + SOME ta => [(r, ta)]
119.2891 + | NONE => (writeln("### locate_rule: rewrite "^
119.2892 + (id_of_thm r)^" "^(term2str t)^" = NONE");
119.2893 + []) end
119.2894 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
119.2895 + | locate_rule _ _ _ _ _ _ =
119.2896 + raise error ("locate_rule: doesnt match rev-sets in istate");
119.2897 +
119.2898 +(*.next_rule = fn : rule list -> term -> rule option
119.2899 + for a given term return the next rules to be done for cancelling.
119.2900 +arguments:
119.2901 + rule list : the reverse rule list
119.2902 + term : the term for which ...
119.2903 +value:
119.2904 + -> rule option: ... this rule is appropriate for cancellation;
119.2905 + there may be no such rule (if the term is canceled already.*)
119.2906 +(* val thy = Rational.thy;
119.2907 + val Rrls {rew_ord=(_,ro),...} = cancel;
119.2908 + val ([rs],t) = (rss,f);
119.2909 + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
119.2910 +
119.2911 + val (thy, [rs]) = (Rational.thy, revsets);
119.2912 + val Rrls {rew_ord=(_,ro),...} = cancel;
119.2913 + nex [rs] t;
119.2914 + *)
119.2915 +fun next_rule thy eval_rls ro [rs] t =
119.2916 + let val der = make_deriv thy eval_rls rs ro NONE t;
119.2917 + in case der of
119.2918 +(* val (_,r,_)::_ = der;
119.2919 + *)
119.2920 + (_,r,_)::_ => SOME r
119.2921 + | _ => NONE
119.2922 + end
119.2923 + | next_rule _ _ _ _ _ =
119.2924 + raise error ("next_rule: doesnt match rev-sets in istate");
119.2925 +
119.2926 +(*.val attach_form = f : rule list -> term -> term
119.2927 + -> (rule * (term * term list)) list
119.2928 + checks an input term TI, if it may belong to a current cancellation, by
119.2929 + trying to derive it from the given term TG.
119.2930 +arguments:
119.2931 + term : TG, the last one in the cancellation agreed upon by user + math-eng
119.2932 + -> term: TI, the next one input by the user
119.2933 +value:
119.2934 + -> (rule : the rule to be applied in order to reach TI
119.2935 + * (term : ... obtained by applying the rule ...
119.2936 + * term list): ... and the respective assumptions.
119.2937 + ) list : there may be several such rules;
119.2938 + the list is empty, if the users term does not belong
119.2939 + to a cancellation of the term last agreed upon.*)
119.2940 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
119.2941 + []:(rule * (term * term list)) list;
119.2942 +
119.2943 +in
119.2944 +
119.2945 +val cancel_p =
119.2946 + Rrls {id = "cancel_p", prepat=[],
119.2947 + rew_ord=("ord_make_polynomial",
119.2948 + ord_make_polynomial false Rational.thy),
119.2949 + erls = rational_erls,
119.2950 + calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
119.2951 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
119.2952 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
119.2953 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
119.2954 + (*asm_thm=[("real_mult_div_cancel2","")],*)
119.2955 + scr=Rfuns {init_state = init_state thy Atools_erls ro,
119.2956 + normal_form = cancel_p_ thy,
119.2957 + locate_rule = locate_rule thy Atools_erls ro,
119.2958 + next_rule = next_rule thy Atools_erls ro,
119.2959 + attach_form = attach_form}}
119.2960 +end;(*local*)
119.2961 +
119.2962 +
119.2963 +local(*.ad (1) 'cancel'
119.2964 +------------------------------
119.2965 +cancels a single fraction consisting of two (uni- or multivariate)
119.2966 +polynomials WN0609???SK[3] into another such a fraction; examples:
119.2967 +
119.2968 + a^2 - b^2 a + b
119.2969 + -------------------- = ---------
119.2970 + a^2 - 2*a*b + b^2 a - *b
119.2971 +
119.2972 +Remark: the reverse ruleset does _NOT_ work properly with other input !.*)
119.2973 +(*WN 24.8.02: wir werden "uberlegen, wie wir ungeeignete inputs zur"uckweisen*)
119.2974 +
119.2975 +(*
119.2976 +val SOME (Rls {rules=rules,rew_ord=(_,ro),...}) =
119.2977 + assoc'(!ruleset',"expand_binoms");
119.2978 +*)
119.2979 +val {rules=rules,rew_ord=(_,ro),...} =
119.2980 + rep_rls (assoc_rls "expand_binoms");
119.2981 +val thy = Rational.thy;
119.2982 +
119.2983 +fun init_state thy eval_rls ro t =
119.2984 + let val SOME (t',_) = factout_ thy t;
119.2985 + val SOME (t'',asm) = cancel_ thy t;
119.2986 + val der = reverse_deriv thy eval_rls rules ro NONE t';
119.2987 + val der = der @ [(Thm ("real_mult_div_cancel2",
119.2988 + num_str real_mult_div_cancel2),
119.2989 + (t'',asm))]
119.2990 + val rs = map #1 der;
119.2991 + in (t,t'',[rs],der) end;
119.2992 +
119.2993 +fun locate_rule thy eval_rls ro [rs] t r =
119.2994 + if (id_of_thm r) mem (map (id_of_thm)) rs
119.2995 + then let val ropt =
119.2996 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
119.2997 + in case ropt of
119.2998 + SOME ta => [(r, ta)]
119.2999 + | NONE => (writeln("### locate_rule: rewrite "^
119.3000 + (id_of_thm r)^" "^(term2str t)^" = NONE");
119.3001 + []) end
119.3002 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
119.3003 + | locate_rule _ _ _ _ _ _ =
119.3004 + raise error ("locate_rule: doesnt match rev-sets in istate");
119.3005 +
119.3006 +fun next_rule thy eval_rls ro [rs] t =
119.3007 + let val der = make_deriv thy eval_rls rs ro NONE t;
119.3008 + in case der of
119.3009 +(* val (_,r,_)::_ = der;
119.3010 + *)
119.3011 + (_,r,_)::_ => SOME r
119.3012 + | _ => NONE
119.3013 + end
119.3014 + | next_rule _ _ _ _ _ =
119.3015 + raise error ("next_rule: doesnt match rev-sets in istate");
119.3016 +
119.3017 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
119.3018 + []:(rule * (term * term list)) list;
119.3019 +
119.3020 +val pat = (term_of o the o (parse thy)) "?r/?s";
119.3021 +val pre1 = (term_of o the o (parse thy)) "?r is_expanded";
119.3022 +val pre2 = (term_of o the o (parse thy)) "?s is_expanded";
119.3023 +val prepat = [([pre1, pre2], pat)];
119.3024 +
119.3025 +in
119.3026 +
119.3027 +
119.3028 +val cancel =
119.3029 + Rrls {id = "cancel", prepat=prepat,
119.3030 + rew_ord=("ord_make_polynomial",
119.3031 + ord_make_polynomial false Rational.thy),
119.3032 + erls = rational_erls,
119.3033 + calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
119.3034 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
119.3035 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
119.3036 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
119.3037 + scr=Rfuns {init_state = init_state thy Atools_erls ro,
119.3038 + normal_form = cancel_ thy,
119.3039 + locate_rule = locate_rule thy Atools_erls ro,
119.3040 + next_rule = next_rule thy Atools_erls ro,
119.3041 + attach_form = attach_form}}
119.3042 +end;(*local*)
119.3043 +
119.3044 +
119.3045 +
119.3046 +local(*.ad [2] 'common_nominator_p'
119.3047 +---------------------------------
119.3048 +FIXME Beschreibung .*)
119.3049 +
119.3050 +
119.3051 +val {rules=rules,rew_ord=(_,ro),...} =
119.3052 + rep_rls (assoc_rls "make_polynomial");
119.3053 +(*WN060829 ... make_deriv does not terminate with 1st expl above,
119.3054 + see rational.sml --- investigate rulesets for cancel_p ---*)
119.3055 +val {rules, rew_ord=(_,ro),...} =
119.3056 + rep_rls (assoc_rls "rev_rew_p");
119.3057 +val thy = Rational.thy;
119.3058 +
119.3059 +
119.3060 +(*.common_nominator_p_ = fn : theory -> term -> (term * term list) option
119.3061 + as defined above*)
119.3062 +
119.3063 +(*.init_state = fn : term -> istate
119.3064 +initialzies the state of the interactive interpreter. The state is:
119.3065 +
119.3066 +type rrlsstate = (*state for reverse rewriting*)
119.3067 + (term * (*the current formula*)
119.3068 + term * (*the final term*)
119.3069 + rule list (*'reverse rule list' (#)*)
119.3070 + list * (*may be serveral, eg. in norm_rational*)
119.3071 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
119.3072 + (term * (*... rewrite with ...*)
119.3073 + term list)) (*... assumptions*)
119.3074 + list); (*derivation from given term to normalform
119.3075 + in reverse order with sym_thm;
119.3076 + (#) could be extracted from here by (map #1)*).*)
119.3077 +fun init_state thy eval_rls ro t =
119.3078 + let val SOME (t',_) = common_nominator_p_ thy t;
119.3079 + val SOME (t'',asm) = add_fraction_p_ thy t;
119.3080 + val der = reverse_deriv thy eval_rls rules ro NONE t';
119.3081 + val der = der @ [(Thm ("real_mult_div_cancel2",
119.3082 + num_str real_mult_div_cancel2),
119.3083 + (t'',asm))]
119.3084 + val rs = (distinct_Thm o (map #1)) der;
119.3085 + val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
119.3086 + "sym_real_mult_0",
119.3087 + "sym_real_mult_1"]) rs;
119.3088 + in (t,t'',[rs(*here only _ONE_*)],der) end;
119.3089 +
119.3090 +(* use"knowledge/Rational.ML";
119.3091 + *)
119.3092 +
119.3093 +(*.locate_rule = fn : rule list -> term -> rule
119.3094 + -> (rule * (term * term list) option) list.
119.3095 + checks a rule R for being a cancel-rule, and if it is,
119.3096 + then return the list of rules (+ the terms they are rewriting to)
119.3097 + which need to be applied before R should be applied.
119.3098 + precondition: the rule is applicable to the argument-term.
119.3099 +arguments:
119.3100 + rule list: the reverse rule list
119.3101 + -> term : ... to which the rule shall be applied
119.3102 + -> rule : ... to be applied to term
119.3103 +value:
119.3104 + -> (rule : a rule rewriting to ...
119.3105 + * (term : ... the resulting term ...
119.3106 + * term list): ... with the assumptions ( //#0).
119.3107 + ) list : there may be several such rules;
119.3108 + the list is empty, if the rule has nothing to do
119.3109 + with cancelation.*)
119.3110 +(* val () = ();
119.3111 + *)
119.3112 +fun locate_rule thy eval_rls ro [rs] t r =
119.3113 + if (id_of_thm r) mem (map (id_of_thm)) rs
119.3114 + then let val ropt =
119.3115 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
119.3116 + in case ropt of
119.3117 + SOME ta => [(r, ta)]
119.3118 + | NONE => (writeln("### locate_rule: rewrite "^
119.3119 + (id_of_thm r)^" "^(term2str t)^" = NONE");
119.3120 + []) end
119.3121 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
119.3122 + | locate_rule _ _ _ _ _ _ =
119.3123 + raise error ("locate_rule: doesnt match rev-sets in istate");
119.3124 +
119.3125 +(*.next_rule = fn : rule list -> term -> rule option
119.3126 + for a given term return the next rules to be done for cancelling.
119.3127 +arguments:
119.3128 + rule list : the reverse rule list
119.3129 + term : the term for which ...
119.3130 +value:
119.3131 + -> rule option: ... this rule is appropriate for cancellation;
119.3132 + there may be no such rule (if the term is canceled already.*)
119.3133 +(* val thy = Rational.thy;
119.3134 + val Rrls {rew_ord=(_,ro),...} = cancel;
119.3135 + val ([rs],t) = (rss,f);
119.3136 + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
119.3137 +
119.3138 + val (thy, [rs]) = (Rational.thy, revsets);
119.3139 + val Rrls {rew_ord=(_,ro),...} = cancel;
119.3140 + nex [rs] t;
119.3141 + *)
119.3142 +fun next_rule thy eval_rls ro [rs] t =
119.3143 + let val der = make_deriv thy eval_rls rs ro NONE t;
119.3144 + in case der of
119.3145 +(* val (_,r,_)::_ = der;
119.3146 + *)
119.3147 + (_,r,_)::_ => SOME r
119.3148 + | _ => NONE
119.3149 + end
119.3150 + | next_rule _ _ _ _ _ =
119.3151 + raise error ("next_rule: doesnt match rev-sets in istate");
119.3152 +
119.3153 +(*.val attach_form = f : rule list -> term -> term
119.3154 + -> (rule * (term * term list)) list
119.3155 + checks an input term TI, if it may belong to a current cancellation, by
119.3156 + trying to derive it from the given term TG.
119.3157 +arguments:
119.3158 + term : TG, the last one in the cancellation agreed upon by user + math-eng
119.3159 + -> term: TI, the next one input by the user
119.3160 +value:
119.3161 + -> (rule : the rule to be applied in order to reach TI
119.3162 + * (term : ... obtained by applying the rule ...
119.3163 + * term list): ... and the respective assumptions.
119.3164 + ) list : there may be several such rules;
119.3165 + the list is empty, if the users term does not belong
119.3166 + to a cancellation of the term last agreed upon.*)
119.3167 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
119.3168 + []:(rule * (term * term list)) list;
119.3169 +
119.3170 +val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v";
119.3171 +val pat1 = (term_of o the o (parse thy)) "?r/?s+?u ";
119.3172 +val pat2 = (term_of o the o (parse thy)) "?r +?u/?v";
119.3173 +val prepat = [([HOLogic.true_const], pat0),
119.3174 + ([HOLogic.true_const], pat1),
119.3175 + ([HOLogic.true_const], pat2)];
119.3176 +
119.3177 +in
119.3178 +
119.3179 +(*11.02 schnelle L"osung f"ur RL: Bruch auch gek"urzt;
119.3180 + besser w"are: auf 1 gemeinsamen Bruchstrich, Nenner und Z"ahler unvereinfacht
119.3181 + dh. wie common_nominator_p_, aber auf 1 Bruchstrich*)
119.3182 +val common_nominator_p =
119.3183 + Rrls {id = "common_nominator_p", prepat=prepat,
119.3184 + rew_ord=("ord_make_polynomial",
119.3185 + ord_make_polynomial false Rational.thy),
119.3186 + erls = rational_erls,
119.3187 + calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
119.3188 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
119.3189 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
119.3190 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
119.3191 + scr=Rfuns {init_state = init_state thy Atools_erls ro,
119.3192 + normal_form = add_fraction_p_ thy,(*FIXME.WN0211*)
119.3193 + locate_rule = locate_rule thy Atools_erls ro,
119.3194 + next_rule = next_rule thy Atools_erls ro,
119.3195 + attach_form = attach_form}}
119.3196 +end;(*local*)
119.3197 +
119.3198 +
119.3199 +local(*.ad [2] 'common_nominator'
119.3200 +---------------------------------
119.3201 +FIXME Beschreibung .*)
119.3202 +
119.3203 +
119.3204 +val {rules=rules,rew_ord=(_,ro),...} =
119.3205 + rep_rls (assoc_rls "make_polynomial");
119.3206 +val thy = Rational.thy;
119.3207 +
119.3208 +
119.3209 +(*.common_nominator_ = fn : theory -> term -> (term * term list) option
119.3210 + as defined above*)
119.3211 +
119.3212 +(*.init_state = fn : term -> istate
119.3213 +initialzies the state of the interactive interpreter. The state is:
119.3214 +
119.3215 +type rrlsstate = (*state for reverse rewriting*)
119.3216 + (term * (*the current formula*)
119.3217 + term * (*the final term*)
119.3218 + rule list (*'reverse rule list' (#)*)
119.3219 + list * (*may be serveral, eg. in norm_rational*)
119.3220 + (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
119.3221 + (term * (*... rewrite with ...*)
119.3222 + term list)) (*... assumptions*)
119.3223 + list); (*derivation from given term to normalform
119.3224 + in reverse order with sym_thm;
119.3225 + (#) could be extracted from here by (map #1)*).*)
119.3226 +fun init_state thy eval_rls ro t =
119.3227 + let val SOME (t',_) = common_nominator_ thy t;
119.3228 + val SOME (t'',asm) = add_fraction_ thy t;
119.3229 + val der = reverse_deriv thy eval_rls rules ro NONE t';
119.3230 + val der = der @ [(Thm ("real_mult_div_cancel2",
119.3231 + num_str real_mult_div_cancel2),
119.3232 + (t'',asm))]
119.3233 + val rs = (distinct_Thm o (map #1)) der;
119.3234 + val rs = filter_out (eq_Thms ["sym_real_add_zero_left",
119.3235 + "sym_real_mult_0",
119.3236 + "sym_real_mult_1"]) rs;
119.3237 + in (t,t'',[rs(*here only _ONE_*)],der) end;
119.3238 +
119.3239 +(* use"knowledge/Rational.ML";
119.3240 + *)
119.3241 +
119.3242 +(*.locate_rule = fn : rule list -> term -> rule
119.3243 + -> (rule * (term * term list) option) list.
119.3244 + checks a rule R for being a cancel-rule, and if it is,
119.3245 + then return the list of rules (+ the terms they are rewriting to)
119.3246 + which need to be applied before R should be applied.
119.3247 + precondition: the rule is applicable to the argument-term.
119.3248 +arguments:
119.3249 + rule list: the reverse rule list
119.3250 + -> term : ... to which the rule shall be applied
119.3251 + -> rule : ... to be applied to term
119.3252 +value:
119.3253 + -> (rule : a rule rewriting to ...
119.3254 + * (term : ... the resulting term ...
119.3255 + * term list): ... with the assumptions ( //#0).
119.3256 + ) list : there may be several such rules;
119.3257 + the list is empty, if the rule has nothing to do
119.3258 + with cancelation.*)
119.3259 +(* val () = ();
119.3260 + *)
119.3261 +fun locate_rule thy eval_rls ro [rs] t r =
119.3262 + if (id_of_thm r) mem (map (id_of_thm)) rs
119.3263 + then let val ropt =
119.3264 + rewrite_ thy ro eval_rls true (thm_of_thm r) t;
119.3265 + in case ropt of
119.3266 + SOME ta => [(r, ta)]
119.3267 + | NONE => (writeln("### locate_rule: rewrite "^
119.3268 + (id_of_thm r)^" "^(term2str t)^" = NONE");
119.3269 + []) end
119.3270 + else (writeln("### locate_rule: "^(id_of_thm r)^" not mem rrls");[])
119.3271 + | locate_rule _ _ _ _ _ _ =
119.3272 + raise error ("locate_rule: doesnt match rev-sets in istate");
119.3273 +
119.3274 +(*.next_rule = fn : rule list -> term -> rule option
119.3275 + for a given term return the next rules to be done for cancelling.
119.3276 +arguments:
119.3277 + rule list : the reverse rule list
119.3278 + term : the term for which ...
119.3279 +value:
119.3280 + -> rule option: ... this rule is appropriate for cancellation;
119.3281 + there may be no such rule (if the term is canceled already.*)
119.3282 +(* val thy = Rational.thy;
119.3283 + val Rrls {rew_ord=(_,ro),...} = cancel;
119.3284 + val ([rs],t) = (rss,f);
119.3285 + next_rule thy eval_rls ro [rs] t;(*eval fun next_rule ... before!*)
119.3286 +
119.3287 + val (thy, [rs]) = (Rational.thy, revsets);
119.3288 + val Rrls {rew_ord=(_,ro),...} = cancel_p;
119.3289 + nex [rs] t;
119.3290 + *)
119.3291 +fun next_rule thy eval_rls ro [rs] t =
119.3292 + let val der = make_deriv thy eval_rls rs ro NONE t;
119.3293 + in case der of
119.3294 +(* val (_,r,_)::_ = der;
119.3295 + *)
119.3296 + (_,r,_)::_ => SOME r
119.3297 + | _ => NONE
119.3298 + end
119.3299 + | next_rule _ _ _ _ _ =
119.3300 + raise error ("next_rule: doesnt match rev-sets in istate");
119.3301 +
119.3302 +(*.val attach_form = f : rule list -> term -> term
119.3303 + -> (rule * (term * term list)) list
119.3304 + checks an input term TI, if it may belong to a current cancellation, by
119.3305 + trying to derive it from the given term TG.
119.3306 +arguments:
119.3307 + term : TG, the last one in the cancellation agreed upon by user + math-eng
119.3308 + -> term: TI, the next one input by the user
119.3309 +value:
119.3310 + -> (rule : the rule to be applied in order to reach TI
119.3311 + * (term : ... obtained by applying the rule ...
119.3312 + * term list): ... and the respective assumptions.
119.3313 + ) list : there may be several such rules;
119.3314 + the list is empty, if the users term does not belong
119.3315 + to a cancellation of the term last agreed upon.*)
119.3316 +fun attach_form (_:rule list list) (_:term) (_:term) = (*still missing*)
119.3317 + []:(rule * (term * term list)) list;
119.3318 +
119.3319 +val pat0 = (term_of o the o (parse thy)) "?r/?s+?u/?v";
119.3320 +val pat01 = (term_of o the o (parse thy)) "?r/?s-?u/?v";
119.3321 +val pat1 = (term_of o the o (parse thy)) "?r/?s+?u ";
119.3322 +val pat11 = (term_of o the o (parse thy)) "?r/?s-?u ";
119.3323 +val pat2 = (term_of o the o (parse thy)) "?r +?u/?v";
119.3324 +val pat21 = (term_of o the o (parse thy)) "?r -?u/?v";
119.3325 +val prepat = [([HOLogic.true_const], pat0),
119.3326 + ([HOLogic.true_const], pat01),
119.3327 + ([HOLogic.true_const], pat1),
119.3328 + ([HOLogic.true_const], pat11),
119.3329 + ([HOLogic.true_const], pat2),
119.3330 + ([HOLogic.true_const], pat21)];
119.3331 +
119.3332 +
119.3333 +in
119.3334 +
119.3335 +val common_nominator =
119.3336 + Rrls {id = "common_nominator", prepat=prepat,
119.3337 + rew_ord=("ord_make_polynomial",
119.3338 + ord_make_polynomial false Rational.thy),
119.3339 + erls = rational_erls,
119.3340 + calc = [("PLUS" ,("op +" ,eval_binop "#add_")),
119.3341 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
119.3342 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
119.3343 + ("POWER" ,("Atools.pow" ,eval_binop "#power_"))],
119.3344 + (*asm_thm=[("real_mult_div_cancel2","")],*)
119.3345 + scr=Rfuns {init_state = init_state thy Atools_erls ro,
119.3346 + normal_form = add_fraction_ (*NOT common_nominator_*) thy,
119.3347 + locate_rule = locate_rule thy Atools_erls ro,
119.3348 + next_rule = next_rule thy Atools_erls ro,
119.3349 + attach_form = attach_form}}
119.3350 +
119.3351 +end;(*local*)
119.3352 +
119.3353 +
119.3354 +(*##*)
119.3355 +end;(*struct*)
119.3356 +
119.3357 +open RationalI;
119.3358 +(*##*)
119.3359 +
119.3360 +(*.the expression contains + - * ^ / only ?.*)
119.3361 +fun is_ratpolyexp (Free _) = true
119.3362 + | is_ratpolyexp (Const ("op +",_) $ Free _ $ Free _) = true
119.3363 + | is_ratpolyexp (Const ("op -",_) $ Free _ $ Free _) = true
119.3364 + | is_ratpolyexp (Const ("op *",_) $ Free _ $ Free _) = true
119.3365 + | is_ratpolyexp (Const ("Atools.pow",_) $ Free _ $ Free _) = true
119.3366 + | is_ratpolyexp (Const ("HOL.divide",_) $ Free _ $ Free _) = true
119.3367 + | is_ratpolyexp (Const ("op +",_) $ t1 $ t2) =
119.3368 + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
119.3369 + | is_ratpolyexp (Const ("op -",_) $ t1 $ t2) =
119.3370 + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
119.3371 + | is_ratpolyexp (Const ("op *",_) $ t1 $ t2) =
119.3372 + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
119.3373 + | is_ratpolyexp (Const ("Atools.pow",_) $ t1 $ t2) =
119.3374 + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
119.3375 + | is_ratpolyexp (Const ("HOL.divide",_) $ t1 $ t2) =
119.3376 + ((is_ratpolyexp t1) andalso (is_ratpolyexp t2))
119.3377 + | is_ratpolyexp _ = false;
119.3378 +
119.3379 +(*("is_ratpolyexp", ("Rational.is'_ratpolyexp", eval_is_ratpolyexp ""))*)
119.3380 +fun eval_is_ratpolyexp (thmid:string) _
119.3381 + (t as (Const("Rational.is'_ratpolyexp", _) $ arg)) thy =
119.3382 + if is_ratpolyexp arg
119.3383 + then SOME (mk_thmid thmid ""
119.3384 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
119.3385 + Trueprop $ (mk_equality (t, HOLogic.true_const)))
119.3386 + else SOME (mk_thmid thmid ""
119.3387 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
119.3388 + Trueprop $ (mk_equality (t, HOLogic.false_const)))
119.3389 + | eval_is_ratpolyexp _ _ _ _ = NONE;
119.3390 +
119.3391 +
119.3392 +
119.3393 +(*-------------------18.3.03 --> struct <-----------vvv--*)
119.3394 +val add_fractions_p = common_nominator_p; (*FIXXXME:eilig f"ur norm_Rational*)
119.3395 +
119.3396 +(*.discard binary minus, shift unary minus into -1*;
119.3397 + unary minus before numerals are put into the numeral by parsing;
119.3398 + contains absolute minimum of thms for context in norm_Rational .*)
119.3399 +val discard_minus = prep_rls(
119.3400 + Rls {id = "discard_minus", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.3401 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
119.3402 + rules = [Thm ("real_diff_minus", num_str real_diff_minus),
119.3403 + (*"a - b = a + -1 * b"*)
119.3404 + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym))
119.3405 + (*- ?z = "-1 * ?z"*)
119.3406 + ],
119.3407 + scr = Script ((term_of o the o (parse thy))
119.3408 + "empty_script")
119.3409 + }):rls;
119.3410 +(*erls for calculate_Rational; make local with FIXX@ME result:term *term list*)
119.3411 +val powers_erls = prep_rls(
119.3412 + Rls {id = "powers_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.3413 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
119.3414 + rules = [Calc ("Atools.is'_atom",eval_is_atom "#is_atom_"),
119.3415 + Calc ("Atools.is'_even",eval_is_even "#is_even_"),
119.3416 + Calc ("op <",eval_equ "#less_"),
119.3417 + Thm ("not_false", not_false),
119.3418 + Thm ("not_true", not_true),
119.3419 + Calc ("op +",eval_binop "#add_")
119.3420 + ],
119.3421 + scr = Script ((term_of o the o (parse thy))
119.3422 + "empty_script")
119.3423 + }:rls);
119.3424 +(*.all powers over + distributed; atoms over * collected, other distributed
119.3425 + contains absolute minimum of thms for context in norm_Rational .*)
119.3426 +val powers = prep_rls(
119.3427 + Rls {id = "powers", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.3428 + erls = powers_erls, srls = Erls, calc = [], (*asm_thm = [],*)
119.3429 + rules = [Thm ("realpow_multI", num_str realpow_multI),
119.3430 + (*"(r * s) ^^^ n = r ^^^ n * s ^^^ n"*)
119.3431 + Thm ("realpow_pow",num_str realpow_pow),
119.3432 + (*"(a ^^^ b) ^^^ c = a ^^^ (b * c)"*)
119.3433 + Thm ("realpow_oneI",num_str realpow_oneI),
119.3434 + (*"r ^^^ 1 = r"*)
119.3435 + Thm ("realpow_minus_even",num_str realpow_minus_even),
119.3436 + (*"n is_even ==> (- r) ^^^ n = r ^^^ n" ?-->discard_minus?*)
119.3437 + Thm ("realpow_minus_odd",num_str realpow_minus_odd),
119.3438 + (*"Not (n is_even) ==> (- r) ^^^ n = -1 * r ^^^ n"*)
119.3439 +
119.3440 + (*----- collect atoms over * -----*)
119.3441 + Thm ("realpow_two_atom",num_str realpow_two_atom),
119.3442 + (*"r is_atom ==> r * r = r ^^^ 2"*)
119.3443 + Thm ("realpow_plus_1",num_str realpow_plus_1),
119.3444 + (*"r is_atom ==> r * r ^^^ n = r ^^^ (n + 1)"*)
119.3445 + Thm ("realpow_addI_atom",num_str realpow_addI_atom),
119.3446 + (*"r is_atom ==> r ^^^ n * r ^^^ m = r ^^^ (n + m)"*)
119.3447 +
119.3448 + (*----- distribute none-atoms -----*)
119.3449 + Thm ("realpow_def_atom",num_str realpow_def_atom),
119.3450 + (*"[| 1 < n; not(r is_atom) |]==>r ^^^ n = r * r ^^^ (n + -1)"*)
119.3451 + Thm ("realpow_eq_oneI",num_str realpow_eq_oneI),
119.3452 + (*"1 ^^^ n = 1"*)
119.3453 + Calc ("op +",eval_binop "#add_")
119.3454 + ],
119.3455 + scr = Script ((term_of o the o (parse thy))
119.3456 + "empty_script")
119.3457 + }:rls);
119.3458 +(*.contains absolute minimum of thms for context in norm_Rational.*)
119.3459 +val rat_mult_divide = prep_rls(
119.3460 + Rls {id = "rat_mult_divide", preconds = [],
119.3461 + rew_ord = ("dummy_ord",dummy_ord),
119.3462 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
119.3463 + rules = [Thm ("rat_mult",num_str rat_mult),
119.3464 + (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
119.3465 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
119.3466 + (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2],
119.3467 + otherwise inv.to a / b / c = ...*)
119.3468 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
119.3469 + (*"?a / ?b * ?c = ?a * ?c / ?b" order weights x^^^n too much
119.3470 + and does not commute a / b * c ^^^ 2 !*)
119.3471 +
119.3472 + Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
119.3473 + (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
119.3474 + Thm ("real_divide_divide2_eq", real_divide_divide2_eq),
119.3475 + (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
119.3476 + Calc ("HOL.divide" ,eval_cancel "#divide_")
119.3477 + ],
119.3478 + scr = Script ((term_of o the o (parse thy)) "empty_script")
119.3479 + }:rls);
119.3480 +(*.contains absolute minimum of thms for context in norm_Rational.*)
119.3481 +val reduce_0_1_2 = prep_rls(
119.3482 + Rls{id = "reduce_0_1_2", preconds = [], rew_ord = ("dummy_ord", dummy_ord),
119.3483 + erls = e_rls,srls = Erls,calc = [],(*asm_thm = [],*)
119.3484 + rules = [(*Thm ("real_divide_1",num_str real_divide_1),
119.3485 + "?x / 1 = ?x" unnecess.for normalform*)
119.3486 + Thm ("real_mult_1",num_str real_mult_1),
119.3487 + (*"1 * z = z"*)
119.3488 + (*Thm ("real_mult_minus1",num_str real_mult_minus1),
119.3489 + "-1 * z = - z"*)
119.3490 + (*Thm ("real_minus_mult_cancel",num_str real_minus_mult_cancel),
119.3491 + "- ?x * - ?y = ?x * ?y"*)
119.3492 +
119.3493 + Thm ("real_mult_0",num_str real_mult_0),
119.3494 + (*"0 * z = 0"*)
119.3495 + Thm ("real_add_zero_left",num_str real_add_zero_left),
119.3496 + (*"0 + z = z"*)
119.3497 + (*Thm ("real_add_minus",num_str real_add_minus),
119.3498 + "?z + - ?z = 0"*)
119.3499 +
119.3500 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
119.3501 + (*"z1 + z1 = 2 * z1"*)
119.3502 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
119.3503 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
119.3504 +
119.3505 + Thm ("real_0_divide",num_str real_0_divide)
119.3506 + (*"0 / ?x = 0"*)
119.3507 + ], scr = EmptyScr}:rls);
119.3508 +
119.3509 +(*erls for calculate_Rational;
119.3510 + make local with FIXX@ME result:term *term list WN0609???SKMG*)
119.3511 +val norm_rat_erls = prep_rls(
119.3512 + Rls {id = "norm_rat_erls", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.3513 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
119.3514 + rules = [Calc ("Atools.is'_const",eval_const "#is_const_")
119.3515 + ],
119.3516 + scr = Script ((term_of o the o (parse thy))
119.3517 + "empty_script")
119.3518 + }:rls);
119.3519 +(*.consists of rls containing the absolute minimum of thms.*)
119.3520 +(*040209: this version has been used by RL for his equations,
119.3521 +which is now replaced by MGs version below
119.3522 +vvv OLD VERSION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)
119.3523 +val norm_Rational = prep_rls(
119.3524 + Rls {id = "norm_Rational", preconds = [], rew_ord = ("dummy_ord",dummy_ord),
119.3525 + erls = norm_rat_erls, srls = Erls, calc = [], (*asm_thm = [],*)
119.3526 + rules = [(*sequence given by operator precedence*)
119.3527 + Rls_ discard_minus,
119.3528 + Rls_ powers,
119.3529 + Rls_ rat_mult_divide,
119.3530 + Rls_ expand,
119.3531 + Rls_ reduce_0_1_2,
119.3532 + (*^^^^^^^^^ from RL -- not the latest one vvvvvvvvv*)
119.3533 + Rls_ order_add_mult,
119.3534 + Rls_ collect_numerals,
119.3535 + Rls_ add_fractions_p,
119.3536 + Rls_ cancel_p
119.3537 + ],
119.3538 + scr = Script ((term_of o the o (parse thy))
119.3539 + "empty_script")
119.3540 + }:rls);
119.3541 +val norm_Rational_parenthesized = prep_rls(
119.3542 + Seq {id = "norm_Rational_parenthesized", preconds = []:term list,
119.3543 + rew_ord = ("dummy_ord", dummy_ord),
119.3544 + erls = Atools_erls, srls = Erls,
119.3545 + calc = [], (*asm_thm = [],*)
119.3546 + rules = [Rls_ norm_Rational, (*from RL -- not the latest one*)
119.3547 + Rls_ discard_parentheses
119.3548 + ],
119.3549 + scr = EmptyScr
119.3550 + }:rls);
119.3551 +
119.3552 +
119.3553 +(*-------------------18.3.03 --> struct <-----------^^^--*)
119.3554 +
119.3555 +
119.3556 +
119.3557 +theory' := overwritel (!theory', [("Rational.thy",Rational.thy)]);
119.3558 +
119.3559 +
119.3560 +(*WN030318???SK: simplifies all but cancel and common_nominator*)
119.3561 +val simplify_rational =
119.3562 + merge_rls "simplify_rational" expand_binoms
119.3563 + (append_rls "divide" calculate_Rational
119.3564 + [Thm ("real_divide_1",num_str real_divide_1),
119.3565 + (*"?x / 1 = ?x"*)
119.3566 + Thm ("rat_mult",num_str rat_mult),
119.3567 + (*(1)"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
119.3568 + Thm ("real_times_divide1_eq",num_str real_times_divide1_eq),
119.3569 + (*(2)"?a * (?c / ?d) = ?a * ?c / ?d" must be [2],
119.3570 + otherwise inv.to a / b / c = ...*)
119.3571 + Thm ("real_times_divide2_eq",num_str real_times_divide2_eq),
119.3572 + (*"?a / ?b * ?c = ?a * ?c / ?b"*)
119.3573 + Thm ("add_minus",num_str add_minus),
119.3574 + (*"?a + ?b - ?b = ?a"*)
119.3575 + Thm ("add_minus1",num_str add_minus1),
119.3576 + (*"?a - ?b + ?b = ?a"*)
119.3577 + Thm ("real_divide_minus1",num_str real_divide_minus1)
119.3578 + (*"?x / -1 = - ?x"*)
119.3579 +(*
119.3580 +,
119.3581 + Thm ("",num_str )
119.3582 +*)
119.3583 + ]);
119.3584 +
119.3585 +(*---------vvv-------------MG ab 1.07.2003--------------vvv-----------*)
119.3586 +
119.3587 +(* ------------------------------------------------------------------ *)
119.3588 +(* Simplifier für beliebige Buchterme *)
119.3589 +(* ------------------------------------------------------------------ *)
119.3590 +(*----------------------- norm_Rational_mg ---------------------------*)
119.3591 +(*. description of the simplifier see MG-DA.p.56ff .*)
119.3592 +(* ------------------------------------------------------------------- *)
119.3593 +val common_nominator_p_rls = prep_rls(
119.3594 + Rls {id = "common_nominator_p_rls", preconds = [],
119.3595 + rew_ord = ("dummy_ord",dummy_ord),
119.3596 + erls = e_rls, srls = Erls, calc = [],
119.3597 + rules =
119.3598 + [Rls_ common_nominator_p
119.3599 + (*FIXME.WN0401 ? redesign Rrls - use exhaustively on a term ?
119.3600 + FIXME.WN0510 unnecessary nesting: introduce RRls_ : rls -> rule*)
119.3601 + ],
119.3602 + scr = EmptyScr});
119.3603 +(* ------------------------------------------------------------------- *)
119.3604 +val cancel_p_rls = prep_rls(
119.3605 + Rls {id = "cancel_p_rls", preconds = [],
119.3606 + rew_ord = ("dummy_ord",dummy_ord),
119.3607 + erls = e_rls, srls = Erls, calc = [],
119.3608 + rules =
119.3609 + [Rls_ cancel_p
119.3610 + (*FIXME.WN.0401 ? redesign Rrls - use exhaustively on a term ?*)
119.3611 + ],
119.3612 + scr = EmptyScr});
119.3613 +(* -------------------------------------------------------------------- *)
119.3614 +(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions;
119.3615 + used in initial part norm_Rational_mg, see example DA-M02-main.p.60.*)
119.3616 +val rat_mult_poly = prep_rls(
119.3617 + Rls {id = "rat_mult_poly", preconds = [],
119.3618 + rew_ord = ("dummy_ord",dummy_ord),
119.3619 + erls = append_rls "e_rls-is_polyexp" e_rls
119.3620 + [Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
119.3621 + srls = Erls, calc = [],
119.3622 + rules =
119.3623 + [Thm ("rat_mult_poly_l",num_str rat_mult_poly_l),
119.3624 + (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*)
119.3625 + Thm ("rat_mult_poly_r",num_str rat_mult_poly_r)
119.3626 + (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*)
119.3627 + ],
119.3628 + scr = EmptyScr});
119.3629 +(* ------------------------------------------------------------------ *)
119.3630 +(*. makes 'normal' fractions; 'is_polyexp' inhibits double fractions;
119.3631 + used in looping part norm_Rational_rls, see example DA-M02-main.p.60
119.3632 + .. WHERE THE LATTER DOES ALWAYS WORK, BECAUSE erls = e_rls,
119.3633 + I.E. THE RESPECTIVE ASSUMPTION IS STORED AND Thm APPLIED; WN051028
119.3634 + ... WN0609???MG.*)
119.3635 +val rat_mult_div_pow = prep_rls(
119.3636 + Rls {id = "rat_mult_div_pow", preconds = [],
119.3637 + rew_ord = ("dummy_ord",dummy_ord),
119.3638 + erls = e_rls,
119.3639 + (*FIXME.WN051028 append_rls "e_rls-is_polyexp" e_rls
119.3640 + [Calc ("Poly.is'_polyexp", eval_is_polyexp "")],
119.3641 + with this correction ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ we get
119.3642 + error "rational.sml.sml: diff.behav. in norm_Rational_mg 29" etc.
119.3643 + thus we decided to go on with this flaw*)
119.3644 + srls = Erls, calc = [],
119.3645 + rules = [Thm ("rat_mult",num_str rat_mult),
119.3646 + (*"?a / ?b * (?c / ?d) = ?a * ?c / (?b * ?d)"*)
119.3647 + Thm ("rat_mult_poly_l",num_str rat_mult_poly_l),
119.3648 + (*"?c is_polyexp ==> ?c * (?a / ?b) = ?c * ?a / ?b"*)
119.3649 + Thm ("rat_mult_poly_r",num_str rat_mult_poly_r),
119.3650 + (*"?c is_polyexp ==> ?a / ?b * ?c = ?a * ?c / ?b"*)
119.3651 +
119.3652 + Thm ("real_divide_divide1_mg", real_divide_divide1_mg),
119.3653 + (*"y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"*)
119.3654 + Thm ("real_divide_divide1_eq", real_divide_divide1_eq),
119.3655 + (*"?x / (?y / ?z) = ?x * ?z / ?y"*)
119.3656 + Thm ("real_divide_divide2_eq", real_divide_divide2_eq),
119.3657 + (*"?x / ?y / ?z = ?x / (?y * ?z)"*)
119.3658 + Calc ("HOL.divide" ,eval_cancel "#divide_"),
119.3659 +
119.3660 + Thm ("rat_power", num_str rat_power)
119.3661 + (*"(?a / ?b) ^^^ ?n = ?a ^^^ ?n / ?b ^^^ ?n"*)
119.3662 + ],
119.3663 + scr = Script ((term_of o the o (parse thy)) "empty_script")
119.3664 + }:rls);
119.3665 +(* ------------------------------------------------------------------ *)
119.3666 +val rat_reduce_1 = prep_rls(
119.3667 + Rls {id = "rat_reduce_1", preconds = [],
119.3668 + rew_ord = ("dummy_ord",dummy_ord),
119.3669 + erls = e_rls, srls = Erls, calc = [],
119.3670 + rules = [Thm ("real_divide_1",num_str real_divide_1),
119.3671 + (*"?x / 1 = ?x"*)
119.3672 + Thm ("real_mult_1",num_str real_mult_1)
119.3673 + (*"1 * z = z"*)
119.3674 + ],
119.3675 + scr = Script ((term_of o the o (parse thy)) "empty_script")
119.3676 + }:rls);
119.3677 +(* ------------------------------------------------------------------ *)
119.3678 +(*. looping part of norm_Rational(*_mg*) .*)
119.3679 +val norm_Rational_rls = prep_rls(
119.3680 + Rls {id = "norm_Rational_rls", preconds = [],
119.3681 + rew_ord = ("dummy_ord",dummy_ord),
119.3682 + erls = norm_rat_erls, srls = Erls, calc = [],
119.3683 + rules = [Rls_ common_nominator_p_rls,
119.3684 + Rls_ rat_mult_div_pow,
119.3685 + Rls_ make_rat_poly_with_parentheses,
119.3686 + Rls_ cancel_p_rls,(*FIXME:cancel_p does NOT order sometimes*)
119.3687 + Rls_ rat_reduce_1
119.3688 + ],
119.3689 + scr = Script ((term_of o the o (parse thy)) "empty_script")
119.3690 + }:rls);
119.3691 +(* ------------------------------------------------------------------ *)
119.3692 +(*040109 'norm_Rational'(by RL) replaced by 'norm_Rational_mg'(MG)
119.3693 + just be renaming:*)
119.3694 +val norm_Rational(*_mg*) = prep_rls(
119.3695 + Seq {id = "norm_Rational"(*_mg*), preconds = [],
119.3696 + rew_ord = ("dummy_ord",dummy_ord),
119.3697 + erls = norm_rat_erls, srls = Erls, calc = [],
119.3698 + rules = [Rls_ discard_minus_,
119.3699 + Rls_ rat_mult_poly,(* removes double fractions like a/b/c *)
119.3700 + Rls_ make_rat_poly_with_parentheses, (*WN0510 also in(#)below*)
119.3701 + Rls_ cancel_p_rls, (*FIXME.MG:cancel_p does NOT order sometim*)
119.3702 + Rls_ norm_Rational_rls, (* the main rls, looping (#) *)
119.3703 + Rls_ discard_parentheses_ (* mult only *)
119.3704 + ],
119.3705 + scr = Script ((term_of o the o (parse thy)) "empty_script")
119.3706 + }:rls);
119.3707 +(* ------------------------------------------------------------------ *)
119.3708 +
119.3709 +
119.3710 +ruleset' := overwritelthy thy (!ruleset',
119.3711 + [("calculate_Rational", calculate_Rational),
119.3712 + ("calc_rat_erls",calc_rat_erls),
119.3713 + ("rational_erls", rational_erls),
119.3714 + ("cancel_p", cancel_p),
119.3715 + ("cancel", cancel),
119.3716 + ("common_nominator_p", common_nominator_p),
119.3717 + ("common_nominator_p_rls", common_nominator_p_rls),
119.3718 + ("common_nominator" , common_nominator),
119.3719 + ("discard_minus", discard_minus),
119.3720 + ("powers_erls", powers_erls),
119.3721 + ("powers", powers),
119.3722 + ("rat_mult_divide", rat_mult_divide),
119.3723 + ("reduce_0_1_2", reduce_0_1_2),
119.3724 + ("rat_reduce_1", rat_reduce_1),
119.3725 + ("norm_rat_erls", norm_rat_erls),
119.3726 + ("norm_Rational", norm_Rational),
119.3727 + ("norm_Rational_rls", norm_Rational_rls),
119.3728 + ("norm_Rational_parenthesized", norm_Rational_parenthesized),
119.3729 + ("rat_mult_poly", rat_mult_poly),
119.3730 + ("rat_mult_div_pow", rat_mult_div_pow),
119.3731 + ("cancel_p_rls", cancel_p_rls)
119.3732 + ]);
119.3733 +
119.3734 +calclist':= overwritel (!calclist',
119.3735 + [("is_expanded", ("Rational.is'_expanded", eval_is_expanded ""))
119.3736 + ]);
119.3737 +
119.3738 +(** problems **)
119.3739 +
119.3740 +store_pbt
119.3741 + (prep_pbt Rational.thy "pbl_simp_rat" [] e_pblID
119.3742 + (["rational","simplification"],
119.3743 + [("#Given" ,["term t_"]),
119.3744 + ("#Where" ,["t_ is_ratpolyexp"]),
119.3745 + ("#Find" ,["normalform n_"])
119.3746 + ],
119.3747 + append_rls "e_rls" e_rls [(*for preds in where_*)],
119.3748 + SOME "Simplify t_",
119.3749 + [["simplification","of_rationals"]]));
119.3750 +
119.3751 +(** methods **)
119.3752 +
119.3753 +(*WN061025 this methods script is copied from (auto-generated) script
119.3754 + of norm_Rational in order to ease repair on inform*)
119.3755 +store_met
119.3756 + (prep_met Rational.thy "met_simp_rat" [] e_metID
119.3757 + (["simplification","of_rationals"],
119.3758 + [("#Given" ,["term t_"]),
119.3759 + ("#Where" ,["t_ is_ratpolyexp"]),
119.3760 + ("#Find" ,["normalform n_"])
119.3761 + ],
119.3762 + {rew_ord'="tless_true",
119.3763 + rls' = e_rls,
119.3764 + calc = [], srls = e_rls,
119.3765 + prls = append_rls "simplification_of_rationals_prls" e_rls
119.3766 + [(*for preds in where_*)
119.3767 + Calc ("Rational.is'_ratpolyexp",
119.3768 + eval_is_ratpolyexp "")],
119.3769 + crls = e_rls, nrls = norm_Rational_rls},
119.3770 +"Script SimplifyScript (t_::real) = \
119.3771 +\ ((Try (Rewrite_Set discard_minus_ False) @@ \
119.3772 +\ Try (Rewrite_Set rat_mult_poly False) @@ \
119.3773 +\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@ \
119.3774 +\ Try (Rewrite_Set cancel_p_rls False) @@ \
119.3775 +\ (Repeat \
119.3776 +\ ((Try (Rewrite_Set common_nominator_p_rls False) @@ \
119.3777 +\ Try (Rewrite_Set rat_mult_div_pow False) @@ \
119.3778 +\ Try (Rewrite_Set make_rat_poly_with_parentheses False) @@\
119.3779 +\ Try (Rewrite_Set cancel_p_rls False) @@ \
119.3780 +\ Try (Rewrite_Set rat_reduce_1 False)))) @@ \
119.3781 +\ Try (Rewrite_Set discard_parentheses_ False)) \
119.3782 +\ t_)"
119.3783 + ));
119.3784 +
119.3785 +(* use"../Knowledge/Rational.ML";
119.3786 + use"Knowledge/Rational.ML";
119.3787 + use"Rational.ML";
119.3788 + *)
119.3789 +
120.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
120.2 +++ b/src/Tools/isac/Knowledge/Rational.thy Wed Aug 25 16:20:07 2010 +0200
120.3 @@ -0,0 +1,76 @@
120.4 +(* rationals, i.e. fractions of multivariate polynomials over the real field
120.5 + author: isac team
120.6 + Copyright (c) isac team 2002
120.7 + Use is subject to license terms.
120.8 +
120.9 + depends on Poly (and not on Atools), because
120.10 + fractions with _normalized_ polynomials are canceled, added, etc.
120.11 +
120.12 + use_thy_only"Knowledge/Rational";
120.13 + use_thy"../Knowledge/Rational";
120.14 + use_thy"Knowledge/Rational";
120.15 +
120.16 + remove_thy"Rational";
120.17 + use_thy"Knowledge/Isac";
120.18 + use_thy_only"Knowledge/Rational";
120.19 +
120.20 +*)
120.21 +
120.22 +Rational = Poly +
120.23 +
120.24 +consts
120.25 +
120.26 + is'_expanded :: "real => bool" ("_ is'_expanded") (*RL->Poly.thy*)
120.27 + is'_ratpolyexp :: "real => bool" ("_ is'_ratpolyexp")
120.28 +
120.29 +rules (*.not contained in Isabelle2002,
120.30 + stated as axioms, TODO: prove as theorems*)
120.31 +
120.32 + mult_cross "[| b ~= 0; d ~= 0 |] ==> (a / b = c / d) = (a * d = b * c)"
120.33 + mult_cross1 " b ~= 0 ==> (a / b = c ) = (a = b * c)"
120.34 + mult_cross2 " d ~= 0 ==> (a = c / d) = (a * d = c)"
120.35 +
120.36 + add_minus "a + b - b = a"(*RL->Poly.thy*)
120.37 + add_minus1 "a - b + b = a"(*RL->Poly.thy*)
120.38 +
120.39 + rat_mult "a / b * (c / d) = a * c / (b * d)"(*?Isa02*)
120.40 + rat_mult2 "a / b * c = a * c / b "(*?Isa02*)
120.41 +
120.42 + rat_mult_poly_l "c is_polyexp ==> c * (a / b) = c * a / b"
120.43 + rat_mult_poly_r "c is_polyexp ==> (a / b) * c = a * c / b"
120.44 +
120.45 +(*real_times_divide1_eq .. Isa02*)
120.46 + real_times_divide_1_eq "-1 * (c / d) =-1 * c / d "
120.47 + real_times_divide_num "a is_const ==> \
120.48 + \a * (c / d) = a * c / d "
120.49 +
120.50 + real_mult_div_cancel2 "k ~= 0 ==> m * k / (n * k) = m / n"
120.51 +(*real_mult_div_cancel1 "k ~= 0 ==> k * m / (k * n) = m / n"..Isa02*)
120.52 +
120.53 + real_divide_divide1 "y ~= 0 ==> (u / v) / (y / z) = (u / v) * (z / y)"
120.54 + real_divide_divide1_mg "y ~= 0 ==> (u / v) / (y / z) = (u * z) / (y * v)"
120.55 +(*real_divide_divide2_eq "x / y / z = x / (y * z)"..Isa02*)
120.56 +
120.57 + rat_power "(a / b)^^^n = (a^^^n) / (b^^^n)"
120.58 +
120.59 +
120.60 + rat_add "[| a is_const; b is_const; c is_const; d is_const |] ==> \
120.61 + \a / c + b / d = (a * d + b * c) / (c * d)"
120.62 + rat_add_assoc "[| a is_const; b is_const; c is_const; d is_const |] ==> \
120.63 + \a / c +(b / d + e) = (a * d + b * c)/(d * c) + e"
120.64 + rat_add1 "[| a is_const; b is_const; c is_const |] ==> \
120.65 + \a / c + b / c = (a + b) / c"
120.66 + rat_add1_assoc "[| a is_const; b is_const; c is_const |] ==> \
120.67 + \a / c + (b / c + e) = (a + b) / c + e"
120.68 + rat_add2 "[| a is_const; b is_const; c is_const |] ==> \
120.69 + \a / c + b = (a + b * c) / c"
120.70 + rat_add2_assoc "[| a is_const; b is_const; c is_const |] ==> \
120.71 + \a / c + (b + e) = (a + b * c) / c + e"
120.72 + rat_add3 "[| a is_const; b is_const; c is_const |] ==> \
120.73 + \a + b / c = (a * c + b) / c"
120.74 + rat_add3_assoc "[| a is_const; b is_const; c is_const |] ==> \
120.75 + \a + (b / c + e) = (a * c + b) / c + e"
120.76 +
120.77 +
120.78 +
120.79 +end
121.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
121.2 +++ b/src/Tools/isac/Knowledge/Root.ML Wed Aug 25 16:20:07 2010 +0200
121.3 @@ -0,0 +1,299 @@
121.4 +(* collecting all knowledge for Root
121.5 + created by:
121.6 + date:
121.7 + changed by: rlang
121.8 + last change by: rlang
121.9 + date: 02.10.24
121.10 +*)
121.11 +
121.12 +(* use"../knowledge/Root.ML";
121.13 + use"Knowledge/Root.ML";
121.14 + use"Root.ML";
121.15 +
121.16 + remove_thy"Root";
121.17 + use_thy"Knowledge/Isac";
121.18 +
121.19 + use"ROOT.ML";
121.20 + cd"knowledge";
121.21 + *)
121.22 +"******* Root.ML begin *******";
121.23 +theory' := overwritel (!theory', [("Root.thy",Root.thy)]);
121.24 +(*-------------------------functions---------------------*)
121.25 +(*evaluation square-root over the integers*)
121.26 +fun eval_sqrt (thmid:string) (op_:string) (t as
121.27 + (Const(op0,t0) $ arg)) thy =
121.28 + (case arg of
121.29 + Free (n1,t1) =>
121.30 + (case int_of_str n1 of
121.31 + SOME ni =>
121.32 + if ni < 0 then NONE
121.33 + else
121.34 + let val fact = squfact ni;
121.35 + in if fact*fact = ni
121.36 + then SOME ("#sqrt #"^(string_of_int ni)^" = #"
121.37 + ^(string_of_int (if ni = 0 then 0
121.38 + else ni div fact)),
121.39 + Trueprop $ mk_equality (t, term_of_num t1 fact))
121.40 + else if fact = 1 then NONE
121.41 + else SOME ("#sqrt #"^(string_of_int ni)^" = sqrt (#"
121.42 + ^(string_of_int fact)^" * #"
121.43 + ^(string_of_int fact)^" * #"
121.44 + ^(string_of_int (ni div (fact*fact))^")"),
121.45 + Trueprop $
121.46 + (mk_equality
121.47 + (t,
121.48 + (mk_factroot op0 t1 fact
121.49 + (ni div (fact*fact))))))
121.50 + end
121.51 + | NONE => NONE)
121.52 + | _ => NONE)
121.53 +
121.54 + | eval_sqrt _ _ _ _ = NONE;
121.55 +(*val (thmid, op_, t as Const(op0,t0) $ arg) = ("","", str2term "sqrt 0");
121.56 +> eval_sqrt thmid op_ t thy;
121.57 +> val Free (n1,t1) = arg;
121.58 +> val SOME ni = int_of_str n1;
121.59 +*)
121.60 +
121.61 +calclist':= overwritel (!calclist',
121.62 + [("SQRT" ,("Root.sqrt" ,eval_sqrt "#sqrt_"))
121.63 + (*different types for 'sqrt 4' --- 'Calculate sqrt_'*)
121.64 + ]);
121.65 +
121.66 +
121.67 +local (* Vers. 7.10.99.A *)
121.68 +
121.69 +open Term; (* for type order = EQUAL | LESS | GREATER *)
121.70 +
121.71 +fun pr_ord EQUAL = "EQUAL"
121.72 + | pr_ord LESS = "LESS"
121.73 + | pr_ord GREATER = "GREATER";
121.74 +
121.75 +fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
121.76 + (case a of "Root.sqrt" => ((("|||", 0), T), 0) (*WN greatest *)
121.77 + | _ => (((a, 0), T), 0))
121.78 + | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
121.79 + | dest_hd' (Var v) = (v, 2)
121.80 + | dest_hd' (Bound i) = ((("", i), dummyT), 3)
121.81 + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
121.82 +fun size_of_term' (Const(str,_) $ t) =
121.83 + (case str of "Root.sqrt" => (1000 + size_of_term' t)
121.84 + | _ => 1 + size_of_term' t)
121.85 + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
121.86 + | size_of_term' (f $ t) = size_of_term' f + size_of_term' t
121.87 + | size_of_term' _ = 1;
121.88 +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
121.89 + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
121.90 + | term_ord' pr thy (t, u) =
121.91 + (if pr then
121.92 + let
121.93 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
121.94 + val _=writeln("t= f@ts= \""^
121.95 + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
121.96 + (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\"");
121.97 + val _=writeln("u= g@us= \""^
121.98 + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
121.99 + (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\"");
121.100 + val _=writeln("size_of_term(t,u)= ("^
121.101 + (string_of_int(size_of_term' t))^", "^
121.102 + (string_of_int(size_of_term' u))^")");
121.103 + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
121.104 + val _=writeln("terms_ord(ts,us) = "^
121.105 + ((pr_ord o terms_ord str false)(ts,us)));
121.106 + val _=writeln("-------");
121.107 + in () end
121.108 + else ();
121.109 + case int_ord (size_of_term' t, size_of_term' u) of
121.110 + EQUAL =>
121.111 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
121.112 + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
121.113 + | ord => ord)
121.114 + end
121.115 + | ord => ord)
121.116 +and hd_ord (f, g) = (* ~ term.ML *)
121.117 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
121.118 +and terms_ord str pr (ts, us) =
121.119 + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
121.120 +
121.121 +in
121.122 +(* associates a+(b+c) => (a+b)+c = a+b+c ... avoiding parentheses
121.123 + by (1) size_of_term: less(!) to right, size_of 'sqrt (...)' = 1
121.124 + (2) hd_ord: greater to right, 'sqrt' < numerals < variables
121.125 + (3) terms_ord: recurs. on args, greater to right
121.126 +*)
121.127 +
121.128 +(*args
121.129 + pr: print trace, WN0509 'sqrt_right true' not used anymore
121.130 + thy:
121.131 + subst: no bound variables, only Root.sqrt
121.132 + tu: the terms to compare (t1, t2) ... *)
121.133 +fun sqrt_right (pr:bool) thy (_:subst) tu =
121.134 + (term_ord' pr thy(***) tu = LESS );
121.135 +end;
121.136 +
121.137 +rew_ord' := overwritel (!rew_ord',
121.138 +[("termlessI", termlessI),
121.139 + ("sqrt_right", sqrt_right false (theory "Pure"))
121.140 + ]);
121.141 +
121.142 +(*-------------------------rulse-------------------------*)
121.143 +val Root_crls =
121.144 + append_rls "Root_crls" Atools_erls
121.145 + [Thm ("real_unari_minus",num_str real_unari_minus),
121.146 + Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"),
121.147 + Calc ("HOL.divide",eval_cancel "#divide_"),
121.148 + Calc ("Atools.pow" ,eval_binop "#power_"),
121.149 + Calc ("op +", eval_binop "#add_"),
121.150 + Calc ("op -", eval_binop "#sub_"),
121.151 + Calc ("op *", eval_binop "#mult_"),
121.152 + Calc ("op =",eval_equal "#equal_")
121.153 + ];
121.154 +
121.155 +val Root_erls =
121.156 + append_rls "Root_erls" Atools_erls
121.157 + [Thm ("real_unari_minus",num_str real_unari_minus),
121.158 + Calc ("Root.sqrt" ,eval_sqrt "#sqrt_"),
121.159 + Calc ("HOL.divide",eval_cancel "#divide_"),
121.160 + Calc ("Atools.pow" ,eval_binop "#power_"),
121.161 + Calc ("op +", eval_binop "#add_"),
121.162 + Calc ("op -", eval_binop "#sub_"),
121.163 + Calc ("op *", eval_binop "#mult_"),
121.164 + Calc ("op =",eval_equal "#equal_")
121.165 + ];
121.166 +
121.167 +ruleset' := overwritelthy thy (!ruleset',
121.168 + [("Root_erls",Root_erls) (*FIXXXME:del with rls.rls'*)
121.169 + ]);
121.170 +
121.171 +val make_rooteq = prep_rls(
121.172 + Rls{id = "make_rooteq", preconds = []:term list,
121.173 + rew_ord = ("sqrt_right", sqrt_right false Root.thy),
121.174 + erls = Atools_erls, srls = Erls,
121.175 + calc = [],
121.176 + (*asm_thm = [],*)
121.177 + rules = [Thm ("real_diff_minus",num_str real_diff_minus),
121.178 + (*"a - b = a + (-1) * b"*)
121.179 +
121.180 + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
121.181 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
121.182 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
121.183 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
121.184 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
121.185 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
121.186 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
121.187 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
121.188 +
121.189 + Thm ("real_mult_1",num_str real_mult_1),
121.190 + (*"1 * z = z"*)
121.191 + Thm ("real_mult_0",num_str real_mult_0),
121.192 + (*"0 * z = 0"*)
121.193 + Thm ("real_add_zero_left",num_str real_add_zero_left),
121.194 + (*"0 + z = z"*)
121.195 +
121.196 + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
121.197 + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
121.198 + Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
121.199 + Thm ("real_add_commute",num_str real_add_commute), (**)
121.200 + Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
121.201 + Thm ("real_add_assoc",num_str real_add_assoc), (**)
121.202 +
121.203 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
121.204 + (*"r1 * r1 = r1 ^^^ 2"*)
121.205 + Thm ("realpow_plus_1",num_str realpow_plus_1),
121.206 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
121.207 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
121.208 + (*"z1 + z1 = 2 * z1"*)
121.209 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
121.210 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
121.211 +
121.212 + Thm ("real_num_collect",num_str real_num_collect),
121.213 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
121.214 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
121.215 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
121.216 + Thm ("real_one_collect",num_str real_one_collect),
121.217 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
121.218 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
121.219 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
121.220 +
121.221 + Calc ("op +", eval_binop "#add_"),
121.222 + Calc ("op *", eval_binop "#mult_"),
121.223 + Calc ("Atools.pow", eval_binop "#power_")
121.224 + ],
121.225 + scr = Script ((term_of o the o (parse thy)) "empty_script")
121.226 + }:rls);
121.227 +ruleset' := overwritelthy thy (!ruleset',
121.228 + [("make_rooteq", make_rooteq)
121.229 + ]);
121.230 +
121.231 +val expand_rootbinoms = prep_rls(
121.232 + Rls{id = "expand_rootbinoms", preconds = [],
121.233 + rew_ord = ("termlessI",termlessI),
121.234 + erls = Atools_erls, srls = Erls,
121.235 + calc = [],
121.236 + (*asm_thm = [],*)
121.237 + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
121.238 + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
121.239 + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
121.240 + (*"(a + b)*(a + b) = ...*)
121.241 + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
121.242 + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
121.243 + Thm ("real_minus_binom_times",num_str real_minus_binom_times),
121.244 + (*"(a - b)*(a - b) = ...*)
121.245 + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
121.246 + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
121.247 + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
121.248 + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
121.249 + (*RL 020915*)
121.250 + Thm ("real_pp_binom_times",num_str real_pp_binom_times),
121.251 + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
121.252 + Thm ("real_pm_binom_times",num_str real_pm_binom_times),
121.253 + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
121.254 + Thm ("real_mp_binom_times",num_str real_mp_binom_times),
121.255 + (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
121.256 + Thm ("real_mm_binom_times",num_str real_mm_binom_times),
121.257 + (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
121.258 + Thm ("realpow_mul",num_str realpow_mul),
121.259 + (*(a*b)^^^n = a^^^n * b^^^n*)
121.260 +
121.261 + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
121.262 + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
121.263 + Thm ("real_add_zero_left",num_str real_add_zero_left), (*"0 + z = z"*)
121.264 +
121.265 + Calc ("op +", eval_binop "#add_"),
121.266 + Calc ("op -", eval_binop "#sub_"),
121.267 + Calc ("op *", eval_binop "#mult_"),
121.268 + Calc ("HOL.divide" ,eval_cancel "#divide_"),
121.269 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
121.270 + Calc ("Atools.pow", eval_binop "#power_"),
121.271 +
121.272 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
121.273 + (*"r1 * r1 = r1 ^^^ 2"*)
121.274 + Thm ("realpow_plus_1",num_str realpow_plus_1),
121.275 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
121.276 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
121.277 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
121.278 +
121.279 + Thm ("real_num_collect",num_str real_num_collect),
121.280 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
121.281 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
121.282 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
121.283 + Thm ("real_one_collect",num_str real_one_collect),
121.284 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
121.285 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
121.286 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
121.287 +
121.288 + Calc ("op +", eval_binop "#add_"),
121.289 + Calc ("op -", eval_binop "#sub_"),
121.290 + Calc ("op *", eval_binop "#mult_"),
121.291 + Calc ("HOL.divide" ,eval_cancel "#divide_"),
121.292 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
121.293 + Calc ("Atools.pow", eval_binop "#power_")
121.294 + ],
121.295 + scr = Script ((term_of o the o (parse thy)) "empty_script")
121.296 + }:rls);
121.297 +
121.298 +
121.299 +ruleset' := overwritelthy thy (!ruleset',
121.300 + [("expand_rootbinoms", expand_rootbinoms)
121.301 + ]);
121.302 +"******* Root.ML end *******";
122.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
122.2 +++ b/src/Tools/isac/Knowledge/Root.thy Wed Aug 25 16:20:07 2010 +0200
122.3 @@ -0,0 +1,53 @@
122.4 +(* theory collecting all knowledge for Root
122.5 + created by:
122.6 + date:
122.7 + changed by: rlang
122.8 + last change by: rlang
122.9 + date: 02.10.21
122.10 +*)
122.11 +
122.12 +(* use_thy_only"Knowledge/Root";
122.13 + remove_thy"Root";
122.14 + use_thy"Knowledge/Isac";
122.15 +*)
122.16 +Root = Simplify +
122.17 +
122.18 +(*-------------------- consts------------------------------------------------*)
122.19 +consts
122.20 +
122.21 + sqrt :: "real => real" (*"(sqrt _ )" [80] 80*)
122.22 + nroot :: "[real, real] => real"
122.23 +
122.24 +(*----------------------scripts-----------------------*)
122.25 +
122.26 +(*-------------------- rules------------------------------------------------*)
122.27 +rules (*.not contained in Isabelle2002,
122.28 + stated as axioms, TODO: prove as theorems;
122.29 + theorem-IDs 'xxxI' with ^^^ instead of ^ in 'xxx' in Isabelle2002.*)
122.30 +
122.31 + root_plus_minus "0 <= b ==> \
122.32 + \(a^^^2 = b) = ((a = sqrt b) | (a = (-1)*sqrt b))"
122.33 + root_false "b < 0 ==> (a^^^2 = b) = False"
122.34 +
122.35 + (* for expand_rootbinom *)
122.36 + real_pp_binom_times "(a + b)*(c + d) = a*c + a*d + b*c + b*d"
122.37 + real_pm_binom_times "(a + b)*(c - d) = a*c - a*d + b*c - b*d"
122.38 + real_mp_binom_times "(a - b)*(c + d) = a*c + a*d - b*c - b*d"
122.39 + real_mm_binom_times "(a - b)*(c - d) = a*c - a*d - b*c + b*d"
122.40 + real_plus_binom_pow3 "(a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3"
122.41 + real_minus_binom_pow3 "(a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3"
122.42 + realpow_mul "(a*b)^^^n = a^^^n * b^^^n"
122.43 +
122.44 + real_diff_minus "a - b = a + (-1) * b"
122.45 + real_plus_binom_times "(a + b)*(a + b) = a^^^2 + 2*a*b + b^^^2"
122.46 + real_minus_binom_times "(a - b)*(a - b) = a^^^2 - 2*a*b + b^^^2"
122.47 + real_plus_binom_pow2 "(a + b)^^^2 = a^^^2 + 2*a*b + b^^^2"
122.48 + real_minus_binom_pow2 "(a - b)^^^2 = a^^^2 - 2*a*b + b^^^2"
122.49 + real_plus_minus_binom1 "(a + b)*(a - b) = a^^^2 - b^^^2"
122.50 + real_plus_minus_binom2 "(a - b)*(a + b) = a^^^2 - b^^^2"
122.51 +
122.52 + real_root_positive "0 <= a ==> (x ^^^ 2 = a) = (x = sqrt a)"
122.53 + real_root_negative "a < 0 ==> (x ^^^ 2 = a) = False"
122.54 +
122.55 +
122.56 +end
123.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
123.2 +++ b/src/Tools/isac/Knowledge/RootEq.ML Wed Aug 25 16:20:07 2010 +0200
123.3 @@ -0,0 +1,505 @@
123.4 +(*.(c) by Richard Lang, 2003 .*)
123.5 +(* theory collecting all knowledge for RootEquations
123.6 + created by: rlang
123.7 + date: 02.09
123.8 + changed by: rlang
123.9 + last change by: rlang
123.10 + date: 02.11.14
123.11 +*)
123.12 +
123.13 +(* use"Knowledge/RootEq.ML";
123.14 + use"RootEq.ML";
123.15 +
123.16 + use"ROOT.ML";
123.17 + cd"knowledge";
123.18 +
123.19 + remove_thy"RootEq";
123.20 + use_thy"Knowledge/Isac";
123.21 + *)
123.22 +"******* RootEq.ML begin *******";
123.23 +
123.24 +theory' := overwritel (!theory', [("RootEq.thy",RootEq.thy)]);
123.25 +(*-------------------------functions---------------------*)
123.26 +(* true if bdv is under sqrt of a Equation*)
123.27 +fun is_rootTerm_in t v =
123.28 + let
123.29 + fun coeff_in c v = member op = (vars c) v;
123.30 + fun findroot (_ $ _ $ _ $ _) v = raise error("is_rootTerm_in:")
123.31 + (* at the moment there is no term like this, but ....*)
123.32 + | findroot (t as (Const ("Root.nroot",_) $ _ $ t3)) v = coeff_in t3 v
123.33 + | findroot (_ $ t2 $ t3) v = (findroot t2 v) orelse (findroot t3 v)
123.34 + | findroot (t as (Const ("Root.sqrt",_) $ t2)) v = coeff_in t2 v
123.35 + | findroot (_ $ t2) v = (findroot t2 v)
123.36 + | findroot _ _ = false;
123.37 + in
123.38 + findroot t v
123.39 + end;
123.40 +
123.41 + fun is_sqrtTerm_in t v =
123.42 + let
123.43 + fun coeff_in c v = member op = (vars c) v;
123.44 + fun findsqrt (_ $ _ $ _ $ _) v = raise error("is_sqrteqation_in:")
123.45 + (* at the moment there is no term like this, but ....*)
123.46 + | findsqrt (_ $ t1 $ t2) v = (findsqrt t1 v) orelse (findsqrt t2 v)
123.47 + | findsqrt (t as (Const ("Root.sqrt",_) $ a)) v = coeff_in a v
123.48 + | findsqrt (_ $ t1) v = (findsqrt t1 v)
123.49 + | findsqrt _ _ = false;
123.50 + in
123.51 + findsqrt t v
123.52 + end;
123.53 +
123.54 +(* RL: 030518: Is in the rightest subterm of a term a sqrt with bdv,
123.55 +and the subterm ist connected with + or * --> is normalized*)
123.56 + fun is_normSqrtTerm_in t v =
123.57 + let
123.58 + fun coeff_in c v = member op = (vars c) v;
123.59 + fun isnorm (_ $ _ $ _ $ _) v = raise error("is_normSqrtTerm_in:")
123.60 + (* at the moment there is no term like this, but ....*)
123.61 + | isnorm (Const ("op +",_) $ _ $ t2) v = is_sqrtTerm_in t2 v
123.62 + | isnorm (Const ("op *",_) $ _ $ t2) v = is_sqrtTerm_in t2 v
123.63 + | isnorm (Const ("op -",_) $ _ $ _) v = false
123.64 + | isnorm (Const ("HOL.divide",_) $ t1 $ t2) v = (is_sqrtTerm_in t1 v) orelse
123.65 + (is_sqrtTerm_in t2 v)
123.66 + | isnorm (Const ("Root.sqrt",_) $ t1) v = coeff_in t1 v
123.67 + | isnorm (_ $ t1) v = is_sqrtTerm_in t1 v
123.68 + | isnorm _ _ = false;
123.69 + in
123.70 + isnorm t v
123.71 + end;
123.72 +
123.73 +fun eval_is_rootTerm_in _ _ (p as (Const ("RootEq.is'_rootTerm'_in",_) $ t $ v)) _ =
123.74 + if is_rootTerm_in t v then
123.75 + SOME ((term2str p) ^ " = True",
123.76 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
123.77 + else SOME ((term2str p) ^ " = True",
123.78 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
123.79 + | eval_is_rootTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
123.80 +
123.81 +fun eval_is_sqrtTerm_in _ _ (p as (Const ("RootEq.is'_sqrtTerm'_in",_) $ t $ v)) _ =
123.82 + if is_sqrtTerm_in t v then
123.83 + SOME ((term2str p) ^ " = True",
123.84 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
123.85 + else SOME ((term2str p) ^ " = True",
123.86 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
123.87 + | eval_is_sqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
123.88 +
123.89 +fun eval_is_normSqrtTerm_in _ _ (p as (Const ("RootEq.is'_normSqrtTerm'_in",_) $ t $ v)) _ =
123.90 + if is_normSqrtTerm_in t v then
123.91 + SOME ((term2str p) ^ " = True",
123.92 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
123.93 + else SOME ((term2str p) ^ " = True",
123.94 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
123.95 + | eval_is_normSqrtTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
123.96 +
123.97 +(*-------------------------rulse-------------------------*)
123.98 +val RootEq_prls = (*15.10.02:just the following order due to subterm evaluation*)
123.99 + append_rls "RootEq_prls" e_rls
123.100 + [Calc ("Atools.ident",eval_ident "#ident_"),
123.101 + Calc ("Tools.matches",eval_matches ""),
123.102 + Calc ("Tools.lhs" ,eval_lhs ""),
123.103 + Calc ("Tools.rhs" ,eval_rhs ""),
123.104 + Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""),
123.105 + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""),
123.106 + Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""),
123.107 + Calc ("op =",eval_equal "#equal_"),
123.108 + Thm ("not_true",num_str not_true),
123.109 + Thm ("not_false",num_str not_false),
123.110 + Thm ("and_true",num_str and_true),
123.111 + Thm ("and_false",num_str and_false),
123.112 + Thm ("or_true",num_str or_true),
123.113 + Thm ("or_false",num_str or_false)
123.114 + ];
123.115 +
123.116 +val RootEq_erls =
123.117 + append_rls "RootEq_erls" Root_erls
123.118 + [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq)
123.119 + ];
123.120 +
123.121 +val RootEq_crls =
123.122 + append_rls "RootEq_crls" Root_crls
123.123 + [Thm ("real_divide_divide2_eq",num_str real_divide_divide2_eq)
123.124 + ];
123.125 +
123.126 +val rooteq_srls =
123.127 + append_rls "rooteq_srls" e_rls
123.128 + [Calc ("RootEq.is'_sqrtTerm'_in",eval_is_sqrtTerm_in ""),
123.129 + Calc ("RootEq.is'_normSqrtTerm'_in",eval_is_normSqrtTerm_in ""),
123.130 + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in "")
123.131 + ];
123.132 +
123.133 +ruleset' := overwritelthy thy (!ruleset',
123.134 + [("RootEq_erls",RootEq_erls), (*FIXXXME:del with rls.rls'*)
123.135 + ("rooteq_srls",rooteq_srls)
123.136 + ]);
123.137 +
123.138 +(*isolate the bound variable in an sqrt equation; 'bdv' is a meta-constant*)
123.139 + val sqrt_isolate = prep_rls(
123.140 + Rls {id = "sqrt_isolate", preconds = [], rew_ord = ("termlessI",termlessI),
123.141 + erls = RootEq_erls, srls = Erls, calc = [],
123.142 + (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
123.143 + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
123.144 + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
123.145 + ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""),
123.146 + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
123.147 + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
123.148 + ("sqrt_square_equation_right_6","")],*)
123.149 + rules = [
123.150 + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
123.151 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
123.152 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
123.153 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
123.154 + Thm("sqrt_square_equation_both_1",num_str sqrt_square_equation_both_1),
123.155 + (* (sqrt a + sqrt b = sqrt c + sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *)
123.156 + Thm("sqrt_square_equation_both_2",num_str sqrt_square_equation_both_2),
123.157 + (* (sqrt a - sqrt b = sqrt c + sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c+2*sqrt(c)*sqrt(d)+d) *)
123.158 + Thm("sqrt_square_equation_both_3",num_str sqrt_square_equation_both_3),
123.159 + (* (sqrt a + sqrt b = sqrt c - sqrt d) -> (a+2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *)
123.160 + Thm("sqrt_square_equation_both_4",num_str sqrt_square_equation_both_4),
123.161 + (* (sqrt a - sqrt b = sqrt c - sqrt d) -> (a-2*sqrt(a)*sqrt(b)+b) = c-2*sqrt(c)*sqrt(d)+d) *)
123.162 + Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *)
123.163 + Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *)
123.164 + Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *)
123.165 + Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *)
123.166 + Thm("sqrt_isolate_l_add5",num_str sqrt_isolate_l_add5), (* a+b*c/f*sqrt(x)=d->b*c/f*sqrt(x)=d-a *)
123.167 + Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *)
123.168 + (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *)
123.169 + Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *)
123.170 + Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *)
123.171 + Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*)
123.172 + Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *)
123.173 + Thm("sqrt_isolate_r_add5",num_str sqrt_isolate_r_add5), (* a=d+e*g/h*sqrt(x)->a-d=e*g/h*sqrt(x)*)
123.174 + Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *)
123.175 + (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *)
123.176 + Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1),
123.177 + (* sqrt(x)=b -> x=b^2 *)
123.178 + Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2),
123.179 + (* c*sqrt(x)=b -> c^2*x=b^2 *)
123.180 + Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3),
123.181 + (* c/sqrt(x)=b -> c^2/x=b^2 *)
123.182 + Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4),
123.183 + (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *)
123.184 + Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5),
123.185 + (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *)
123.186 + Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6),
123.187 + (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *)
123.188 + Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1),
123.189 + (* a=sqrt(x) ->a^2=x *)
123.190 + Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2),
123.191 + (* a=c*sqrt(x) ->a^2=c^2*x *)
123.192 + Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3),
123.193 + (* a=c/sqrt(x) ->a^2=c^2/x *)
123.194 + Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4),
123.195 + (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *)
123.196 + Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5),
123.197 + (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *)
123.198 + Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6)
123.199 + (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *)
123.200 + ],
123.201 + scr = Script ((term_of o the o (parse thy)) "empty_script")
123.202 + }:rls);
123.203 +ruleset' := overwritelthy thy (!ruleset',
123.204 + [("sqrt_isolate",sqrt_isolate)
123.205 + ]);
123.206 +(* -- left 28.08.02--*)
123.207 +(*isolate the bound variable in an sqrt left equation; 'bdv' is a meta-constant*)
123.208 + val l_sqrt_isolate = prep_rls(
123.209 + Rls {id = "l_sqrt_isolate", preconds = [],
123.210 + rew_ord = ("termlessI",termlessI),
123.211 + erls = RootEq_erls, srls = Erls, calc = [],
123.212 + (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
123.213 + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
123.214 + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
123.215 + ("sqrt_square_equation_left_6","")],*)
123.216 + rules = [
123.217 + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
123.218 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
123.219 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
123.220 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
123.221 + Thm("sqrt_isolate_l_add1",num_str sqrt_isolate_l_add1), (* a+b*sqrt(x)=d -> b*sqrt(x) = d-a *)
123.222 + Thm("sqrt_isolate_l_add2",num_str sqrt_isolate_l_add2), (* a+ sqrt(x)=d -> sqrt(x) = d-a *)
123.223 + Thm("sqrt_isolate_l_add3",num_str sqrt_isolate_l_add3), (* a+b*c/sqrt(x)=d->b*c/sqrt(x)=d-a *)
123.224 + Thm("sqrt_isolate_l_add4",num_str sqrt_isolate_l_add4), (* a+c/sqrt(x)=d -> c/sqrt(x) = d-a *)
123.225 + Thm("sqrt_isolate_l_add5",num_str sqrt_isolate_l_add5), (* a+b*c/f*sqrt(x)=d->b*c/f*sqrt(x)=d-a *)
123.226 + Thm("sqrt_isolate_l_add6",num_str sqrt_isolate_l_add6), (* a+c/f*sqrt(x)=d -> c/f*sqrt(x) = d-a *)
123.227 + (*Thm("sqrt_isolate_l_div",num_str sqrt_isolate_l_div),*) (* b*sqrt(x) = d sqrt(x) d/b *)
123.228 + Thm("sqrt_square_equation_left_1",num_str sqrt_square_equation_left_1),
123.229 + (* sqrt(x)=b -> x=b^2 *)
123.230 + Thm("sqrt_square_equation_left_2",num_str sqrt_square_equation_left_2),
123.231 + (* a*sqrt(x)=b -> a^2*x=b^2*)
123.232 + Thm("sqrt_square_equation_left_3",num_str sqrt_square_equation_left_3),
123.233 + (* c/sqrt(x)=b -> c^2/x=b^2 *)
123.234 + Thm("sqrt_square_equation_left_4",num_str sqrt_square_equation_left_4),
123.235 + (* c*d/sqrt(x)=b -> c^2*d^2/x=b^2 *)
123.236 + Thm("sqrt_square_equation_left_5",num_str sqrt_square_equation_left_5),
123.237 + (* c/d*sqrt(x)=b -> c^2/d^2x=b^2 *)
123.238 + Thm("sqrt_square_equation_left_6",num_str sqrt_square_equation_left_6)
123.239 + (* c*d/g*sqrt(x)=b -> c^2*d^2/g^2x=b^2 *)
123.240 + ],
123.241 + scr = Script ((term_of o the o (parse thy)) "empty_script")
123.242 + }:rls);
123.243 +ruleset' := overwritelthy thy (!ruleset',
123.244 + [("l_sqrt_isolate",l_sqrt_isolate)
123.245 + ]);
123.246 +
123.247 +(* -- right 28.8.02--*)
123.248 +(*isolate the bound variable in an sqrt right equation; 'bdv' is a meta-constant*)
123.249 + val r_sqrt_isolate = prep_rls(
123.250 + Rls {id = "r_sqrt_isolate", preconds = [],
123.251 + rew_ord = ("termlessI",termlessI),
123.252 + erls = RootEq_erls, srls = Erls, calc = [],
123.253 + (*asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_right_1",""),
123.254 + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
123.255 + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
123.256 + ("sqrt_square_equation_right_6","")],*)
123.257 + rules = [
123.258 + Thm("sqrt_square_1",num_str sqrt_square_1), (* (sqrt a)^^^2 -> a *)
123.259 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) -> a *)
123.260 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt a sqrt b -> sqrt(ab) *)
123.261 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a sqrt b sqrt c -> a sqrt(bc) *)
123.262 + Thm("sqrt_isolate_r_add1",num_str sqrt_isolate_r_add1), (* a= d+e*sqrt(x) -> a-d=e*sqrt(x) *)
123.263 + Thm("sqrt_isolate_r_add2",num_str sqrt_isolate_r_add2), (* a= d+ sqrt(x) -> a-d= sqrt(x) *)
123.264 + Thm("sqrt_isolate_r_add3",num_str sqrt_isolate_r_add3), (* a=d+e*g/sqrt(x)->a-d=e*g/sqrt(x)*)
123.265 + Thm("sqrt_isolate_r_add4",num_str sqrt_isolate_r_add4), (* a= d+g/sqrt(x) -> a-d=g/sqrt(x) *)
123.266 + Thm("sqrt_isolate_r_add5",num_str sqrt_isolate_r_add5), (* a=d+e*g/h*sqrt(x)->a-d=e*g/h*sqrt(x)*)
123.267 + Thm("sqrt_isolate_r_add6",num_str sqrt_isolate_r_add6), (* a= d+g/h*sqrt(x) -> a-d=g/h*sqrt(x) *)
123.268 + (*Thm("sqrt_isolate_r_div",num_str sqrt_isolate_r_div),*) (* a=e*sqrt(x) -> a/e = sqrt(x) *)
123.269 + Thm("sqrt_square_equation_right_1",num_str sqrt_square_equation_right_1),
123.270 + (* a=sqrt(x) ->a^2=x *)
123.271 + Thm("sqrt_square_equation_right_2",num_str sqrt_square_equation_right_2),
123.272 + (* a=c*sqrt(x) ->a^2=c^2*x *)
123.273 + Thm("sqrt_square_equation_right_3",num_str sqrt_square_equation_right_3),
123.274 + (* a=c/sqrt(x) ->a^2=c^2/x *)
123.275 + Thm("sqrt_square_equation_right_4",num_str sqrt_square_equation_right_4),
123.276 + (* a=c*d/sqrt(x) ->a^2=c^2*d^2/x *)
123.277 + Thm("sqrt_square_equation_right_5",num_str sqrt_square_equation_right_5),
123.278 + (* a=c/e*sqrt(x) ->a^2=c^2/e^2x *)
123.279 + Thm("sqrt_square_equation_right_6",num_str sqrt_square_equation_right_6)
123.280 + (* a=c*d/g*sqrt(x) ->a^2=c^2*d^2/g^2*x *)
123.281 + ],
123.282 + scr = Script ((term_of o the o (parse thy)) "empty_script")
123.283 + }:rls);
123.284 +ruleset' := overwritelthy thy (!ruleset',
123.285 + [("r_sqrt_isolate",r_sqrt_isolate)
123.286 + ]);
123.287 +
123.288 +val rooteq_simplify = prep_rls(
123.289 + Rls {id = "rooteq_simplify",
123.290 + preconds = [], rew_ord = ("termlessI",termlessI),
123.291 + erls = RootEq_erls, srls = Erls, calc = [],
123.292 + (*asm_thm = [("sqrt_square_1","")],*)
123.293 + rules = [Thm ("real_assoc_1",num_str real_assoc_1), (* a+(b+c) = a+b+c *)
123.294 + Thm ("real_assoc_2",num_str real_assoc_2), (* a*(b*c) = a*b*c *)
123.295 + Calc ("op +",eval_binop "#add_"),
123.296 + Calc ("op -",eval_binop "#sub_"),
123.297 + Calc ("op *",eval_binop "#mult_"),
123.298 + Calc ("HOL.divide", eval_cancel "#divide_"),
123.299 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
123.300 + Calc ("Atools.pow" ,eval_binop "#power_"),
123.301 + Thm("real_plus_binom_pow2",num_str real_plus_binom_pow2),
123.302 + Thm("real_minus_binom_pow2",num_str real_minus_binom_pow2),
123.303 + Thm("realpow_mul",num_str realpow_mul), (* (a * b)^n = a^n * b^n*)
123.304 + Thm("sqrt_times_root_1",num_str sqrt_times_root_1), (* sqrt b * sqrt c = sqrt(b*c) *)
123.305 + Thm("sqrt_times_root_2",num_str sqrt_times_root_2), (* a * sqrt a * sqrt b = a * sqrt(a*b) *)
123.306 + Thm("sqrt_square_2",num_str sqrt_square_2), (* sqrt (a^^^2) = a *)
123.307 + Thm("sqrt_square_1",num_str sqrt_square_1) (* sqrt a ^^^ 2 = a *)
123.308 + ],
123.309 + scr = Script ((term_of o the o (parse thy)) "empty_script")
123.310 + }:rls);
123.311 + ruleset' := overwritelthy thy (!ruleset',
123.312 + [("rooteq_simplify",rooteq_simplify)
123.313 + ]);
123.314 +
123.315 +(*-------------------------Problem-----------------------*)
123.316 +(*
123.317 +(get_pbt ["root","univariate","equation"]);
123.318 +show_ptyps();
123.319 +*)
123.320 +(* ---------root----------- *)
123.321 +store_pbt
123.322 + (prep_pbt RootEq.thy "pbl_equ_univ_root" [] e_pblID
123.323 + (["root","univariate","equation"],
123.324 + [("#Given" ,["equality e_","solveFor v_"]),
123.325 + ("#Where" ,["(lhs e_) is_rootTerm_in (v_::real) | \
123.326 + \(rhs e_) is_rootTerm_in (v_::real)"]),
123.327 + ("#Find" ,["solutions v_i_"])
123.328 + ],
123.329 + RootEq_prls, SOME "solve (e_::bool, v_)",
123.330 + []));
123.331 +(* ---------sqrt----------- *)
123.332 +store_pbt
123.333 + (prep_pbt RootEq.thy "pbl_equ_univ_root_sq" [] e_pblID
123.334 + (["sq","root","univariate","equation"],
123.335 + [("#Given" ,["equality e_","solveFor v_"]),
123.336 + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
123.337 + \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\
123.338 + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
123.339 + \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]),
123.340 + ("#Find" ,["solutions v_i_"])
123.341 + ],
123.342 + RootEq_prls, SOME "solve (e_::bool, v_)",
123.343 + [["RootEq","solve_sq_root_equation"]]));
123.344 +(* ---------normalize----------- *)
123.345 +store_pbt
123.346 + (prep_pbt RootEq.thy "pbl_equ_univ_root_norm" [] e_pblID
123.347 + (["normalize","root","univariate","equation"],
123.348 + [("#Given" ,["equality e_","solveFor v_"]),
123.349 + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
123.350 + \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \
123.351 + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
123.352 + \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]),
123.353 + ("#Find" ,["solutions v_i_"])
123.354 + ],
123.355 + RootEq_prls, SOME "solve (e_::bool, v_)",
123.356 + [["RootEq","norm_sq_root_equation"]]));
123.357 +
123.358 +(*-------------------------methods-----------------------*)
123.359 +(* ---- root 20.8.02 ---*)
123.360 +store_met
123.361 + (prep_met RootEq.thy "met_rooteq" [] e_metID
123.362 + (["RootEq"],
123.363 + [],
123.364 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
123.365 + crls=RootEq_crls, nrls=norm_Poly(*,
123.366 + asm_rls=[],asm_thm=[]*)}, "empty_script"));
123.367 +(*-- normalize 20.10.02 --*)
123.368 +store_met
123.369 + (prep_met RootEq.thy "met_rooteq_norm" [] e_metID
123.370 + (["RootEq","norm_sq_root_equation"],
123.371 + [("#Given" ,["equality e_","solveFor v_"]),
123.372 + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
123.373 + \ Not((lhs e_) is_normSqrtTerm_in (v_::real))) | \
123.374 + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
123.375 + \ Not((rhs e_) is_normSqrtTerm_in (v_::real)))"]),
123.376 + ("#Find" ,["solutions v_i_"])
123.377 + ],
123.378 + {rew_ord'="termlessI",
123.379 + rls'=RootEq_erls,
123.380 + srls=e_rls,
123.381 + prls=RootEq_prls,
123.382 + calc=[],
123.383 + crls=RootEq_crls, nrls=norm_Poly(*,
123.384 + asm_rls=[],
123.385 + asm_thm=[("sqrt_square_1","")]*)},
123.386 + "Script Norm_sq_root_equation (e_::bool) (v_::real) = \
123.387 + \(let e_ = ((Repeat(Try (Rewrite makex1_x False))) @@ \
123.388 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
123.389 + \ (Try (Rewrite_Set rooteq_simplify True)) @@ \
123.390 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
123.391 + \ (Try (Rewrite_Set rooteq_simplify True))) e_ \
123.392 + \ in ((SubProblem (RootEq_,[univariate,equation], \
123.393 + \ [no_met]) [bool_ e_, real_ v_])))"
123.394 + ));
123.395 +
123.396 +store_met
123.397 + (prep_met RootEq.thy "met_rooteq_sq" [] e_metID
123.398 + (["RootEq","solve_sq_root_equation"],
123.399 + [("#Given" ,["equality e_","solveFor v_"]),
123.400 + ("#Where" ,["( ((lhs e_) is_sqrtTerm_in (v_::real)) &\
123.401 + \ ((lhs e_) is_normSqrtTerm_in (v_::real)) ) |\
123.402 + \( ((rhs e_) is_sqrtTerm_in (v_::real)) &\
123.403 + \ ((rhs e_) is_normSqrtTerm_in (v_::real)) )"]),
123.404 + ("#Find" ,["solutions v_i_"])
123.405 + ],
123.406 + {rew_ord'="termlessI",
123.407 + rls'=RootEq_erls,
123.408 + srls = rooteq_srls,
123.409 + prls = RootEq_prls,
123.410 + calc = [],
123.411 + crls=RootEq_crls, nrls=norm_Poly(*,
123.412 + asm_rls = [],
123.413 + asm_thm = [("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
123.414 + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
123.415 + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
123.416 + ("sqrt_square_equation_left_6",""),("sqrt_square_equation_right_1",""),
123.417 + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
123.418 + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
123.419 + ("sqrt_square_equation_right_6","")]*)},
123.420 +"Script Solve_sq_root_equation (e_::bool) (v_::real) = \
123.421 +\(let e_ = \
123.422 +\ ((Try (Rewrite_Set_Inst [(bdv,v_::real)] sqrt_isolate True)) @@ \
123.423 +\ (Try (Rewrite_Set rooteq_simplify True)) @@ \
123.424 +\ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
123.425 +\ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
123.426 +\ (Try (Rewrite_Set rooteq_simplify True))) e_;\
123.427 +\ (L_::bool list) = \
123.428 +\ (if (((lhs e_) is_sqrtTerm_in v_) | ((rhs e_) is_sqrtTerm_in v_))\
123.429 +\ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
123.430 +\ [no_met]) [bool_ e_, real_ v_]) \
123.431 +\ else (SubProblem (RootEq_,[univariate,equation], \
123.432 +\ [no_met]) [bool_ e_, real_ v_])) \
123.433 +\ in Check_elementwise L_ {(v_::real). Assumptions})"
123.434 + ));
123.435 +
123.436 +(*-- right 28.08.02 --*)
123.437 +store_met
123.438 + (prep_met RootEq.thy "met_rooteq_sq_right" [] e_metID
123.439 + (["RootEq","solve_right_sq_root_equation"],
123.440 + [("#Given" ,["equality e_","solveFor v_"]),
123.441 + ("#Where" ,["(rhs e_) is_sqrtTerm_in v_"]),
123.442 + ("#Find" ,["solutions v_i_"])
123.443 + ],
123.444 + {rew_ord'="termlessI",
123.445 + rls'=RootEq_erls,
123.446 + srls=e_rls,
123.447 + prls=RootEq_prls,
123.448 + calc=[],
123.449 + crls=RootEq_crls, nrls=norm_Poly(*,
123.450 + asm_rls=[],
123.451 + asm_thm=[("sqrt_square_1",""),("sqrt_square_1",""),("sqrt_square_equation_right_1",""),
123.452 + ("sqrt_square_equation_right_2",""),("sqrt_square_equation_right_3",""),
123.453 + ("sqrt_square_equation_right_4",""),("sqrt_square_equation_right_5",""),
123.454 + ("sqrt_square_equation_right_6","")]*)},
123.455 + "Script Solve_right_sq_root_equation (e_::bool) (v_::real) = \
123.456 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] r_sqrt_isolate False)) @@ \
123.457 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
123.458 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
123.459 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
123.460 + \ (Try (Rewrite_Set rooteq_simplify False))) e_\
123.461 + \ in if ((rhs e_) is_sqrtTerm_in v_) \
123.462 + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
123.463 + \ [no_met]) [bool_ e_, real_ v_]) \
123.464 + \ else ((SubProblem (RootEq_,[univariate,equation], \
123.465 + \ [no_met]) [bool_ e_, real_ v_])))"
123.466 + ));
123.467 +
123.468 +(*-- left 28.08.02 --*)
123.469 +store_met
123.470 + (prep_met RootEq.thy "met_rooteq_sq_left" [] e_metID
123.471 + (["RootEq","solve_left_sq_root_equation"],
123.472 + [("#Given" ,["equality e_","solveFor v_"]),
123.473 + ("#Where" ,["(lhs e_) is_sqrtTerm_in v_"]),
123.474 + ("#Find" ,["solutions v_i_"])
123.475 + ],
123.476 + {rew_ord'="termlessI",
123.477 + rls'=RootEq_erls,
123.478 + srls=e_rls,
123.479 + prls=RootEq_prls,
123.480 + calc=[],
123.481 + crls=RootEq_crls, nrls=norm_Poly(*,
123.482 + asm_rls=[],
123.483 + asm_thm=[("sqrt_square_1",""),("sqrt_square_equation_left_1",""),
123.484 + ("sqrt_square_equation_left_2",""),("sqrt_square_equation_left_3",""),
123.485 + ("sqrt_square_equation_left_4",""),("sqrt_square_equation_left_5",""),
123.486 + ("sqrt_square_equation_left_6","")]*)},
123.487 + "Script Solve_left_sq_root_equation (e_::bool) (v_::real) = \
123.488 + \(let e_ = ((Try (Rewrite_Set_Inst [(bdv,v_::real)] l_sqrt_isolate False)) @@ \
123.489 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
123.490 + \ (Try (Repeat (Rewrite_Set expand_rootbinoms False))) @@ \
123.491 + \ (Try (Repeat (Rewrite_Set make_rooteq False))) @@ \
123.492 + \ (Try (Rewrite_Set rooteq_simplify False))) e_\
123.493 + \ in if ((lhs e_) is_sqrtTerm_in v_) \
123.494 + \ then (SubProblem (RootEq_,[normalize,root,univariate,equation], \
123.495 + \ [no_met]) [bool_ e_, real_ v_]) \
123.496 + \ else ((SubProblem (RootEq_,[univariate,equation], \
123.497 + \ [no_met]) [bool_ e_, real_ v_])))"
123.498 + ));
123.499 +
123.500 +calclist':= overwritel (!calclist',
123.501 + [("is_rootTerm_in", ("RootEq.is'_rootTerm'_in",
123.502 + eval_is_rootTerm_in"")),
123.503 + ("is_sqrtTerm_in", ("RootEq.is'_sqrtTerm'_in",
123.504 + eval_is_sqrtTerm_in"")),
123.505 + ("is_normSqrtTerm_in", ("RootEq.is_normSqrtTerm_in",
123.506 + eval_is_normSqrtTerm_in""))
123.507 + ]);(*("", ("", "")),*)
123.508 +"******* RootEq.ML end *******";
124.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
124.2 +++ b/src/Tools/isac/Knowledge/RootEq.thy Wed Aug 25 16:20:07 2010 +0200
124.3 @@ -0,0 +1,142 @@
124.4 +(*.(c) by Richard Lang, 2003 .*)
124.5 +(* collecting all knowledge for Root Equations
124.6 + created by: rlang
124.7 + date: 02.08
124.8 + changed by: rlang
124.9 + last change by: rlang
124.10 + date: 02.11.14
124.11 +*)
124.12 +(* use"../knowledge/RootEq.ML";
124.13 + use"knowledge/RootEq.ML";
124.14 + use"RootEq.ML";
124.15 +
124.16 + remove_thy"RootEq";
124.17 + use_thy"Isac";
124.18 +
124.19 + use"ROOT.ML";
124.20 + cd"knowledge";
124.21 + *)
124.22 +
124.23 +RootEq = Root +
124.24 +
124.25 +(*-------------------- consts------------------------------------------------*)
124.26 +consts
124.27 + (*-------------------------root-----------------------*)
124.28 + is'_rootTerm'_in :: [real, real] => bool ("_ is'_rootTerm'_in _")
124.29 + is'_sqrtTerm'_in :: [real, real] => bool ("_ is'_sqrtTerm'_in _")
124.30 + is'_normSqrtTerm'_in :: [real, real] => bool ("_ is'_normSqrtTerm'_in _")
124.31 + (*----------------------scripts-----------------------*)
124.32 + Norm'_sq'_root'_equation
124.33 + :: "[bool,real, \
124.34 + \ bool list] => bool list"
124.35 + ("((Script Norm'_sq'_root'_equation (_ _ =))// \
124.36 + \ (_))" 9)
124.37 + Solve'_sq'_root'_equation
124.38 + :: "[bool,real, \
124.39 + \ bool list] => bool list"
124.40 + ("((Script Solve'_sq'_root'_equation (_ _ =))// \
124.41 + \ (_))" 9)
124.42 + Solve'_left'_sq'_root'_equation
124.43 + :: "[bool,real, \
124.44 + \ bool list] => bool list"
124.45 + ("((Script Solve'_left'_sq'_root'_equation (_ _ =))// \
124.46 + \ (_))" 9)
124.47 + Solve'_right'_sq'_root'_equation
124.48 + :: "[bool,real, \
124.49 + \ bool list] => bool list"
124.50 + ("((Script Solve'_right'_sq'_root'_equation (_ _ =))// \
124.51 + \ (_))" 9)
124.52 +
124.53 +(*-------------------- rules------------------------------------------------*)
124.54 +rules
124.55 +
124.56 +(* normalize *)
124.57 + makex1_x
124.58 + "a^^^1 = a"
124.59 + real_assoc_1
124.60 + "a+(b+c) = a+b+c"
124.61 + real_assoc_2
124.62 + "a*(b*c) = a*b*c"
124.63 +
124.64 + (* simplification of root*)
124.65 + sqrt_square_1
124.66 + "[|0 <= a|] ==> (sqrt a)^^^2 = a"
124.67 + sqrt_square_2
124.68 + "sqrt (a ^^^ 2) = a"
124.69 + sqrt_times_root_1
124.70 + "sqrt a * sqrt b = sqrt(a*b)"
124.71 + sqrt_times_root_2
124.72 + "a * sqrt b * sqrt c = a * sqrt(b*c)"
124.73 +
124.74 + (* isolate one root on the LEFT or RIGHT hand side of the equation *)
124.75 + sqrt_isolate_l_add1
124.76 + "[|bdv occurs_in c|] ==> (a + b*sqrt(c) = d) = (b * sqrt(c) = d+ (-1) * a)"
124.77 + sqrt_isolate_l_add2
124.78 + "[|bdv occurs_in c|] ==>(a + sqrt(c) = d) = ((sqrt(c) = d+ (-1) * a))"
124.79 + sqrt_isolate_l_add3
124.80 + "[|bdv occurs_in c|] ==> (a + b*(e/sqrt(c)) = d) = (b * (e/sqrt(c)) = d+ (-1) * a)"
124.81 + sqrt_isolate_l_add4
124.82 + "[|bdv occurs_in c|] ==>(a + b/(f*sqrt(c)) = d) = (b / (f*sqrt(c)) = d+ (-1) * a)"
124.83 + sqrt_isolate_l_add5
124.84 + "[|bdv occurs_in c|] ==> (a + b*(e/(f*sqrt(c))) = d) = (b * (e/(f*sqrt(c))) = d+ (-1) * a)"
124.85 + sqrt_isolate_l_add6
124.86 + "[|bdv occurs_in c|] ==>(a + b/sqrt(c) = d) = (b / sqrt(c) = d+ (-1) * a)"
124.87 + sqrt_isolate_r_add1
124.88 + "[|bdv occurs_in f|] ==>(a = d + e*sqrt(f)) = (a + (-1) * d = e*sqrt(f))"
124.89 + sqrt_isolate_r_add2
124.90 + "[|bdv occurs_in f|] ==>(a = d + sqrt(f)) = (a + (-1) * d = sqrt(f))"
124.91 + (* small hack: thm 3,5,6 are not needed if rootnormalize is well done*)
124.92 + sqrt_isolate_r_add3
124.93 + "[|bdv occurs_in f|] ==>(a = d + e*(g/sqrt(f))) = (a + (-1) * d = e*(g/sqrt(f)))"
124.94 + sqrt_isolate_r_add4
124.95 + "[|bdv occurs_in f|] ==>(a = d + g/sqrt(f)) = (a + (-1) * d = g/sqrt(f))"
124.96 + sqrt_isolate_r_add5
124.97 + "[|bdv occurs_in f|] ==>(a = d + e*(g/(h*sqrt(f)))) = (a + (-1) * d = e*(g/(h*sqrt(f))))"
124.98 + sqrt_isolate_r_add6
124.99 + "[|bdv occurs_in f|] ==>(a = d + g/(h*sqrt(f))) = (a + (-1) * d = g/(h*sqrt(f)))"
124.100 +
124.101 + (* eliminate isolates sqrt *)
124.102 + sqrt_square_equation_both_1
124.103 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
124.104 + ( (sqrt a + sqrt b = sqrt c + sqrt d) =
124.105 + (a+2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))"
124.106 + sqrt_square_equation_both_2
124.107 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
124.108 + ( (sqrt a - sqrt b = sqrt c + sqrt d) =
124.109 + (a - 2*sqrt(a)*sqrt(b)+b = c+2*sqrt(c)*sqrt(d)+d))"
124.110 + sqrt_square_equation_both_3
124.111 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
124.112 + ( (sqrt a + sqrt b = sqrt c - sqrt d) =
124.113 + (a + 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))"
124.114 + sqrt_square_equation_both_4
124.115 + "[|bdv occurs_in b; bdv occurs_in d|] ==>
124.116 + ( (sqrt a - sqrt b = sqrt c - sqrt d) =
124.117 + (a - 2*sqrt(a)*sqrt(b)+b = c - 2*sqrt(c)*sqrt(d)+d))"
124.118 + sqrt_square_equation_left_1
124.119 + "[|bdv occurs_in a; 0 <= a; 0 <= b|] ==> ( (sqrt (a) = b) = (a = (b^^^2)))"
124.120 + sqrt_square_equation_left_2
124.121 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( (c*sqrt(a) = b) = (c^^^2*a = b^^^2))"
124.122 + sqrt_square_equation_left_3
124.123 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c|] ==> ( c/sqrt(a) = b) = (c^^^2 / a = b^^^2)"
124.124 + (* small hack: thm 4-6 are not needed if rootnormalize is well done*)
124.125 + sqrt_square_equation_left_4
124.126 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( (c*(d/sqrt (a)) = b) = (c^^^2*(d^^^2/a) = b^^^2))"
124.127 + sqrt_square_equation_left_5
124.128 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d|] ==> ( c/(d*sqrt(a)) = b) = (c^^^2 / (d^^^2*a) = b^^^2)"
124.129 + sqrt_square_equation_left_6
124.130 + "[|bdv occurs_in a; 0 <= a; 0 <= b*c*d*e|] ==> ( (c*(d/(e*sqrt (a))) = b) = (c^^^2*(d^^^2/(e^^^2*a)) = b^^^2))"
124.131 + sqrt_square_equation_right_1
124.132 + "[|bdv occurs_in b; 0 <= a; 0 <= b|] ==> ( (a = sqrt (b)) = (a^^^2 = b))"
124.133 + sqrt_square_equation_right_2
124.134 + "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c*sqrt (b)) = ((a^^^2) = c^^^2*b))"
124.135 + sqrt_square_equation_right_3
124.136 + "[|bdv occurs_in b; 0 <= a*c; 0 <= b|] ==> ( (a = c/sqrt (b)) = (a^^^2 = c^^^2/b))"
124.137 + (* small hack: thm 4-6 are not needed if rootnormalize is well done*)
124.138 + sqrt_square_equation_right_4
124.139 + "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c*(d/sqrt (b))) = ((a^^^2) = c^^^2*(d^^^2/b)))"
124.140 + sqrt_square_equation_right_5
124.141 + "[|bdv occurs_in b; 0 <= a*c*d; 0 <= b|] ==> ( (a = c/(d*sqrt (b))) = (a^^^2 = c^^^2/(d^^^2*b)))"
124.142 + sqrt_square_equation_right_6
124.143 + "[|bdv occurs_in b; 0 <= a*c*d*e; 0 <= b|] ==> ( (a = c*(d/(e*sqrt (b)))) = ((a^^^2) = c^^^2*(d^^^2/(e^^^2*b))))"
124.144 +
124.145 +end
125.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
125.2 +++ b/src/Tools/isac/Knowledge/RootRat.ML Wed Aug 25 16:20:07 2010 +0200
125.3 @@ -0,0 +1,50 @@
125.4 +(*.(c) by Richard Lang, 2003 .*)
125.5 +(* collecting all knowledge for Root and Rational
125.6 + created by: rlang
125.7 + date: 02.10
125.8 + changed by: rlang
125.9 + last change by: rlang
125.10 + date: 02.10.21
125.11 +*)
125.12 +(* use"knowledge/RootRat.ML";
125.13 + use"RootRat.ML";
125.14 +
125.15 + use"ROOT.ML";
125.16 + cd"knowledge";
125.17 +
125.18 + remove_thy"RootRat";
125.19 + use_thy"Isac";
125.20 + *)
125.21 +
125.22 +"******* RootRat.ML begin *******";
125.23 +theory' := overwritel (!theory', [("RootRat.thy",RootRat.thy)]);
125.24 +
125.25 +(*-------------------------functions---------------------*)
125.26 +
125.27 +(*-------------------------rulse-------------------------*)
125.28 +val rootrat_erls =
125.29 + merge_rls "rootrat_erls" Root_erls
125.30 + (merge_rls "" rational_erls
125.31 + (append_rls "" e_rls
125.32 + []));
125.33 +
125.34 +ruleset' := overwritelthy thy (!ruleset',
125.35 + [("rootrat_erls",rootrat_erls) (*FIXXXME:del with rls.rls'*)
125.36 + ]);
125.37 +
125.38 +(*.calculate numeral groundterms.*)
125.39 +val calculate_RootRat =
125.40 + append_rls "calculate_RootRat" calculate_Rational
125.41 + [Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
125.42 + (* w*(z1.0 + z2.0) = w * z1.0 + w * z2.0 *)
125.43 + Thm ("real_mult_1",num_str real_mult_1),
125.44 + (* 1 * z = z *)
125.45 + Thm ("sym_real_mult_minus1",num_str (real_mult_minus1 RS sym)),
125.46 + (* "- z1 = -1 * z1" *)
125.47 + Calc ("Root.sqrt",eval_sqrt "#sqrt_")
125.48 + ];
125.49 +ruleset' := overwritelthy thy (!ruleset',
125.50 + [("calculate_RootRat",calculate_RootRat)]);
125.51 +
125.52 +
125.53 +"******* RootRat.ML end *******";
126.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
126.2 +++ b/src/Tools/isac/Knowledge/RootRat.thy Wed Aug 25 16:20:07 2010 +0200
126.3 @@ -0,0 +1,16 @@
126.4 +(*.(c) by Richard Lang, 2003 .*)
126.5 +(* collecting all knowledge for Root and Rational
126.6 + created by: rlang
126.7 + date: 02.10
126.8 + changed by: rlang
126.9 + last change by: rlang
126.10 + date: 02.10.20
126.11 +*)
126.12 +
126.13 +RootRat = Root + Rational +
126.14 +(*-------------------- consts------------------------------------------------*)
126.15 +
126.16 +
126.17 +(*-------------------- rules------------------------------------------------*)
126.18 +
126.19 +end
127.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
127.2 +++ b/src/Tools/isac/Knowledge/RootRatEq.ML Wed Aug 25 16:20:07 2010 +0200
127.3 @@ -0,0 +1,166 @@
127.4 +(*.(c) by Richard Lang, 2003 .*)
127.5 +(* collecting all knowledge for Root and Rational Equations
127.6 + created by: rlang
127.7 + date: 02.10
127.8 + changed by: rlang
127.9 + last change by: rlang
127.10 + date: 02.11.04
127.11 +*)
127.12 +
127.13 +(* use"knowledge/RootRatEq.ML";
127.14 + use"RootRatEq.ML";
127.15 +
127.16 + use"ROOT.ML";
127.17 + cd"knowledge";
127.18 +
127.19 + remove_thy"RootRatEq";
127.20 + use_thy"Isac";
127.21 + *)
127.22 +
127.23 +"******* RootRatEq.ML begin *******";
127.24 +theory' := overwritel (!theory', [("RootRatEq.thy",RootRatEq.thy)]);
127.25 +
127.26 +(*-------------------------functions---------------------*)
127.27 +(* true if denominator contains (sq)root in + or - term
127.28 + 1/(sqrt(x+3)*(x+4)) -> false; 1/(sqrt(x)+2) -> true
127.29 + if false then (term)^2 contains no (sq)root *)
127.30 +fun is_rootRatAddTerm_in t v =
127.31 + let
127.32 + fun coeff_in c v = member op = (vars c) v;
127.33 + fun rootadd (t as (Const ("op +",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse
127.34 + (is_rootTerm_in t3 v)
127.35 + | rootadd (t as (Const ("op -",_) $ t2 $ t3)) v = (is_rootTerm_in t2 v) orelse
127.36 + (is_rootTerm_in t3 v)
127.37 + | rootadd _ _ = false;
127.38 + fun findrootrat (_ $ _ $ _ $ _) v = raise error("is_rootRatAddTerm_in:")
127.39 + (* at the moment there is no term like this, but ....*)
127.40 + | findrootrat (t as (Const ("HOL.divide",_) $ _ $ t3)) v =
127.41 + if (is_rootTerm_in t3 v) then rootadd t3 v else false
127.42 + | findrootrat (_ $ t1 $ t2) v = (findrootrat t1 v) orelse (findrootrat t2 v)
127.43 + | findrootrat (_ $ t1) v = (findrootrat t1 v)
127.44 + | findrootrat _ _ = false;
127.45 + in
127.46 + findrootrat t v
127.47 + end;
127.48 +
127.49 +fun eval_is_rootRatAddTerm_in _ _ (p as (Const ("RootRatEq.is'_rootRatAddTerm'_in",_) $ t $ v)) _ =
127.50 + if is_rootRatAddTerm_in t v then
127.51 + SOME ((term2str p) ^ " = True",
127.52 + Trueprop $ (mk_equality (p, HOLogic.true_const)))
127.53 + else SOME ((term2str p) ^ " = True",
127.54 + Trueprop $ (mk_equality (p, HOLogic.false_const)))
127.55 + | eval_is_rootRatAddTerm_in _ _ _ _ = ((*writeln"### nichts matcht";*) NONE);
127.56 +
127.57 +(*-------------------------rulse-------------------------*)
127.58 +val RootRatEq_prls =
127.59 + append_rls "RootRatEq_prls" e_rls
127.60 + [Calc ("Atools.ident",eval_ident "#ident_"),
127.61 + Calc ("Tools.matches",eval_matches ""),
127.62 + Calc ("Tools.lhs" ,eval_lhs ""),
127.63 + Calc ("Tools.rhs" ,eval_rhs ""),
127.64 + Calc ("RootEq.is'_rootTerm'_in",eval_is_rootTerm_in ""),
127.65 + Calc ("RootRatEq.is'_rootRatAddTerm'_in", eval_is_rootRatAddTerm_in ""),
127.66 + Calc ("op =",eval_equal "#equal_"),
127.67 + Thm ("not_true",num_str not_true),
127.68 + Thm ("not_false",num_str not_false),
127.69 + Thm ("and_true",num_str and_true),
127.70 + Thm ("and_false",num_str and_false),
127.71 + Thm ("or_true",num_str or_true),
127.72 + Thm ("or_false",num_str or_false)
127.73 + ];
127.74 +
127.75 +
127.76 +val RooRatEq_erls =
127.77 + merge_rls "RooRatEq_erls" rootrat_erls
127.78 + (merge_rls "" RootEq_erls
127.79 + (merge_rls "" rateq_erls
127.80 + (append_rls "" e_rls
127.81 + [])));
127.82 +
127.83 +val RootRatEq_crls =
127.84 + merge_rls "RootRatEq_crls" rootrat_erls
127.85 + (merge_rls "" RootEq_erls
127.86 + (merge_rls "" rateq_erls
127.87 + (append_rls "" e_rls
127.88 + [])));
127.89 +
127.90 +ruleset' := overwritelthy thy (!ruleset',
127.91 + [("RooRatEq_erls",RooRatEq_erls) (*FIXXXME:del with rls.rls'*)
127.92 + ]);
127.93 +
127.94 +(* Solves a rootrat Equation *)
127.95 + val rootrat_solve = prep_rls(
127.96 + Rls {id = "rootrat_solve", preconds = [],
127.97 + rew_ord = ("termlessI",termlessI),
127.98 + erls = e_rls, srls = Erls, calc = [], (*asm_thm = [],*)
127.99 + rules = [ Thm("rootrat_equation_left_1",num_str rootrat_equation_left_1),
127.100 + (* [|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c )) *)
127.101 + Thm("rootrat_equation_left_2",num_str rootrat_equation_left_2),
127.102 + (* [|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c )) *)
127.103 + Thm("rootrat_equation_right_1",num_str rootrat_equation_right_1),
127.104 + (* [|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e )) *)
127.105 + Thm("rootrat_equation_right_2",num_str rootrat_equation_right_2)
127.106 + (* [|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e )) *)
127.107 + ],
127.108 + scr = Script ((term_of o the o (parse thy)) "empty_script")
127.109 + }:rls);
127.110 +ruleset' := overwritelthy thy (!ruleset',
127.111 + [("rootrat_solve",rootrat_solve)
127.112 + ]);
127.113 +
127.114 +(*-----------------------probleme------------------------*)
127.115 +(*
127.116 +(get_pbt ["rat","root","univariate","equation"]);
127.117 +show_ptyps();
127.118 +*)
127.119 +store_pbt
127.120 + (prep_pbt RootRatEq.thy "pbl_equ_univ_root_sq_rat" [] e_pblID
127.121 + (["rat","sq","root","univariate","equation"],
127.122 + [("#Given" ,["equality e_","solveFor v_"]),
127.123 + ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) )| \
127.124 + \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]),
127.125 + ("#Find" ,["solutions v_i_"])
127.126 + ],
127.127 + RootRatEq_prls, SOME "solve (e_::bool, v_)",
127.128 + [["RootRatEq","elim_rootrat_equation"]]));
127.129 +
127.130 +(*-------------------------Methode-----------------------*)
127.131 +store_met
127.132 + (prep_met LinEq.thy "met_rootrateq" [] e_metID
127.133 + (["RootRatEq"],
127.134 + [],
127.135 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
127.136 + crls=Atools_erls, nrls=norm_Rational(*,
127.137 + asm_rls=[],asm_thm=[]*)}, "empty_script"));
127.138 +(*-- left 20.10.02 --*)
127.139 +store_met
127.140 + (prep_met RootRatEq.thy "met_rootrateq_elim" [] e_metID
127.141 + (["RootRatEq","elim_rootrat_equation"],
127.142 + [("#Given" ,["equality e_","solveFor v_"]),
127.143 + ("#Where" ,["( (lhs e_) is_rootRatAddTerm_in (v_::real) ) | \
127.144 + \( (rhs e_) is_rootRatAddTerm_in (v_::real) )"]),
127.145 + ("#Find" ,["solutions v_i_"])
127.146 + ],
127.147 + {rew_ord'="termlessI",
127.148 + rls'=RooRatEq_erls,
127.149 + srls=e_rls,
127.150 + prls=RootRatEq_prls,
127.151 + calc=[],
127.152 + crls=RootRatEq_crls, nrls=norm_Rational(*,
127.153 + asm_rls=[],
127.154 + asm_thm=[]*)},
127.155 + "Script Elim_rootrat_equation (e_::bool) (v_::real) = \
127.156 + \(let e_ = ((Try (Rewrite_Set expand_rootbinoms False)) @@ \
127.157 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
127.158 + \ (Try (Rewrite_Set make_rooteq False)) @@ \
127.159 + \ (Try (Rewrite_Set rooteq_simplify False)) @@ \
127.160 + \ (Try (Rewrite_Set_Inst [(bdv,v_)] \
127.161 + \ rootrat_solve False))) e_ \
127.162 + \ in (SubProblem (RootEq_,[univariate,equation], \
127.163 + \ [no_met]) [bool_ e_, real_ v_]))"
127.164 + ));
127.165 +calclist':= overwritel (!calclist',
127.166 + [("is_rootRatAddTerm_in", ("RootRatEq.is_rootRatAddTerm_in",
127.167 + eval_is_rootRatAddTerm_in""))
127.168 + ]);(*("", ("", "")),*)
127.169 +"******* RootRatEq.ML end *******";
128.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
128.2 +++ b/src/Tools/isac/Knowledge/RootRatEq.thy Wed Aug 25 16:20:07 2010 +0200
128.3 @@ -0,0 +1,48 @@
128.4 +(*.c) by Richard Lang, 2003 .*)
128.5 +(* collecting all knowledge for Root and Rational Equations
128.6 + created by: rlang
128.7 + date: 02.10
128.8 + changed by: rlang
128.9 + last change by: rlang
128.10 + date: 02.11.04
128.11 +*)
128.12 +
128.13 +(* use"knowledge/RootRatEq.ML";
128.14 + use"RootRatEq.ML";
128.15 +
128.16 + use"ROOT.ML";
128.17 + cd"knowledge";
128.18 +
128.19 + remove_thy"RootRatEq";
128.20 + use_thy"Isac";
128.21 + *)
128.22 +
128.23 +RootRatEq = RootEq + RatEq + RootRat +
128.24 +
128.25 +(*-------------------- consts-----------------------------------------------*)
128.26 +consts
128.27 +
128.28 + is'_rootRatAddTerm'_in :: [real, real] => bool ("_ is'_rootRatAddTerm'_in _") (*RL DA*)
128.29 +
128.30 +(*---------scripts--------------------------*)
128.31 + Elim'_rootrat'_equation
128.32 + :: "[bool,real, \
128.33 + \ bool list] => bool list"
128.34 + ("((Script Elim'_rootrat'_equation (_ _ =))// \
128.35 + \ (_))" 9)
128.36 + (*-------------------- rules------------------------------------------------*)
128.37 +rules
128.38 +
128.39 + (* eliminate ratRootTerm *)
128.40 + rootrat_equation_left_1
128.41 + "[|c is_rootTerm_in bdv|] ==> ( (a + b/c = d) = ( b = (d - a) * c ))"
128.42 + rootrat_equation_left_2
128.43 + "[|c is_rootTerm_in bdv|] ==> ( (b/c = d) = ( b = d * c ))"
128.44 + rootrat_equation_right_2
128.45 + "[|f is_rootTerm_in bdv|] ==> ( (a = d + e/f) = ( (a - d) * f = e ))"
128.46 + rootrat_equation_right_1
128.47 + "[|f is_rootTerm_in bdv|] ==> ( (a = e/f) = ( a * f = e ))"
128.48 +
128.49 +
128.50 +
128.51 +end
129.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
129.2 +++ b/src/Tools/isac/Knowledge/Simplify.ML Wed Aug 25 16:20:07 2010 +0200
129.3 @@ -0,0 +1,76 @@
129.4 +(* simplification of terms
129.5 + author: Walther Neuper 050912
129.6 + (c) due to copyright terms
129.7 +
129.8 +use"Knowledge/Simplify.ML";
129.9 +use"Simplify.ML";
129.10 +*)
129.11 +
129.12 +
129.13 +(** interface isabelle -- isac **)
129.14 +
129.15 +theory' := overwritel (!theory', [("Simplify.thy",Simplify.thy)]);
129.16 +
129.17 +(** problems **)
129.18 +
129.19 +store_pbt
129.20 + (prep_pbt Simplify.thy "pbl_simp" [] e_pblID
129.21 + (["simplification"],
129.22 + [("#Given" ,["term t_"]),
129.23 + ("#Find" ,["normalform n_"])
129.24 + ],
129.25 + append_rls "e_rls" e_rls [(*for preds in where_*)],
129.26 + SOME "Simplify t_",
129.27 + []));
129.28 +
129.29 +store_pbt
129.30 + (prep_pbt Simplify.thy "pbl_vereinfache" [] e_pblID
129.31 + (["vereinfachen"],
129.32 + [("#Given" ,["term t_"]),
129.33 + ("#Find" ,["normalform n_"])
129.34 + ],
129.35 + append_rls "e_rls" e_rls [(*for preds in where_*)],
129.36 + SOME "Vereinfache t_",
129.37 + []));
129.38 +
129.39 +(** methods **)
129.40 +
129.41 +store_met
129.42 + (prep_met Simplify.thy "met_simp" [] e_metID
129.43 + (["simplification"],
129.44 + [("#Given" ,["term t_"]),
129.45 + ("#Find" ,["normalform n_"])
129.46 + ],
129.47 + {rew_ord'="tless_true",
129.48 + rls'= e_rls,
129.49 + calc = [],
129.50 + srls = e_rls,
129.51 + prls=e_rls,
129.52 + crls = e_rls, nrls = e_rls},
129.53 + "empty_script"
129.54 + ));
129.55 +
129.56 +(** CAS-command **)
129.57 +
129.58 +(*.function for handling the cas-input "Simplify (2*a + 3*a)":
129.59 + make a model which is already in ptree-internal format.*)
129.60 +(* val (h,argl) = strip_comb (str2term "Simplify (2*a + 3*a)");
129.61 + val (h,argl) = strip_comb ((term_of o the o (parse thy))
129.62 + "Simplify (2*a + 3*a)");
129.63 + *)
129.64 +fun argl2dtss t =
129.65 + [((term_of o the o (parse thy)) "term", t),
129.66 + ((term_of o the o (parse thy)) "normalform",
129.67 + [(term_of o the o (parse thy)) "N"])
129.68 + ]
129.69 + | argl2dtss _ = raise error "Simplify.ML: wrong argument for argl2dtss";
129.70 +
129.71 +castab :=
129.72 +overwritel (!castab,
129.73 + [((term_of o the o (parse thy)) "Simplify",
129.74 + (("Isac.thy", ["simplification"], ["no_met"]),
129.75 + argl2dtss)),
129.76 + ((term_of o the o (parse thy)) "Vereinfache",
129.77 + (("Isac.thy", ["vereinfachen"], ["no_met"]),
129.78 + argl2dtss))
129.79 + ]);
130.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
130.2 +++ b/src/Tools/isac/Knowledge/Simplify.thy Wed Aug 25 16:20:07 2010 +0200
130.3 @@ -0,0 +1,29 @@
130.4 +(* simplification of terms
130.5 + author: Walther Neuper 050912
130.6 + (c) due to copyright terms
130.7 +
130.8 +remove_thy"Simplify";
130.9 +use_thy"~/proto2/isac/src/sml/Knowledge/Simplify";
130.10 +
130.11 +use_thy_only"~/proto2/isac/src/sml/Knowledge/Simplify";
130.12 +use_thy"~/proto2/isac/src/sml/Knowledge/Isac";
130.13 +*)
130.14 +
130.15 +Simplify = Atools +
130.16 +
130.17 +consts
130.18 +
130.19 + (*descriptions in the related problem*)
130.20 + term :: real => una
130.21 + normalform :: real => una
130.22 +
130.23 + (*the CAS-command*)
130.24 + Simplify :: "real => real" (*"Simplify (1+2a+3+4a)*)
130.25 + Vereinfache :: "real => real" (*"Vereinfache (1+2a+3+4a)*)
130.26 +
130.27 + (*Script-name*)
130.28 + SimplifyScript :: "[real, real] => real"
130.29 + ("((Script SimplifyScript (_ =))// (_))" 9)
130.30 +
130.31 +
130.32 +end
130.33 \ No newline at end of file
131.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
131.2 +++ b/src/Tools/isac/Knowledge/Test.ML Wed Aug 25 16:20:07 2010 +0200
131.3 @@ -0,0 +1,1301 @@
131.4 +(* SML functions for rational arithmetic
131.5 + WN.22.10.99
131.6 + use"../knowledge/Test.ML";
131.7 + use"Knowledge/Test.ML";
131.8 + use"Test.ML";
131.9 + *)
131.10 +
131.11 +
131.12 +(** interface isabelle -- isac **)
131.13 +
131.14 +theory' := overwritel (!theory', [("Test.thy",Test.thy)]);
131.15 +
131.16 +(** evaluation of numerals and predicates **)
131.17 +
131.18 +(*does a term contain a root ?*)
131.19 +fun eval_root_free (thmid:string) _ (t as (Const(op0,t0) $ arg)) thy =
131.20 + if strip_thy op0 <> "is'_root'_free"
131.21 + then raise error ("eval_root_free: wrong "^op0)
131.22 + else if const_in (strip_thy op0) arg
131.23 + then SOME (mk_thmid thmid ""
131.24 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
131.25 + Trueprop $ (mk_equality (t, false_as_term)))
131.26 + else SOME (mk_thmid thmid ""
131.27 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
131.28 + Trueprop $ (mk_equality (t, true_as_term)))
131.29 + | eval_root_free _ _ _ _ = NONE;
131.30 +
131.31 +(*does a term contain a root ?*)
131.32 +fun eval_contains_root (thmid:string) _
131.33 + (t as (Const("Test.contains'_root",t0) $ arg)) thy =
131.34 + if member op = (ids_of arg) "sqrt"
131.35 + then SOME (mk_thmid thmid ""
131.36 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
131.37 + Trueprop $ (mk_equality (t, true_as_term)))
131.38 + else SOME (mk_thmid thmid ""
131.39 + ((Syntax.string_of_term (thy2ctxt thy)) arg) "",
131.40 + Trueprop $ (mk_equality (t, false_as_term)))
131.41 + | eval_contains_root _ _ _ _ = NONE;
131.42 +
131.43 +calclist':= overwritel (!calclist',
131.44 + [("is_root_free", ("Test.is'_root'_free",
131.45 + eval_root_free"#is_root_free_")),
131.46 + ("contains_root", ("Test.contains'_root",
131.47 + eval_contains_root"#contains_root_"))
131.48 + ]);
131.49 +
131.50 +(** term order **)
131.51 +fun term_order (_:subst) tu = (term_ordI [] tu = LESS);
131.52 +
131.53 +(** rule sets **)
131.54 +
131.55 +val testerls =
131.56 + Rls {id = "testerls", preconds = [], rew_ord = ("termlessI",termlessI),
131.57 + erls = e_rls, srls = Erls,
131.58 + calc = [],
131.59 + rules = [Thm ("refl",num_str refl),
131.60 + Thm ("le_refl",num_str le_refl),
131.61 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
131.62 + Thm ("not_true",num_str not_true),
131.63 + Thm ("not_false",num_str not_false),
131.64 + Thm ("and_true",and_true),
131.65 + Thm ("and_false",and_false),
131.66 + Thm ("or_true",or_true),
131.67 + Thm ("or_false",or_false),
131.68 + Thm ("and_commute",num_str and_commute),
131.69 + Thm ("or_commute",num_str or_commute),
131.70 +
131.71 + Calc ("Atools.is'_const",eval_const "#is_const_"),
131.72 + Calc ("Tools.matches",eval_matches ""),
131.73 +
131.74 + Calc ("op +",eval_binop "#add_"),
131.75 + Calc ("op *",eval_binop "#mult_"),
131.76 + Calc ("Atools.pow" ,eval_binop "#power_"),
131.77 +
131.78 + Calc ("op <",eval_equ "#less_"),
131.79 + Calc ("op <=",eval_equ "#less_equal_"),
131.80 +
131.81 + Calc ("Atools.ident",eval_ident "#ident_")],
131.82 + scr = Script ((term_of o the o (parse thy))
131.83 + "empty_script")
131.84 + }:rls;
131.85 +
131.86 +(*.for evaluation of conditions in rewrite rules.*)
131.87 +(*FIXXXXXXME 10.8.02: handle like _simplify*)
131.88 +val tval_rls =
131.89 + Rls{id = "tval_rls", preconds = [],
131.90 + rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")),
131.91 + erls=testerls,srls = e_rls,
131.92 + calc=[],
131.93 + rules = [Thm ("refl",num_str refl),
131.94 + Thm ("le_refl",num_str le_refl),
131.95 + Thm ("radd_left_cancel_le",num_str radd_left_cancel_le),
131.96 + Thm ("not_true",num_str not_true),
131.97 + Thm ("not_false",num_str not_false),
131.98 + Thm ("and_true",and_true),
131.99 + Thm ("and_false",and_false),
131.100 + Thm ("or_true",or_true),
131.101 + Thm ("or_false",or_false),
131.102 + Thm ("and_commute",num_str and_commute),
131.103 + Thm ("or_commute",num_str or_commute),
131.104 +
131.105 + Thm ("real_diff_minus",num_str real_diff_minus),
131.106 +
131.107 + Thm ("root_ge0",num_str root_ge0),
131.108 + Thm ("root_add_ge0",num_str root_add_ge0),
131.109 + Thm ("root_ge0_1",num_str root_ge0_1),
131.110 + Thm ("root_ge0_2",num_str root_ge0_2),
131.111 +
131.112 + Calc ("Atools.is'_const",eval_const "#is_const_"),
131.113 + Calc ("Test.is'_root'_free",eval_root_free "#is_root_free_"),
131.114 + Calc ("Tools.matches",eval_matches ""),
131.115 + Calc ("Test.contains'_root",
131.116 + eval_contains_root"#contains_root_"),
131.117 +
131.118 + Calc ("op +",eval_binop "#add_"),
131.119 + Calc ("op *",eval_binop "#mult_"),
131.120 + Calc ("Root.sqrt",eval_sqrt "#sqrt_"),
131.121 + Calc ("Atools.pow" ,eval_binop "#power_"),
131.122 +
131.123 + Calc ("op <",eval_equ "#less_"),
131.124 + Calc ("op <=",eval_equ "#less_equal_"),
131.125 +
131.126 + Calc ("Atools.ident",eval_ident "#ident_")],
131.127 + scr = Script ((term_of o the o (parse thy))
131.128 + "empty_script")
131.129 + }:rls;
131.130 +
131.131 +
131.132 +ruleset' := overwritelthy thy (!ruleset',
131.133 + [("testerls", prep_rls testerls)
131.134 + ]);
131.135 +
131.136 +
131.137 +(*make () dissappear*)
131.138 +val rearrange_assoc =
131.139 + Rls{id = "rearrange_assoc", preconds = [],
131.140 + rew_ord = ("e_rew_ord",e_rew_ord),
131.141 + erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*)
131.142 + rules =
131.143 + [Thm ("sym_radd_assoc",num_str (radd_assoc RS sym)),
131.144 + Thm ("sym_rmult_assoc",num_str (rmult_assoc RS sym))],
131.145 + scr = Script ((term_of o the o (parse thy))
131.146 + "empty_script")
131.147 + }:rls;
131.148 +
131.149 +val ac_plus_times =
131.150 + Rls{id = "ac_plus_times", preconds = [], rew_ord = ("term_order",term_order),
131.151 + erls = e_rls, srls = e_rls, calc = [], (*asm_thm=[],*)
131.152 + rules =
131.153 + [Thm ("radd_commute",radd_commute),
131.154 + Thm ("radd_left_commute",radd_left_commute),
131.155 + Thm ("radd_assoc",radd_assoc),
131.156 + Thm ("rmult_commute",rmult_commute),
131.157 + Thm ("rmult_left_commute",rmult_left_commute),
131.158 + Thm ("rmult_assoc",rmult_assoc)],
131.159 + scr = Script ((term_of o the o (parse thy))
131.160 + "empty_script")
131.161 + }:rls;
131.162 +
131.163 +(*todo: replace by Rewrite("rnorm_equation_add",num_str rnorm_equation_add)*)
131.164 +val norm_equation =
131.165 + Rls{id = "norm_equation", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
131.166 + erls = tval_rls, srls = e_rls, calc = [], (*asm_thm=[],*)
131.167 + rules = [Thm ("rnorm_equation_add",num_str rnorm_equation_add)
131.168 + ],
131.169 + scr = Script ((term_of o the o (parse thy))
131.170 + "empty_script")
131.171 + }:rls;
131.172 +
131.173 +(** rule sets **)
131.174 +
131.175 +val STest_simplify = (* vv--- not changed to real by parse*)
131.176 + "Script STest_simplify (t_::'z) = \
131.177 + \(Repeat\
131.178 + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
131.179 + \ (Try (Repeat (Rewrite radd_mult_distrib2 False))) @@ \
131.180 + \ (Try (Repeat (Rewrite rdistr_right_assoc False))) @@ \
131.181 + \ (Try (Repeat (Rewrite rdistr_right_assoc_p False))) @@\
131.182 + \ (Try (Repeat (Rewrite rdistr_div_right False))) @@ \
131.183 + \ (Try (Repeat (Rewrite rbinom_power_2 False))) @@ \
131.184 +
131.185 + \ (Try (Repeat (Rewrite radd_commute False))) @@ \
131.186 + \ (Try (Repeat (Rewrite radd_left_commute False))) @@ \
131.187 + \ (Try (Repeat (Rewrite radd_assoc False))) @@ \
131.188 + \ (Try (Repeat (Rewrite rmult_commute False))) @@ \
131.189 + \ (Try (Repeat (Rewrite rmult_left_commute False))) @@ \
131.190 + \ (Try (Repeat (Rewrite rmult_assoc False))) @@ \
131.191 +
131.192 + \ (Try (Repeat (Rewrite radd_real_const_eq False))) @@ \
131.193 + \ (Try (Repeat (Rewrite radd_real_const False))) @@ \
131.194 + \ (Try (Repeat (Calculate plus))) @@ \
131.195 + \ (Try (Repeat (Calculate times))) @@ \
131.196 + \ (Try (Repeat (Calculate divide_))) @@\
131.197 + \ (Try (Repeat (Calculate power_))) @@ \
131.198 +
131.199 + \ (Try (Repeat (Rewrite rcollect_right False))) @@ \
131.200 + \ (Try (Repeat (Rewrite rcollect_one_left False))) @@ \
131.201 + \ (Try (Repeat (Rewrite rcollect_one_left_assoc False))) @@ \
131.202 + \ (Try (Repeat (Rewrite rcollect_one_left_assoc_p False))) @@ \
131.203 +
131.204 + \ (Try (Repeat (Rewrite rshift_nominator False))) @@ \
131.205 + \ (Try (Repeat (Rewrite rcancel_den False))) @@ \
131.206 + \ (Try (Repeat (Rewrite rroot_square_inv False))) @@ \
131.207 + \ (Try (Repeat (Rewrite rroot_times_root False))) @@ \
131.208 + \ (Try (Repeat (Rewrite rroot_times_root_assoc_p False))) @@ \
131.209 + \ (Try (Repeat (Rewrite rsqare False))) @@ \
131.210 + \ (Try (Repeat (Rewrite power_1 False))) @@ \
131.211 + \ (Try (Repeat (Rewrite rtwo_of_the_same False))) @@ \
131.212 + \ (Try (Repeat (Rewrite rtwo_of_the_same_assoc_p False))) @@ \
131.213 +
131.214 + \ (Try (Repeat (Rewrite rmult_1 False))) @@ \
131.215 + \ (Try (Repeat (Rewrite rmult_1_right False))) @@ \
131.216 + \ (Try (Repeat (Rewrite rmult_0 False))) @@ \
131.217 + \ (Try (Repeat (Rewrite rmult_0_right False))) @@ \
131.218 + \ (Try (Repeat (Rewrite radd_0 False))) @@ \
131.219 + \ (Try (Repeat (Rewrite radd_0_right False)))) \
131.220 + \ t_)";
131.221 +
131.222 +
131.223 +(* expects * distributed over + *)
131.224 +val Test_simplify =
131.225 + Rls{id = "Test_simplify", preconds = [],
131.226 + rew_ord = ("sqrt_right",sqrt_right false (theory "Pure")),
131.227 + erls = tval_rls, srls = e_rls,
131.228 + calc=[(*since 040209 filled by prep_rls*)],
131.229 + (*asm_thm = [],*)
131.230 + rules = [
131.231 + Thm ("real_diff_minus",num_str real_diff_minus),
131.232 + Thm ("radd_mult_distrib2",num_str radd_mult_distrib2),
131.233 + Thm ("rdistr_right_assoc",num_str rdistr_right_assoc),
131.234 + Thm ("rdistr_right_assoc_p",num_str rdistr_right_assoc_p),
131.235 + Thm ("rdistr_div_right",num_str rdistr_div_right),
131.236 + Thm ("rbinom_power_2",num_str rbinom_power_2),
131.237 +
131.238 + Thm ("radd_commute",num_str radd_commute),
131.239 + Thm ("radd_left_commute",num_str radd_left_commute),
131.240 + Thm ("radd_assoc",num_str radd_assoc),
131.241 + Thm ("rmult_commute",num_str rmult_commute),
131.242 + Thm ("rmult_left_commute",num_str rmult_left_commute),
131.243 + Thm ("rmult_assoc",num_str rmult_assoc),
131.244 +
131.245 + Thm ("radd_real_const_eq",num_str radd_real_const_eq),
131.246 + Thm ("radd_real_const",num_str radd_real_const),
131.247 + (* these 2 rules are invers to distr_div_right wrt. termination.
131.248 + thus they MUST be done IMMEDIATELY before calc *)
131.249 + Calc ("op +", eval_binop "#add_"),
131.250 + Calc ("op *", eval_binop "#mult_"),
131.251 + Calc ("HOL.divide", eval_cancel "#divide_"),
131.252 + Calc ("Atools.pow", eval_binop "#power_"),
131.253 +
131.254 + Thm ("rcollect_right",num_str rcollect_right),
131.255 + Thm ("rcollect_one_left",num_str rcollect_one_left),
131.256 + Thm ("rcollect_one_left_assoc",num_str rcollect_one_left_assoc),
131.257 + Thm ("rcollect_one_left_assoc_p",num_str rcollect_one_left_assoc_p),
131.258 +
131.259 + Thm ("rshift_nominator",num_str rshift_nominator),
131.260 + Thm ("rcancel_den",num_str rcancel_den),
131.261 + Thm ("rroot_square_inv",num_str rroot_square_inv),
131.262 + Thm ("rroot_times_root",num_str rroot_times_root),
131.263 + Thm ("rroot_times_root_assoc_p",num_str rroot_times_root_assoc_p),
131.264 + Thm ("rsqare",num_str rsqare),
131.265 + Thm ("power_1",num_str power_1),
131.266 + Thm ("rtwo_of_the_same",num_str rtwo_of_the_same),
131.267 + Thm ("rtwo_of_the_same_assoc_p",num_str rtwo_of_the_same_assoc_p),
131.268 +
131.269 + Thm ("rmult_1",num_str rmult_1),
131.270 + Thm ("rmult_1_right",num_str rmult_1_right),
131.271 + Thm ("rmult_0",num_str rmult_0),
131.272 + Thm ("rmult_0_right",num_str rmult_0_right),
131.273 + Thm ("radd_0",num_str radd_0),
131.274 + Thm ("radd_0_right",num_str radd_0_right)
131.275 + ],
131.276 + scr = Script ((term_of o the o (parse thy)) "empty_script")
131.277 + (*since 040209 filled by prep_rls: STest_simplify*)
131.278 + }:rls;
131.279 +
131.280 +
131.281 +
131.282 +
131.283 +
131.284 +(** rule sets **)
131.285 +
131.286 +
131.287 +
131.288 +(*isolate the root in a root-equation*)
131.289 +val isolate_root =
131.290 + Rls{id = "isolate_root", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
131.291 + erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *)
131.292 + rules = [Thm ("rroot_to_lhs",num_str rroot_to_lhs),
131.293 + Thm ("rroot_to_lhs_mult",num_str rroot_to_lhs_mult),
131.294 + Thm ("rroot_to_lhs_add_mult",num_str rroot_to_lhs_add_mult),
131.295 + Thm ("risolate_root_add",num_str risolate_root_add),
131.296 + Thm ("risolate_root_mult",num_str risolate_root_mult),
131.297 + Thm ("risolate_root_div",num_str risolate_root_div) ],
131.298 + scr = Script ((term_of o the o (parse thy))
131.299 + "empty_script")
131.300 + }:rls;
131.301 +
131.302 +(*isolate the bound variable in an equation; 'bdv' is a meta-constant*)
131.303 +val isolate_bdv =
131.304 + Rls{id = "isolate_bdv", preconds = [], rew_ord = ("e_rew_ord",e_rew_ord),
131.305 + erls=tval_rls,srls = e_rls, calc=[],(*asm_thm = [], *)
131.306 + rules =
131.307 + [Thm ("risolate_bdv_add",num_str risolate_bdv_add),
131.308 + Thm ("risolate_bdv_mult_add",num_str risolate_bdv_mult_add),
131.309 + Thm ("risolate_bdv_mult",num_str risolate_bdv_mult),
131.310 + Thm ("mult_square",num_str mult_square),
131.311 + Thm ("constant_square",num_str constant_square),
131.312 + Thm ("constant_mult_square",num_str constant_mult_square)
131.313 + ],
131.314 + scr = Script ((term_of o the o (parse thy))
131.315 + "empty_script")
131.316 + }:rls;
131.317 +
131.318 +
131.319 +
131.320 +
131.321 +(* association list for calculate_, calculate
131.322 + "op +" etc. not usable in scripts *)
131.323 +val calclist =
131.324 + [
131.325 + (*as Tools.ML*)
131.326 + ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")),
131.327 + ("matches",("Tools.matches",eval_matches "#matches_")),
131.328 + ("lhs" ,("Tools.lhs" ,eval_lhs "")),
131.329 + (*aus Atools.ML*)
131.330 + ("PLUS" ,("op +" ,eval_binop "#add_")),
131.331 + ("TIMES" ,("op *" ,eval_binop "#mult_")),
131.332 + ("DIVIDE" ,("HOL.divide" ,eval_cancel "#divide_")),
131.333 + ("POWER" ,("Atools.pow" ,eval_binop "#power_")),
131.334 + ("is_const",("Atools.is'_const",eval_const "#is_const_")),
131.335 + ("le" ,("op <" ,eval_equ "#less_")),
131.336 + ("leq" ,("op <=" ,eval_equ "#less_equal_")),
131.337 + ("ident" ,("Atools.ident",eval_ident "#ident_")),
131.338 + (*von hier (ehem.SqRoot*)
131.339 + ("sqrt" ,("Root.sqrt" ,eval_sqrt "#sqrt_")),
131.340 + ("Test.is_root_free",("is'_root'_free", eval_root_free"#is_root_free_")),
131.341 + ("Test.contains_root",("contains'_root",
131.342 + eval_contains_root"#contains_root_"))
131.343 + ];
131.344 +
131.345 +ruleset' := overwritelthy thy (!ruleset',
131.346 + [("Test_simplify", prep_rls Test_simplify),
131.347 + ("tval_rls", prep_rls tval_rls),
131.348 + ("isolate_root", prep_rls isolate_root),
131.349 + ("isolate_bdv", prep_rls isolate_bdv),
131.350 + ("matches",
131.351 + prep_rls (append_rls "matches" testerls
131.352 + [Calc ("Tools.matches",eval_matches "#matches_")]))
131.353 + ]);
131.354 +
131.355 +(** problem types **)
131.356 +store_pbt
131.357 + (prep_pbt Test.thy "pbl_test" [] e_pblID
131.358 + (["test"],
131.359 + [],
131.360 + e_rls, NONE, []));
131.361 +store_pbt
131.362 + (prep_pbt Test.thy "pbl_test_equ" [] e_pblID
131.363 + (["equation","test"],
131.364 + [("#Given" ,["equality e_","solveFor v_"]),
131.365 + ("#Where" ,["matches (?a = ?b) e_"]),
131.366 + ("#Find" ,["solutions v_i_"])
131.367 + ],
131.368 + assoc_rls "matches",
131.369 + SOME "solve (e_::bool, v_)", []));
131.370 +
131.371 +store_pbt
131.372 + (prep_pbt Test.thy "pbl_test_uni" [] e_pblID
131.373 + (["univariate","equation","test"],
131.374 + [("#Given" ,["equality e_","solveFor v_"]),
131.375 + ("#Where" ,["matches (?a = ?b) e_"]),
131.376 + ("#Find" ,["solutions v_i_"])
131.377 + ],
131.378 + assoc_rls "matches",
131.379 + SOME "solve (e_::bool, v_)", []));
131.380 +
131.381 +store_pbt
131.382 + (prep_pbt Test.thy "pbl_test_uni_lin" [] e_pblID
131.383 + (["linear","univariate","equation","test"],
131.384 + [("#Given" ,["equality e_","solveFor v_"]),
131.385 + ("#Where" ,["(matches ( v_ = 0) e_) | (matches ( ?b*v_ = 0) e_) |\
131.386 + \(matches (?a+v_ = 0) e_) | (matches (?a+?b*v_ = 0) e_) "]),
131.387 + ("#Find" ,["solutions v_i_"])
131.388 + ],
131.389 + assoc_rls "matches",
131.390 + SOME "solve (e_::bool, v_)", [["Test","solve_linear"]]));
131.391 +
131.392 +(*25.8.01 ------
131.393 +store_pbt
131.394 + (prep_pbt Test.thy
131.395 + (["Test.thy"],
131.396 + [("#Given" ,"boolTestGiven g_"),
131.397 + ("#Find" ,"boolTestFind f_")
131.398 + ],
131.399 + []));
131.400 +
131.401 +store_pbt
131.402 + (prep_pbt Test.thy
131.403 + (["testeq","Test.thy"],
131.404 + [("#Given" ,"boolTestGiven g_"),
131.405 + ("#Find" ,"boolTestFind f_")
131.406 + ],
131.407 + []));
131.408 +
131.409 +
131.410 +val ttt = (term_of o the o (parse Isac.thy)) "(matches ( v_ = 0) e_)";
131.411 +
131.412 + ------ 25.8.01*)
131.413 +
131.414 +
131.415 +(** methods **)
131.416 +store_met
131.417 + (prep_met Diff.thy "met_test" [] e_metID
131.418 + (["Test"],
131.419 + [],
131.420 + {rew_ord'="tless_true",rls'=Atools_erls,calc = [], srls = e_rls, prls=e_rls,
131.421 + crls=Atools_erls, nrls=e_rls(*,
131.422 + asm_rls=[],asm_thm=[]*)}, "empty_script"));
131.423 +(*
131.424 +store_met
131.425 + (prep_met Script.thy
131.426 + (e_metID,(*empty method*)
131.427 + [],
131.428 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
131.429 + asm_rls=[],asm_thm=[]},
131.430 + "Undef"));*)
131.431 +store_met
131.432 + (prep_met Test.thy "met_test_solvelin" [] e_metID
131.433 + (["Test","solve_linear"]:metID,
131.434 + [("#Given" ,["equality e_","solveFor v_"]),
131.435 + ("#Where" ,["matches (?a = ?b) e_"]),
131.436 + ("#Find" ,["solutions v_i_"])
131.437 + ],
131.438 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,
131.439 + prls=assoc_rls "matches",
131.440 + calc=[],
131.441 + crls=tval_rls, nrls=Test_simplify},
131.442 + "Script Solve_linear (e_::bool) (v_::real)= \
131.443 + \(let e_ =\
131.444 + \ Repeat\
131.445 + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
131.446 + \ (Rewrite_Set Test_simplify False))) e_\
131.447 + \ in [e_::bool])"
131.448 + )
131.449 +(*, prep_met Test.thy (*test for equations*)
131.450 + (["Test","testeq"]:metID,
131.451 + [("#Given" ,["boolTestGiven g_"]),
131.452 + ("#Find" ,["boolTestFind f_"])
131.453 + ],
131.454 + {rew_ord'="e_rew_ord",rls'="tval_rls",asm_rls=[],
131.455 + asm_thm=[("square_equation_left","")]},
131.456 + "Script Testeq (eq_::bool) = \
131.457 + \Repeat \
131.458 + \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False eq_)); \
131.459 + \ e_ = Try (Repeat (Rewrite square_equation_left True e_)); \
131.460 + \ e_ = Try (Repeat (Rewrite rmult_0 False e_)) \
131.461 + \ in e_) Until (is_root_free e_)" (*deleted*)
131.462 + )
131.463 +, ---------27.4.02*)
131.464 +);
131.465 +
131.466 +
131.467 +
131.468 +
131.469 +ruleset' := overwritelthy thy (!ruleset',
131.470 + [("norm_equation", prep_rls norm_equation),
131.471 + ("ac_plus_times", prep_rls ac_plus_times),
131.472 + ("rearrange_assoc", prep_rls rearrange_assoc)
131.473 + ]);
131.474 +
131.475 +
131.476 +fun bin_o (Const (op_,(Type ("fun",
131.477 + [Type (s2,[]),Type ("fun",
131.478 + [Type (s4,tl4),Type (s5,tl5)])])))) =
131.479 + if (s2=s4)andalso(s4=s5)then[op_]else[]
131.480 + | bin_o _ = [];
131.481 +
131.482 +fun bin_op (t1 $ t2) = union op = (bin_op t1) (bin_op t2)
131.483 + | bin_op t = bin_o t;
131.484 +fun is_bin_op t = ((bin_op t)<>[]);
131.485 +
131.486 +fun bin_op_arg1 ((Const (op_,(Type ("fun",
131.487 + [Type (s2,[]),Type ("fun",
131.488 + [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) =
131.489 + arg1;
131.490 +fun bin_op_arg2 ((Const (op_,(Type ("fun",
131.491 + [Type (s2,[]),Type ("fun",
131.492 + [Type (s4,tl4),Type (s5,tl5)])]))))$ arg1 $ arg2) =
131.493 + arg2;
131.494 +
131.495 +
131.496 +exception NO_EQUATION_TERM;
131.497 +fun is_equation ((Const ("op =",(Type ("fun",
131.498 + [Type (_,[]),Type ("fun",
131.499 + [Type (_,[]),Type ("bool",[])])])))) $ _ $ _)
131.500 + = true
131.501 + | is_equation _ = false;
131.502 +fun equ_lhs ((Const ("op =",(Type ("fun",
131.503 + [Type (_,[]),Type ("fun",
131.504 + [Type (_,[]),Type ("bool",[])])])))) $ l $ r)
131.505 + = l
131.506 + | equ_lhs _ = raise NO_EQUATION_TERM;
131.507 +fun equ_rhs ((Const ("op =",(Type ("fun",
131.508 + [Type (_,[]),Type ("fun",
131.509 + [Type (_,[]),Type ("bool",[])])])))) $ l $ r)
131.510 + = r
131.511 + | equ_rhs _ = raise NO_EQUATION_TERM;
131.512 +
131.513 +
131.514 +fun atom (Const (_,Type (_,[]))) = true
131.515 + | atom (Free (_,Type (_,[]))) = true
131.516 + | atom (Var (_,Type (_,[]))) = true
131.517 +(*| atom (_ (_,"?DUMMY" )) = true ..ML-error *)
131.518 + | atom((Const ("Bin.integ_of_bin",_)) $ _) = true
131.519 + | atom _ = false;
131.520 +
131.521 +fun varids (Const (s,Type (_,[]))) = [strip_thy s]
131.522 + | varids (Free (s,Type (_,[]))) = if is_no s then []
131.523 + else [strip_thy s]
131.524 + | varids (Var((s,_),Type (_,[]))) = [strip_thy s]
131.525 +(*| varids (_ (s,"?DUMMY" )) = ..ML-error *)
131.526 + | varids((Const ("Bin.integ_of_bin",_)) $ _)= [](*8.01: superfluous?*)
131.527 + | varids (Abs(a,T,t)) = union op = [a] (varids t)
131.528 + | varids (t1 $ t2) = union op = (varids t1) (varids t2)
131.529 + | varids _ = [];
131.530 +(*> val t = term_of (hd (parse Diophant.thy "x"));
131.531 +val t = Free ("x","?DUMMY") : term
131.532 +> varids t;
131.533 +val it = [] : string list [] !!! *)
131.534 +
131.535 +
131.536 +fun bin_ops_only ((Const op_) $ t1 $ t2) =
131.537 + if(is_bin_op (Const op_))
131.538 + then(bin_ops_only t1)andalso(bin_ops_only t2)
131.539 + else false
131.540 + | bin_ops_only t =
131.541 + if atom t then true else bin_ops_only t;
131.542 +
131.543 +fun polynomial opl t bdVar = (* bdVar TODO *)
131.544 + subset op = (bin_op t, opl) andalso (bin_ops_only t);
131.545 +
131.546 +fun poly_equ opl bdVar t = is_equation t (* bdVar TODO *)
131.547 + andalso polynomial opl (equ_lhs t) bdVar
131.548 + andalso polynomial opl (equ_rhs t) bdVar
131.549 + andalso (subset op = (varids bdVar, varids (equ_lhs t)) orelse
131.550 + subset op = (varids bdVar, varids (equ_lhs t)));
131.551 +
131.552 +(*fun max is =
131.553 + let fun max_ m [] = m
131.554 + | max_ m (i::is) = if m<i then max_ i is else max_ m is;
131.555 + in max_ (hd is) is end;
131.556 +> max [1,5,3,7,4,2];
131.557 +val it = 7 : int *)
131.558 +
131.559 +fun max (a,b) = if a < b then b else a;
131.560 +
131.561 +fun degree addl mul bdVar t =
131.562 +let
131.563 +fun deg _ _ v (Const (s,Type (_,[]))) = if v=strip_thy s then 1 else 0
131.564 + | deg _ _ v (Free (s,Type (_,[]))) = if v=strip_thy s then 1 else 0
131.565 + | deg _ _ v (Var((s,_),Type (_,[]))) = if v=strip_thy s then 1 else 0
131.566 +(*| deg _ _ v (_ (s,"?DUMMY" )) = ..ML-error *)
131.567 + | deg _ _ v((Const ("Bin.integ_of_bin",_)) $ _ )= 0
131.568 + | deg addl mul v (h $ t1 $ t2) =
131.569 + if subset op = (bin_op h, addl)
131.570 + then max (deg addl mul v t1 ,deg addl mul v t2)
131.571 + else (*mul!*)(deg addl mul v t1)+(deg addl mul v t2)
131.572 +in if polynomial (addl @ [mul]) t bdVar
131.573 + then SOME (deg addl mul (id_of bdVar) t) else (NONE:int option)
131.574 +end;
131.575 +fun degree_ addl mul bdVar t = (* do not export *)
131.576 + let fun opt (SOME i)= i
131.577 + | opt NONE = 0
131.578 +in opt (degree addl mul bdVar t) end;
131.579 +
131.580 +
131.581 +fun linear addl mul t bdVar = (degree_ addl mul bdVar t)<2;
131.582 +
131.583 +fun linear_equ addl mul bdVar t =
131.584 + if is_equation t
131.585 + then let val degl = degree_ addl mul bdVar (equ_lhs t);
131.586 + val degr = degree_ addl mul bdVar (equ_rhs t)
131.587 + in if (degl>0 orelse degr>0)andalso max(degl,degr)<2
131.588 + then true else false
131.589 + end
131.590 + else false;
131.591 +(* strip_thy op_ before *)
131.592 +fun is_div_op (dv,(Const (op_,(Type ("fun",
131.593 + [Type (s2,[]),Type ("fun",
131.594 + [Type (s4,tl4),Type (s5,tl5)])])))) )= (dv = strip_thy op_)
131.595 + | is_div_op _ = false;
131.596 +
131.597 +fun is_denom bdVar div_op t =
131.598 + let fun is bool[v]dv (Const (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
131.599 + | is bool[v]dv (Free (s,Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
131.600 + | is bool[v]dv (Var((s,_),Type(_,[])))= bool andalso(if v=strip_thy s then true else false)
131.601 + | is bool[v]dv((Const ("Bin.integ_of_bin",_)) $ _) = false
131.602 + | is bool[v]dv (h$n$d) =
131.603 + if is_div_op(dv,h)
131.604 + then (is false[v]dv n)orelse(is true[v]dv d)
131.605 + else (is bool [v]dv n)orelse(is bool[v]dv d)
131.606 +in is false (varids bdVar) (strip_thy div_op) t end;
131.607 +
131.608 +
131.609 +fun rational t div_op bdVar =
131.610 + is_denom bdVar div_op t andalso bin_ops_only t;
131.611 +
131.612 +
131.613 +
131.614 +(** problem types **)
131.615 +
131.616 +store_pbt
131.617 + (prep_pbt Test.thy "pbl_test_uni_plain2" [] e_pblID
131.618 + (["plain_square","univariate","equation","test"],
131.619 + [("#Given" ,["equality e_","solveFor v_"]),
131.620 + ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\
131.621 + \(matches ( ?b*v_ ^^^2 = 0) e_) |\
131.622 + \(matches (?a + v_ ^^^2 = 0) e_) |\
131.623 + \(matches ( v_ ^^^2 = 0) e_)"]),
131.624 + ("#Find" ,["solutions v_i_"])
131.625 + ],
131.626 + assoc_rls "matches",
131.627 + SOME "solve (e_::bool, v_)", [["Test","solve_plain_square"]]));
131.628 +(*
131.629 + val e_ = (term_of o the o (parse thy)) "e_::bool";
131.630 + val ve = (term_of o the o (parse thy)) "4 + 3*x^^^2 = 0";
131.631 + val env = [(e_,ve)];
131.632 +
131.633 + val pre = (term_of o the o (parse thy))
131.634 + "(matches (a + b*v_ ^^^2 = 0, e_::bool)) |\
131.635 + \(matches ( b*v_ ^^^2 = 0, e_::bool)) |\
131.636 + \(matches (a + v_ ^^^2 = 0, e_::bool)) |\
131.637 + \(matches ( v_ ^^^2 = 0, e_::bool))";
131.638 + val prei = subst_atomic env pre;
131.639 + val cpre = (cterm_of thy) prei;
131.640 +
131.641 + val SOME (ct,_) = rewrite_set_ thy false tval_rls cpre;
131.642 +val ct = "True | False | False | False" : cterm
131.643 +
131.644 +> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
131.645 +> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
131.646 +> val SOME (ct,_) = rewrite_ thy sqrt_right tval_rls false or_false ct;
131.647 +val ct = "True" : cterm
131.648 +
131.649 +*)
131.650 +
131.651 +store_pbt
131.652 + (prep_pbt Test.thy "pbl_test_uni_poly" [] e_pblID
131.653 + (["polynomial","univariate","equation","test"],
131.654 + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]),
131.655 + ("#Where" ,["False"]),
131.656 + ("#Find" ,["solutions v_i_"])
131.657 + ],
131.658 + e_rls, SOME "solve (e_::bool, v_)", []));
131.659 +
131.660 +store_pbt
131.661 + (prep_pbt Test.thy "pbl_test_uni_poly_deg2" [] e_pblID
131.662 + (["degree_two","polynomial","univariate","equation","test"],
131.663 + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]),
131.664 + ("#Find" ,["solutions v_i_"])
131.665 + ],
131.666 + e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", []));
131.667 +
131.668 +store_pbt
131.669 + (prep_pbt Test.thy "pbl_test_uni_poly_deg2_pq" [] e_pblID
131.670 + (["pq_formula","degree_two","polynomial","univariate","equation","test"],
131.671 + [("#Given" ,["equality (v_ ^^^2 + p_ * v_ + q__ = 0)","solveFor v_"]),
131.672 + ("#Find" ,["solutions v_i_"])
131.673 + ],
131.674 + e_rls, SOME "solve (v_ ^^^2 + p_ * v_ + q__ = 0, v_)", []));
131.675 +
131.676 +store_pbt
131.677 + (prep_pbt Test.thy "pbl_test_uni_poly_deg2_abc" [] e_pblID
131.678 + (["abc_formula","degree_two","polynomial","univariate","equation","test"],
131.679 + [("#Given" ,["equality (a_ * x ^^^2 + b_ * x + c_ = 0)","solveFor v_"]),
131.680 + ("#Find" ,["solutions v_i_"])
131.681 + ],
131.682 + e_rls, SOME "solve (a_ * x ^^^2 + b_ * x + c_ = 0, v_)", []));
131.683 +
131.684 +store_pbt
131.685 + (prep_pbt Test.thy "pbl_test_uni_root" [] e_pblID
131.686 + (["squareroot","univariate","equation","test"],
131.687 + [("#Given" ,["equality e_","solveFor v_"]),
131.688 + ("#Where" ,["contains_root (e_::bool)"]),
131.689 + ("#Find" ,["solutions v_i_"])
131.690 + ],
131.691 + append_rls "contains_root" e_rls [Calc ("Test.contains'_root",
131.692 + eval_contains_root "#contains_root_")],
131.693 + SOME "solve (e_::bool, v_)", [["Test","square_equation"]]));
131.694 +
131.695 +store_pbt
131.696 + (prep_pbt Test.thy "pbl_test_uni_norm" [] e_pblID
131.697 + (["normalize","univariate","equation","test"],
131.698 + [("#Given" ,["equality e_","solveFor v_"]),
131.699 + ("#Where" ,[]),
131.700 + ("#Find" ,["solutions v_i_"])
131.701 + ],
131.702 + e_rls, SOME "solve (e_::bool, v_)", [["Test","norm_univar_equation"]]));
131.703 +
131.704 +store_pbt
131.705 + (prep_pbt Test.thy "pbl_test_uni_roottest" [] e_pblID
131.706 + (["sqroot-test","univariate","equation","test"],
131.707 + [("#Given" ,["equality e_","solveFor v_"]),
131.708 + (*("#Where" ,["contains_root (e_::bool)"]),*)
131.709 + ("#Find" ,["solutions v_i_"])
131.710 + ],
131.711 + e_rls, SOME "solve (e_::bool, v_)", []));
131.712 +
131.713 +(*
131.714 +(#ppc o get_pbt) ["sqroot-test","univariate","equation"];
131.715 + *)
131.716 +
131.717 +
131.718 +store_met
131.719 + (prep_met Test.thy "met_test_sqrt" [] e_metID
131.720 +(*root-equation, version for tests before 8.01.01*)
131.721 + (["Test","sqrt-equ-test"]:metID,
131.722 + [("#Given" ,["equality e_","solveFor v_"]),
131.723 + ("#Where" ,["contains_root (e_::bool)"]),
131.724 + ("#Find" ,["solutions v_i_"])
131.725 + ],
131.726 + {rew_ord'="e_rew_ord",rls'=tval_rls,
131.727 + srls =append_rls "srls_contains_root" e_rls
131.728 + [Calc ("Test.contains'_root",eval_contains_root "")],
131.729 + prls =append_rls "prls_contains_root" e_rls
131.730 + [Calc ("Test.contains'_root",eval_contains_root "")],
131.731 + calc=[],
131.732 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],
131.733 + asm_thm=[("square_equation_left",""),
131.734 + ("square_equation_right","")]*)},
131.735 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.736 + \(let e_ = \
131.737 + \ ((While (contains_root e_) Do\
131.738 + \ ((Rewrite square_equation_left True) @@\
131.739 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.740 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
131.741 + \ (Try (Rewrite_Set isolate_root False)) @@\
131.742 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
131.743 + \ (Try (Rewrite_Set norm_equation False)) @@\
131.744 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.745 + \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
131.746 + \ (Try (Rewrite_Set Test_simplify False)))\
131.747 + \ e_\
131.748 + \ in [e_::bool])"
131.749 + ));
131.750 +
131.751 +store_met
131.752 + (prep_met Test.thy "met_test_sqrt2" [] e_metID
131.753 +(*root-equation ... for test-*.sml until 8.01*)
131.754 + (["Test","squ-equ-test2"]:metID,
131.755 + [("#Given" ,["equality e_","solveFor v_"]),
131.756 + ("#Find" ,["solutions v_i_"])
131.757 + ],
131.758 + {rew_ord'="e_rew_ord",rls'=tval_rls,
131.759 + srls = append_rls "srls_contains_root" e_rls
131.760 + [Calc ("Test.contains'_root",eval_contains_root"")],
131.761 + prls=e_rls,calc=[],
131.762 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],
131.763 + asm_thm=[("square_equation_left",""),
131.764 + ("square_equation_right","")]*)},
131.765 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.766 + \(let e_ = \
131.767 + \ ((While (contains_root e_) Do\
131.768 + \ ((Rewrite square_equation_left True) @@\
131.769 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.770 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
131.771 + \ (Try (Rewrite_Set isolate_root False)) @@\
131.772 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
131.773 + \ (Try (Rewrite_Set norm_equation False)) @@\
131.774 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.775 + \ (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
131.776 + \ (Try (Rewrite_Set Test_simplify False)))\
131.777 + \ e_;\
131.778 + \ (L_::bool list) = Tac subproblem_equation_dummy; \
131.779 + \ L_ = Tac solve_equation_dummy \
131.780 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
131.781 + ));
131.782 +
131.783 +store_met
131.784 + (prep_met Test.thy "met_test_squ_sub" [] e_metID
131.785 +(*tests subproblem fixed linear*)
131.786 + (["Test","squ-equ-test-subpbl1"]:metID,
131.787 + [("#Given" ,["equality e_","solveFor v_"]),
131.788 + ("#Find" ,["solutions v_i_"])
131.789 + ],
131.790 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
131.791 + crls=tval_rls, nrls=Test_simplify},
131.792 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.793 + \ (let e_ = ((Try (Rewrite_Set norm_equation False)) @@ \
131.794 + \ (Try (Rewrite_Set Test_simplify False))) e_; \
131.795 + \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
131.796 + \ [Test,solve_linear]) [bool_ e_, real_ v_])\
131.797 + \in Check_elementwise L_ {(v_::real). Assumptions})"
131.798 + ));
131.799 +
131.800 +store_met
131.801 + (prep_met Test.thy "met_test_squ_sub2" [] e_metID
131.802 + (*tests subproblem fixed degree 2*)
131.803 + (["Test","squ-equ-test-subpbl2"]:metID,
131.804 + [("#Given" ,["equality e_","solveFor v_"]),
131.805 + ("#Find" ,["solutions v_i_"])
131.806 + ],
131.807 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls=e_rls,prls=e_rls,calc=[],
131.808 + crls=tval_rls, nrls=e_rls(*,
131.809 + asm_rls=[],asm_thm=[("square_equation_left",""),
131.810 + ("square_equation_right","")]*)},
131.811 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.812 + \ (let e_ = Try (Rewrite_Set norm_equation False) e_; \
131.813 + \(L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
131.814 + \ [Test,solve_by_pq_formula]) [bool_ e_, real_ v_])\
131.815 + \in Check_elementwise L_ {(v_::real). Assumptions})"
131.816 + ));
131.817 +
131.818 +store_met
131.819 + (prep_met Test.thy "met_test_squ_nonterm" [] e_metID
131.820 + (*root-equation: see foils..., but notTerminating*)
131.821 + (["Test","square_equation...notTerminating"]:metID,
131.822 + [("#Given" ,["equality e_","solveFor v_"]),
131.823 + ("#Find" ,["solutions v_i_"])
131.824 + ],
131.825 + {rew_ord'="e_rew_ord",rls'=tval_rls,
131.826 + srls = append_rls "srls_contains_root" e_rls
131.827 + [Calc ("Test.contains'_root",eval_contains_root"")],
131.828 + prls=e_rls,calc=[],
131.829 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],
131.830 + asm_thm=[("square_equation_left",""),
131.831 + ("square_equation_right","")]*)},
131.832 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.833 + \(let e_ = \
131.834 + \ ((While (contains_root e_) Do\
131.835 + \ ((Rewrite square_equation_left True) @@\
131.836 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.837 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
131.838 + \ (Try (Rewrite_Set isolate_root False)) @@\
131.839 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
131.840 + \ (Try (Rewrite_Set norm_equation False)) @@\
131.841 + \ (Try (Rewrite_Set Test_simplify False)))\
131.842 + \ e_;\
131.843 + \ (L_::bool list) = \
131.844 + \ (SubProblem (Test_,[linear,univariate,equation,test],\
131.845 + \ [Test,solve_linear]) [bool_ e_, real_ v_])\
131.846 + \in Check_elementwise L_ {(v_::real). Assumptions})"
131.847 + ));
131.848 +
131.849 +store_met
131.850 + (prep_met Test.thy "met_test_eq1" [] e_metID
131.851 +(*root-equation1:*)
131.852 + (["Test","square_equation1"]:metID,
131.853 + [("#Given" ,["equality e_","solveFor v_"]),
131.854 + ("#Find" ,["solutions v_i_"])
131.855 + ],
131.856 + {rew_ord'="e_rew_ord",rls'=tval_rls,
131.857 + srls = append_rls "srls_contains_root" e_rls
131.858 + [Calc ("Test.contains'_root",eval_contains_root"")],
131.859 + prls=e_rls,calc=[],
131.860 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],
131.861 + asm_thm=[("square_equation_left",""),
131.862 + ("square_equation_right","")]*)},
131.863 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.864 + \(let e_ = \
131.865 + \ ((While (contains_root e_) Do\
131.866 + \ ((Rewrite square_equation_left True) @@\
131.867 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.868 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
131.869 + \ (Try (Rewrite_Set isolate_root False)) @@\
131.870 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
131.871 + \ (Try (Rewrite_Set norm_equation False)) @@\
131.872 + \ (Try (Rewrite_Set Test_simplify False)))\
131.873 + \ e_;\
131.874 + \ (L_::bool list) = (SubProblem (Test_,[linear,univariate,equation,test],\
131.875 + \ [Test,solve_linear]) [bool_ e_, real_ v_])\
131.876 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
131.877 + ));
131.878 +
131.879 +store_met
131.880 + (prep_met Test.thy "met_test_squ2" [] e_metID
131.881 + (*root-equation2*)
131.882 + (["Test","square_equation2"]:metID,
131.883 + [("#Given" ,["equality e_","solveFor v_"]),
131.884 + ("#Find" ,["solutions v_i_"])
131.885 + ],
131.886 + {rew_ord'="e_rew_ord",rls'=tval_rls,
131.887 + srls = append_rls "srls_contains_root" e_rls
131.888 + [Calc ("Test.contains'_root",eval_contains_root"")],
131.889 + prls=e_rls,calc=[],
131.890 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],
131.891 + asm_thm=[("square_equation_left",""),
131.892 + ("square_equation_right","")]*)},
131.893 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.894 + \(let e_ = \
131.895 + \ ((While (contains_root e_) Do\
131.896 + \ (((Rewrite square_equation_left True) Or \
131.897 + \ (Rewrite square_equation_right True)) @@\
131.898 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.899 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
131.900 + \ (Try (Rewrite_Set isolate_root False)) @@\
131.901 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
131.902 + \ (Try (Rewrite_Set norm_equation False)) @@\
131.903 + \ (Try (Rewrite_Set Test_simplify False)))\
131.904 + \ e_;\
131.905 + \ (L_::bool list) = (SubProblem (Test_,[plain_square,univariate,equation,test],\
131.906 + \ [Test,solve_plain_square]) [bool_ e_, real_ v_])\
131.907 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
131.908 + ));
131.909 +
131.910 +store_met
131.911 + (prep_met Test.thy "met_test_squeq" [] e_metID
131.912 + (*root-equation*)
131.913 + (["Test","square_equation"]:metID,
131.914 + [("#Given" ,["equality e_","solveFor v_"]),
131.915 + ("#Find" ,["solutions v_i_"])
131.916 + ],
131.917 + {rew_ord'="e_rew_ord",rls'=tval_rls,
131.918 + srls = append_rls "srls_contains_root" e_rls
131.919 + [Calc ("Test.contains'_root",eval_contains_root"")],
131.920 + prls=e_rls,calc=[],
131.921 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],
131.922 + asm_thm=[("square_equation_left",""),
131.923 + ("square_equation_right","")]*)},
131.924 + "Script Solve_root_equation (e_::bool) (v_::real) = \
131.925 + \(let e_ = \
131.926 + \ ((While (contains_root e_) Do\
131.927 + \ (((Rewrite square_equation_left True) Or\
131.928 + \ (Rewrite square_equation_right True)) @@\
131.929 + \ (Try (Rewrite_Set Test_simplify False)) @@\
131.930 + \ (Try (Rewrite_Set rearrange_assoc False)) @@\
131.931 + \ (Try (Rewrite_Set isolate_root False)) @@\
131.932 + \ (Try (Rewrite_Set Test_simplify False)))) @@\
131.933 + \ (Try (Rewrite_Set norm_equation False)) @@\
131.934 + \ (Try (Rewrite_Set Test_simplify False)))\
131.935 + \ e_;\
131.936 + \ (L_::bool list) = (SubProblem (Test_,[univariate,equation,test],\
131.937 + \ [no_met]) [bool_ e_, real_ v_])\
131.938 + \ in Check_elementwise L_ {(v_::real). Assumptions})"
131.939 + ) ); (*#######*)
131.940 +
131.941 +store_met
131.942 + (prep_met Test.thy "met_test_eq_plain" [] e_metID
131.943 + (*solve_plain_square*)
131.944 + (["Test","solve_plain_square"]:metID,
131.945 + [("#Given",["equality e_","solveFor v_"]),
131.946 + ("#Where" ,["(matches (?a + ?b*v_ ^^^2 = 0) e_) |\
131.947 + \(matches ( ?b*v_ ^^^2 = 0) e_) |\
131.948 + \(matches (?a + v_ ^^^2 = 0) e_) |\
131.949 + \(matches ( v_ ^^^2 = 0) e_)"]),
131.950 + ("#Find" ,["solutions v_i_"])
131.951 + ],
131.952 + {rew_ord'="e_rew_ord",rls'=tval_rls,calc=[],srls=e_rls,
131.953 + prls = assoc_rls "matches",
131.954 + crls=tval_rls, nrls=e_rls(*,
131.955 + asm_rls=[],asm_thm=[]*)},
131.956 + "Script Solve_plain_square (e_::bool) (v_::real) = \
131.957 + \ (let e_ = ((Try (Rewrite_Set isolate_bdv False)) @@ \
131.958 + \ (Try (Rewrite_Set Test_simplify False)) @@ \
131.959 + \ ((Rewrite square_equality_0 False) Or \
131.960 + \ (Rewrite square_equality True)) @@ \
131.961 + \ (Try (Rewrite_Set tval_rls False))) e_ \
131.962 + \ in ((Or_to_List e_)::bool list))"
131.963 + ));
131.964 +
131.965 +store_met
131.966 + (prep_met Test.thy "met_test_norm_univ" [] e_metID
131.967 + (["Test","norm_univar_equation"]:metID,
131.968 + [("#Given",["equality e_","solveFor v_"]),
131.969 + ("#Where" ,[]),
131.970 + ("#Find" ,["solutions v_i_"])
131.971 + ],
131.972 + {rew_ord'="e_rew_ord",rls'=tval_rls,srls = e_rls,prls=e_rls,
131.973 + calc=[],
131.974 + crls=tval_rls, nrls=e_rls(*,asm_rls=[],asm_thm=[]*)},
131.975 + "Script Norm_univar_equation (e_::bool) (v_::real) = \
131.976 + \ (let e_ = ((Try (Rewrite rnorm_equation_add False)) @@ \
131.977 + \ (Try (Rewrite_Set Test_simplify False))) e_ \
131.978 + \ in (SubProblem (Test_,[univariate,equation,test], \
131.979 + \ [no_met]) [bool_ e_, real_ v_]))"
131.980 + ));
131.981 +
131.982 +
131.983 +
131.984 +(*17.9.02 aus SqRoot.ML------------------------------^^^---*)
131.985 +
131.986 +(*8.4.03 aus Poly.ML--------------------------------vvv---
131.987 + make_polynomial ---> make_poly
131.988 + ^-- for user ^-- for systest _ONLY_*)
131.989 +
131.990 +local (*. for make_polytest .*)
131.991 +
131.992 +open Term; (* for type order = EQUAL | LESS | GREATER *)
131.993 +
131.994 +fun pr_ord EQUAL = "EQUAL"
131.995 + | pr_ord LESS = "LESS"
131.996 + | pr_ord GREATER = "GREATER";
131.997 +
131.998 +fun dest_hd' (Const (a, T)) = (* ~ term.ML *)
131.999 + (case a of
131.1000 + "Atools.pow" => ((("|||||||||||||", 0), T), 0) (*WN greatest *)
131.1001 + | _ => (((a, 0), T), 0))
131.1002 + | dest_hd' (Free (a, T)) = (((a, 0), T), 1)
131.1003 + | dest_hd' (Var v) = (v, 2)
131.1004 + | dest_hd' (Bound i) = ((("", i), dummyT), 3)
131.1005 + | dest_hd' (Abs (_, T, _)) = ((("", 0), T), 4);
131.1006 +(* RL *)
131.1007 +fun get_order_pow (t $ (Free(order,_))) =
131.1008 + (case int_of_str (order) of
131.1009 + SOME d => d
131.1010 + | NONE => 0)
131.1011 + | get_order_pow _ = 0;
131.1012 +
131.1013 +fun size_of_term' (Const(str,_) $ t) =
131.1014 + if "Atools.pow"= str then 1000 + size_of_term' t else 1 + size_of_term' t (*WN*)
131.1015 + | size_of_term' (Abs (_,_,body)) = 1 + size_of_term' body
131.1016 + | size_of_term' (f$t) = size_of_term' f + size_of_term' t
131.1017 + | size_of_term' _ = 1;
131.1018 +
131.1019 +fun term_ord' pr thy (Abs (_, T, t), Abs(_, U, u)) = (* ~ term.ML *)
131.1020 + (case term_ord' pr thy (t, u) of EQUAL => typ_ord (T, U) | ord => ord)
131.1021 + | term_ord' pr thy (t, u) =
131.1022 + (if pr then
131.1023 + let
131.1024 + val (f, ts) = strip_comb t and (g, us) = strip_comb u;
131.1025 + val _=writeln("t= f@ts= \""^
131.1026 + ((Syntax.string_of_term (thy2ctxt thy)) f)^"\" @ \"["^
131.1027 + (commas(map(Syntax.string_of_term (thy2ctxt thy)) ts))^"]\"");
131.1028 + val _=writeln("u= g@us= \""^
131.1029 + ((Syntax.string_of_term (thy2ctxt thy)) g)^"\" @ \"["^
131.1030 + (commas(map(Syntax.string_of_term (thy2ctxt thy)) us))^"]\"");
131.1031 + val _=writeln("size_of_term(t,u)= ("^
131.1032 + (string_of_int(size_of_term' t))^", "^
131.1033 + (string_of_int(size_of_term' u))^")");
131.1034 + val _=writeln("hd_ord(f,g) = "^((pr_ord o hd_ord)(f,g)));
131.1035 + val _=writeln("terms_ord(ts,us) = "^
131.1036 + ((pr_ord o terms_ord str false)(ts,us)));
131.1037 + val _=writeln("-------");
131.1038 + in () end
131.1039 + else ();
131.1040 + case int_ord (size_of_term' t, size_of_term' u) of
131.1041 + EQUAL =>
131.1042 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
131.1043 + (case hd_ord (f, g) of EQUAL => (terms_ord str pr) (ts, us)
131.1044 + | ord => ord)
131.1045 + end
131.1046 + | ord => ord)
131.1047 +and hd_ord (f, g) = (* ~ term.ML *)
131.1048 + prod_ord (prod_ord indexname_ord typ_ord) int_ord (dest_hd' f, dest_hd' g)
131.1049 +and terms_ord str pr (ts, us) =
131.1050 + list_ord (term_ord' pr (assoc_thy "Isac.thy"))(ts, us);
131.1051 +in
131.1052 +
131.1053 +fun ord_make_polytest (pr:bool) thy (_:subst) tu =
131.1054 + (term_ord' pr thy(***) tu = LESS );
131.1055 +
131.1056 +end;(*local*)
131.1057 +
131.1058 +rew_ord' := overwritel (!rew_ord',
131.1059 +[("termlessI", termlessI),
131.1060 + ("ord_make_polytest", ord_make_polytest false thy)
131.1061 + ]);
131.1062 +
131.1063 +(*WN060510 this was a preparation for prep_rls ...
131.1064 +val scr_make_polytest =
131.1065 +"Script Expand_binomtest t_ =\
131.1066 +\(Repeat \
131.1067 +\((Try (Repeat (Rewrite real_diff_minus False))) @@ \
131.1068 +
131.1069 +\ (Try (Repeat (Rewrite real_add_mult_distrib False))) @@ \
131.1070 +\ (Try (Repeat (Rewrite real_add_mult_distrib2 False))) @@ \
131.1071 +\ (Try (Repeat (Rewrite real_diff_mult_distrib False))) @@ \
131.1072 +\ (Try (Repeat (Rewrite real_diff_mult_distrib2 False))) @@ \
131.1073 +
131.1074 +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
131.1075 +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
131.1076 +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
131.1077 +
131.1078 +\ (Try (Repeat (Rewrite real_mult_commute False))) @@ \
131.1079 +\ (Try (Repeat (Rewrite real_mult_left_commute False))) @@ \
131.1080 +\ (Try (Repeat (Rewrite real_mult_assoc False))) @@ \
131.1081 +\ (Try (Repeat (Rewrite real_add_commute False))) @@ \
131.1082 +\ (Try (Repeat (Rewrite real_add_left_commute False))) @@ \
131.1083 +\ (Try (Repeat (Rewrite real_add_assoc False))) @@ \
131.1084 +
131.1085 +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
131.1086 +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
131.1087 +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
131.1088 +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
131.1089 +
131.1090 +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
131.1091 +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
131.1092 +
131.1093 +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
131.1094 +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
131.1095 +
131.1096 +\ (Try (Repeat (Calculate plus ))) @@ \
131.1097 +\ (Try (Repeat (Calculate times ))) @@ \
131.1098 +\ (Try (Repeat (Calculate power_)))) \
131.1099 +\ t_)";
131.1100 +-----------------------------------------------------*)
131.1101 +
131.1102 +val make_polytest =
131.1103 + Rls{id = "make_polytest", preconds = []:term list, rew_ord = ("ord_make_polytest",
131.1104 + ord_make_polytest false Poly.thy),
131.1105 + erls = testerls, srls = Erls,
131.1106 + calc = [("PLUS" , ("op +", eval_binop "#add_")),
131.1107 + ("TIMES" , ("op *", eval_binop "#mult_")),
131.1108 + ("POWER", ("Atools.pow", eval_binop "#power_"))
131.1109 + ],
131.1110 + (*asm_thm = [],*)
131.1111 + rules = [Thm ("real_diff_minus",num_str real_diff_minus),
131.1112 + (*"a - b = a + (-1) * b"*)
131.1113 + Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
131.1114 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
131.1115 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
131.1116 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
131.1117 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
131.1118 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
131.1119 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
131.1120 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
131.1121 + Thm ("real_mult_1",num_str real_mult_1),
131.1122 + (*"1 * z = z"*)
131.1123 + Thm ("real_mult_0",num_str real_mult_0),
131.1124 + (*"0 * z = 0"*)
131.1125 + Thm ("real_add_zero_left",num_str real_add_zero_left),
131.1126 + (*"0 + z = z"*)
131.1127 +
131.1128 + (*AC-rewriting*)
131.1129 + Thm ("real_mult_commute",num_str real_mult_commute),
131.1130 + (* z * w = w * z *)
131.1131 + Thm ("real_mult_left_commute",num_str real_mult_left_commute),
131.1132 + (*z1.0 * (z2.0 * z3.0) = z2.0 * (z1.0 * z3.0)*)
131.1133 + Thm ("real_mult_assoc",num_str real_mult_assoc),
131.1134 + (*z1.0 * z2.0 * z3.0 = z1.0 * (z2.0 * z3.0)*)
131.1135 + Thm ("real_add_commute",num_str real_add_commute),
131.1136 + (*z + w = w + z*)
131.1137 + Thm ("real_add_left_commute",num_str real_add_left_commute),
131.1138 + (*x + (y + z) = y + (x + z)*)
131.1139 + Thm ("real_add_assoc",num_str real_add_assoc),
131.1140 + (*z1.0 + z2.0 + z3.0 = z1.0 + (z2.0 + z3.0)*)
131.1141 +
131.1142 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
131.1143 + (*"r1 * r1 = r1 ^^^ 2"*)
131.1144 + Thm ("realpow_plus_1",num_str realpow_plus_1),
131.1145 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
131.1146 + Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
131.1147 + (*"z1 + z1 = 2 * z1"*)
131.1148 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
131.1149 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
131.1150 +
131.1151 + Thm ("real_num_collect",num_str real_num_collect),
131.1152 + (*"[| l is_const; m is_const |]==>l * n + m * n = (l + m) * n"*)
131.1153 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
131.1154 + (*"[| l is_const; m is_const |] ==>
131.1155 + l * n + (m * n + k) = (l + m) * n + k"*)
131.1156 + Thm ("real_one_collect",num_str real_one_collect),
131.1157 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
131.1158 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
131.1159 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
131.1160 +
131.1161 + Calc ("op +", eval_binop "#add_"),
131.1162 + Calc ("op *", eval_binop "#mult_"),
131.1163 + Calc ("Atools.pow", eval_binop "#power_")
131.1164 + ],
131.1165 + scr = EmptyScr(*Script ((term_of o the o (parse thy))
131.1166 + scr_make_polytest)*)
131.1167 + }:rls;
131.1168 +(*WN060510 this was done before 'fun prep_rls' ...
131.1169 +val scr_expand_binomtest =
131.1170 +"Script Expand_binomtest t_ =\
131.1171 +\(Repeat \
131.1172 +\((Try (Repeat (Rewrite real_plus_binom_pow2 False))) @@ \
131.1173 +\ (Try (Repeat (Rewrite real_plus_binom_times False))) @@ \
131.1174 +\ (Try (Repeat (Rewrite real_minus_binom_pow2 False))) @@ \
131.1175 +\ (Try (Repeat (Rewrite real_minus_binom_times False))) @@ \
131.1176 +\ (Try (Repeat (Rewrite real_plus_minus_binom1 False))) @@ \
131.1177 +\ (Try (Repeat (Rewrite real_plus_minus_binom2 False))) @@ \
131.1178 +
131.1179 +\ (Try (Repeat (Rewrite real_mult_1 False))) @@ \
131.1180 +\ (Try (Repeat (Rewrite real_mult_0 False))) @@ \
131.1181 +\ (Try (Repeat (Rewrite real_add_zero_left False))) @@ \
131.1182 +
131.1183 +\ (Try (Repeat (Calculate plus ))) @@ \
131.1184 +\ (Try (Repeat (Calculate times ))) @@ \
131.1185 +\ (Try (Repeat (Calculate power_))) @@ \
131.1186 +
131.1187 +\ (Try (Repeat (Rewrite sym_realpow_twoI False))) @@ \
131.1188 +\ (Try (Repeat (Rewrite realpow_plus_1 False))) @@ \
131.1189 +\ (Try (Repeat (Rewrite sym_real_mult_2 False))) @@ \
131.1190 +\ (Try (Repeat (Rewrite real_mult_2_assoc False))) @@ \
131.1191 +
131.1192 +\ (Try (Repeat (Rewrite real_num_collect False))) @@ \
131.1193 +\ (Try (Repeat (Rewrite real_num_collect_assoc False))) @@ \
131.1194 +
131.1195 +\ (Try (Repeat (Rewrite real_one_collect False))) @@ \
131.1196 +\ (Try (Repeat (Rewrite real_one_collect_assoc False))) @@ \
131.1197 +
131.1198 +\ (Try (Repeat (Calculate plus ))) @@ \
131.1199 +\ (Try (Repeat (Calculate times ))) @@ \
131.1200 +\ (Try (Repeat (Calculate power_)))) \
131.1201 +\ t_)";
131.1202 +------------------------------------------------------*)
131.1203 +
131.1204 +val expand_binomtest =
131.1205 + Rls{id = "expand_binomtest", preconds = [],
131.1206 + rew_ord = ("termlessI",termlessI),
131.1207 + erls = testerls, srls = Erls,
131.1208 + calc = [("PLUS" , ("op +", eval_binop "#add_")),
131.1209 + ("TIMES" , ("op *", eval_binop "#mult_")),
131.1210 + ("POWER", ("Atools.pow", eval_binop "#power_"))
131.1211 + ],
131.1212 + (*asm_thm = [],*)
131.1213 + rules = [Thm ("real_plus_binom_pow2" ,num_str real_plus_binom_pow2),
131.1214 + (*"(a + b) ^^^ 2 = a ^^^ 2 + 2 * a * b + b ^^^ 2"*)
131.1215 + Thm ("real_plus_binom_times" ,num_str real_plus_binom_times),
131.1216 + (*"(a + b)*(a + b) = ...*)
131.1217 + Thm ("real_minus_binom_pow2" ,num_str real_minus_binom_pow2),
131.1218 + (*"(a - b) ^^^ 2 = a ^^^ 2 - 2 * a * b + b ^^^ 2"*)
131.1219 + Thm ("real_minus_binom_times",num_str real_minus_binom_times),
131.1220 + (*"(a - b)*(a - b) = ...*)
131.1221 + Thm ("real_plus_minus_binom1",num_str real_plus_minus_binom1),
131.1222 + (*"(a + b) * (a - b) = a ^^^ 2 - b ^^^ 2"*)
131.1223 + Thm ("real_plus_minus_binom2",num_str real_plus_minus_binom2),
131.1224 + (*"(a - b) * (a + b) = a ^^^ 2 - b ^^^ 2"*)
131.1225 + (*RL 020915*)
131.1226 + Thm ("real_pp_binom_times",num_str real_pp_binom_times),
131.1227 + (*(a + b)*(c + d) = a*c + a*d + b*c + b*d*)
131.1228 + Thm ("real_pm_binom_times",num_str real_pm_binom_times),
131.1229 + (*(a + b)*(c - d) = a*c - a*d + b*c - b*d*)
131.1230 + Thm ("real_mp_binom_times",num_str real_mp_binom_times),
131.1231 + (*(a - b)*(c p d) = a*c + a*d - b*c - b*d*)
131.1232 + Thm ("real_mm_binom_times",num_str real_mm_binom_times),
131.1233 + (*(a - b)*(c p d) = a*c - a*d - b*c + b*d*)
131.1234 + Thm ("realpow_multI",num_str realpow_multI),
131.1235 + (*(a*b)^^^n = a^^^n * b^^^n*)
131.1236 + Thm ("real_plus_binom_pow3",num_str real_plus_binom_pow3),
131.1237 + (* (a + b)^^^3 = a^^^3 + 3*a^^^2*b + 3*a*b^^^2 + b^^^3 *)
131.1238 + Thm ("real_minus_binom_pow3",num_str real_minus_binom_pow3),
131.1239 + (* (a - b)^^^3 = a^^^3 - 3*a^^^2*b + 3*a*b^^^2 - b^^^3 *)
131.1240 +
131.1241 +
131.1242 + (* Thm ("real_add_mult_distrib" ,num_str real_add_mult_distrib),
131.1243 + (*"(z1.0 + z2.0) * w = z1.0 * w + z2.0 * w"*)
131.1244 + Thm ("real_add_mult_distrib2",num_str real_add_mult_distrib2),
131.1245 + (*"w * (z1.0 + z2.0) = w * z1.0 + w * z2.0"*)
131.1246 + Thm ("real_diff_mult_distrib" ,num_str real_diff_mult_distrib),
131.1247 + (*"(z1.0 - z2.0) * w = z1.0 * w - z2.0 * w"*)
131.1248 + Thm ("real_diff_mult_distrib2",num_str real_diff_mult_distrib2),
131.1249 + (*"w * (z1.0 - z2.0) = w * z1.0 - w * z2.0"*)
131.1250 + *)
131.1251 +
131.1252 + Thm ("real_mult_1",num_str real_mult_1), (*"1 * z = z"*)
131.1253 + Thm ("real_mult_0",num_str real_mult_0), (*"0 * z = 0"*)
131.1254 + Thm ("real_add_zero_left",num_str real_add_zero_left),(*"0 + z = z"*)
131.1255 +
131.1256 + Calc ("op +", eval_binop "#add_"),
131.1257 + Calc ("op *", eval_binop "#mult_"),
131.1258 + Calc ("Atools.pow", eval_binop "#power_"),
131.1259 + (*
131.1260 + Thm ("real_mult_commute",num_str real_mult_commute), (*AC-rewriting*)
131.1261 + Thm ("real_mult_left_commute",num_str real_mult_left_commute), (**)
131.1262 + Thm ("real_mult_assoc",num_str real_mult_assoc), (**)
131.1263 + Thm ("real_add_commute",num_str real_add_commute), (**)
131.1264 + Thm ("real_add_left_commute",num_str real_add_left_commute), (**)
131.1265 + Thm ("real_add_assoc",num_str real_add_assoc), (**)
131.1266 + *)
131.1267 +
131.1268 + Thm ("sym_realpow_twoI",num_str (realpow_twoI RS sym)),
131.1269 + (*"r1 * r1 = r1 ^^^ 2"*)
131.1270 + Thm ("realpow_plus_1",num_str realpow_plus_1),
131.1271 + (*"r * r ^^^ n = r ^^^ (n + 1)"*)
131.1272 + (*Thm ("sym_real_mult_2",num_str (real_mult_2 RS sym)),
131.1273 + (*"z1 + z1 = 2 * z1"*)*)
131.1274 + Thm ("real_mult_2_assoc",num_str real_mult_2_assoc),
131.1275 + (*"z1 + (z1 + k) = 2 * z1 + k"*)
131.1276 +
131.1277 + Thm ("real_num_collect",num_str real_num_collect),
131.1278 + (*"[| l is_const; m is_const |] ==> l * n + m * n = (l + m) * n"*)
131.1279 + Thm ("real_num_collect_assoc",num_str real_num_collect_assoc),
131.1280 + (*"[| l is_const; m is_const |] ==> l * n + (m * n + k) = (l + m) * n + k"*)
131.1281 + Thm ("real_one_collect",num_str real_one_collect),
131.1282 + (*"m is_const ==> n + m * n = (1 + m) * n"*)
131.1283 + Thm ("real_one_collect_assoc",num_str real_one_collect_assoc),
131.1284 + (*"m is_const ==> k + (n + m * n) = k + (1 + m) * n"*)
131.1285 +
131.1286 + Calc ("op +", eval_binop "#add_"),
131.1287 + Calc ("op *", eval_binop "#mult_"),
131.1288 + Calc ("Atools.pow", eval_binop "#power_")
131.1289 + ],
131.1290 + scr = EmptyScr
131.1291 +(*Script ((term_of o the o (parse thy)) scr_expand_binomtest)*)
131.1292 + }:rls;
131.1293 +
131.1294 +
131.1295 +ruleset' := overwritelthy thy (!ruleset',
131.1296 + [("make_polytest", prep_rls make_polytest),
131.1297 + ("expand_binomtest", prep_rls expand_binomtest)
131.1298 + ]);
131.1299 +
131.1300 +
131.1301 +
131.1302 +
131.1303 +
131.1304 +
132.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
132.2 +++ b/src/Tools/isac/Knowledge/Test.sml Wed Aug 25 16:20:07 2010 +0200
132.3 @@ -0,0 +1,158 @@
132.4 +val ttt = (term_of o the o (parse thy))
132.5 +"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_";
132.6 +val ttt = (term_of o the o (parse thy))
132.7 +"(Try (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) e_)";
132.8 +
132.9 +val ttt = (term_of o the o (parse thy))
132.10 + "(Rewrite_Set SqRoot_simplify False) e_ ";
132.11 +val ttt = (term_of o the o (parseold thy))
132.12 + "%e_. (Rewrite_Set SqRoot_simplify False) e_";
132.13 +val ttt = (term_of o the o (parseold thy))
132.14 + "Repeat (%e_. (Rewrite_Set SqRoot_simplify False)) e_";
132.15 +
132.16 +val ttt = (term_of o the o (parse thy))
132.17 + "Script Solve_linear (e_::bool) (v_::real)= \
132.18 + \[e_]";
132.19 +val ttt = (term_of o the o (parse thy))
132.20 + "Script Solve_linear (e_::bool) (v_::real)= \
132.21 + \((%e_. [e_]) e_)";
132.22 +val ttt = (term_of o the o (parse thy))
132.23 + "Script Solve_linear (e_::bool) (v_::real)= \
132.24 + \((%e_. (let e_ = e_ in [e_])) e_)";
132.25 +val ttt = (term_of o the o (parse thy))
132.26 + "Script Solve_linear (e_::bool) (v_::real)= \
132.27 + \((%e_. \
132.28 + \ (let e_ = ((Rewrite_Set SqRoot_simplify False) e_)\
132.29 + \ in [e_]))\
132.30 + \ e_)";
132.31 +val ttt = (term_of o the o (parse thy))
132.32 + "Script Solve_linear (e_::bool) (v_::real)= \
132.33 + \((%ee_. (let e_ = ((Rewrite_Set SqRoot_simplify False) ee_) in [e_])) e_)";
132.34 +
132.35 +val ttt = (term_of o the o (parse thy))
132.36 + "Script Solve_linear (e_::bool) (v_::real)= \
132.37 + \(let e_ = \
132.38 + \ (Repeat ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False)) e_)\
132.39 + \ in [e_])";
132.40 +(*----*)
132.41 +val ttt = (term_of o the o (parse thy))
132.42 +
132.43 +(*----*)
132.44 +val ttt = (term_of o the o (parse thy))
132.45 + "Script Solve_linear (e_::bool) (v_::real)= \
132.46 + \(let e_ = \
132.47 + \ (Repeat\
132.48 + \ ((%ee_. (Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\
132.49 + \ e_)\
132.50 + \ e_)\
132.51 + \ in [e_])";
132.52 +val ttt = (term_of o the o (parse thy))
132.53 + "Script Solve_linear (e_::bool) (v_::real)= \
132.54 + \(let e_ = \
132.55 + \ (Repeat\
132.56 + \ ((%ee_.\
132.57 + \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_))\
132.58 + \ e_)\
132.59 + \ e_)\
132.60 + \ in [e_])";
132.61 +val ttt = (term_of o the o (parse thy))
132.62 + "Script Solve_linear (e_::bool) (v_::real)= \
132.63 + \(let e_ = \
132.64 + \ (Repeat\
132.65 + \ ((%ee_.\
132.66 + \ (let e_ = ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) ee_)\
132.67 + \ in ((Rewrite_Set SqRoot_simplify False) e_)) )\
132.68 + \ e_)\
132.69 + \ e_)\
132.70 + \ in [e_])";
132.71 +atomty ttt;
132.72 +atomt ttt;
132.73 +
132.74 +val ttt = (term_of o the o (parse thy))
132.75 + "Script Testterm (g_::real) = \
132.76 + \Repeat\
132.77 + \ (Rewrite rmult_1 False) g_";
132.78 +val ttt = (term_of o the o (parse thy))
132.79 + "Script Testterm (g_::real) = \
132.80 + \Repeat\
132.81 + \ (((Rewrite rmult_1 False)) Or ((Rewrite rmult_0 False))) g_";
132.82 +val ttt = (term_of o the o (parse thy))
132.83 + "Script Testterm (g_::real) = \
132.84 + \Repeat\
132.85 + \ ((Repeat (Rewrite rmult_1 False)) Or (Repeat (Rewrite rmult_0 False))) g_";
132.86 +val ttt = (term_of o the o (parse thy))
132.87 + "Script Testterm (g_::real) = \
132.88 + \Repeat\
132.89 + \ ((Repeat (Rewrite rmult_1 False)) Or\
132.90 + \ (Repeat (Rewrite rmult_0 False))) g_";
132.91 +val ttt = (term_of o the o (parse thy))
132.92 + "Script Testterm (g_::real) = \
132.93 + \Repeat\
132.94 + \ ((Repeat (Rewrite rmult_1 False)) Or\
132.95 + \ (Repeat (Rewrite rmult_0 False)) Or\
132.96 + \ (Repeat (Rewrite rmult_0 False))) g_";
132.97 +val ttt = (term_of o the o (parse thy))
132.98 + "Script Testterm (g_::real) = \
132.99 + \Repeat\
132.100 + \ ((Try Repeat (Rewrite rmult_1 False)) Or\
132.101 + \ (Try Repeat (Rewrite rmult_0 False)) Or\
132.102 + \ (Try Repeat (Rewrite rmult_0 False))) g_";
132.103 +
132.104 +
132.105 +
132.106 +
132.107 +
132.108 +
132.109 +
132.110 +
132.111 +
132.112 +
132.113 +
132.114 +
132.115 +
132.116 +(*################### 29.4.02: Rewrite o Rewrite o ...###############*)
132.117 +(*################### 29.4.02: Rewrite o Rewrite o ...###############*)
132.118 +(*################### 29.4.02: Rewrite o Rewrite o ...###############*)
132.119 +
132.120 +
132.121 +
132.122 +atomt ttt;
132.123 +val ttt = (term_of o the o (parse thy))
132.124 + "Script Solve_linear (e_::bool) (v_::real)= \
132.125 + \(let e_ = \
132.126 + \ ((Repeat\
132.127 + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
132.128 + \ (Rewrite_Set SqRoot_simplify False)))) e_)\
132.129 + \ in [e_])";
132.130 +atomty ttt;
132.131 +
132.132 +
132.133 +val ttt = (term_of o the o (parse thy))
132.134 +"(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@ yyy";
132.135 +atomty ttt;
132.136 +val ttt = (term_of o the o (parse thy))
132.137 + "(Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
132.138 + \ (Rewrite_Set SqRoot_simplify False)";
132.139 +atomty ttt;
132.140 +val ttt = (term_of o the o (parse thy))
132.141 + "(Repeat\
132.142 + \ ((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
132.143 + \ (Rewrite_Set SqRoot_simplify False))) e_";
132.144 +atomty ttt;
132.145 +val ttt = (term_of o the o (parseold thy))
132.146 +"(let e_ = Repeat xxx e_ in [e_::bool])";
132.147 +atomty ttt;
132.148 +val ttt = (term_of o the o (parseold thy))
132.149 + "Script Solve_linear (e_::bool) (v_::real)= \
132.150 + \(let e_ = Repeat (xxx) e_ in [e_::bool])";
132.151 +atomty ttt;
132.152 +val ttt = (term_of o the o (parseold thy))
132.153 + "Script Solve_linear (e_::bool) (v_::real)= \
132.154 + \(let e_ =\
132.155 + \ Repeat\
132.156 + \ (((Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False) @@\
132.157 + \ (Rewrite_Set SqRoot_simplify False))) e_\
132.158 + \ in [e_::bool])"
132.159 +;
132.160 +atomty ttt;
132.161 +
133.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
133.2 +++ b/src/Tools/isac/Knowledge/Test.thy Wed Aug 25 16:20:07 2010 +0200
133.3 @@ -0,0 +1,169 @@
133.4 +(* use_thy"Knowledge/Test";
133.5 + *)
133.6 +
133.7 +Test = Atools + Rational + Root + Poly +
133.8 +
133.9 +consts
133.10 +
133.11 +(*"cancel":: [real, real] => real (infixl "'/'/'/" 70) ...divide 2002*)
133.12 +
133.13 + Expand'_binomtest
133.14 + :: "['y, \
133.15 + \ 'y] => 'y"
133.16 + ("((Script Expand'_binomtest (_ =))// \
133.17 + \ (_))" 9)
133.18 +
133.19 + Solve'_univar'_err
133.20 + :: "[bool,real,bool, \
133.21 + \ bool list] => bool list"
133.22 + ("((Script Solve'_univar'_err (_ _ _ =))// \
133.23 + \ (_))" 9)
133.24 +
133.25 + Solve'_linear
133.26 + :: "[bool,real, \
133.27 + \ bool list] => bool list"
133.28 + ("((Script Solve'_linear (_ _ =))// \
133.29 + \ (_))" 9)
133.30 +
133.31 +(*17.9.02 aus SqRoot.thy------------------------------vvv---*)
133.32 +
133.33 + "is'_root'_free" :: 'a => bool ("is'_root'_free _" 10)
133.34 + "contains'_root" :: 'a => bool ("contains'_root _" 10)
133.35 +
133.36 + Solve'_root'_equation
133.37 + :: "[bool,real, \
133.38 + \ bool list] => bool list"
133.39 + ("((Script Solve'_root'_equation (_ _ =))// \
133.40 + \ (_))" 9)
133.41 +
133.42 + Solve'_plain'_square
133.43 + :: "[bool,real, \
133.44 + \ bool list] => bool list"
133.45 + ("((Script Solve'_plain'_square (_ _ =))// \
133.46 + \ (_))" 9)
133.47 +
133.48 + Norm'_univar'_equation
133.49 + :: "[bool,real, \
133.50 + \ bool] => bool"
133.51 + ("((Script Norm'_univar'_equation (_ _ =))// \
133.52 + \ (_))" 9)
133.53 +
133.54 + STest'_simplify
133.55 + :: "['z, \
133.56 + \ 'z] => 'z"
133.57 + ("((Script STest'_simplify (_ =))// \
133.58 + \ (_))" 9)
133.59 +
133.60 +(*17.9.02 aus SqRoot.thy------------------------------^^^---*)
133.61 +
133.62 +rules (*stated as axioms, todo: prove as theorems*)
133.63 +
133.64 + radd_mult_distrib2 "(k::real) * (m + n) = k * m + k * n"
133.65 + rdistr_right_assoc "(k::real) + l * n + m * n = k + (l + m) * n"
133.66 + rdistr_right_assoc_p "l * n + (m * n + (k::real)) = (l + m) * n + k"
133.67 + rdistr_div_right "((k::real) + l) / n = k / n + l / n"
133.68 + rcollect_right
133.69 + "[| l is_const; m is_const |] ==> (l::real)*n + m*n = (l + m) * n"
133.70 + rcollect_one_left
133.71 + "m is_const ==> (n::real) + m * n = (1 + m) * n"
133.72 + rcollect_one_left_assoc
133.73 + "m is_const ==> (k::real) + n + m * n = k + (1 + m) * n"
133.74 + rcollect_one_left_assoc_p
133.75 + "m is_const ==> n + (m * n + (k::real)) = (1 + m) * n + k"
133.76 +
133.77 + rtwo_of_the_same "a + a = 2 * a"
133.78 + rtwo_of_the_same_assoc "(x + a) + a = x + 2 * a"
133.79 + rtwo_of_the_same_assoc_p"a + (a + x) = 2 * a + x"
133.80 +
133.81 + rcancel_den "not(a=0) ==> a * (b / a) = b"
133.82 + rcancel_const "[| a is_const; b is_const |] ==> a*(x/b) = a/b*x"
133.83 + rshift_nominator "(a::real) * b / c = a / c * b"
133.84 +
133.85 + exp_pow "(a ^^^ b) ^^^ c = a ^^^ (b * c)"
133.86 + rsqare "(a::real) * a = a ^^^ 2"
133.87 + power_1 "(a::real) ^^^ 1 = a"
133.88 + rbinom_power_2 "((a::real) + b)^^^ 2 = a^^^ 2 + 2*a*b + b^^^ 2"
133.89 +
133.90 + rmult_1 "1 * k = (k::real)"
133.91 + rmult_1_right "k * 1 = (k::real)"
133.92 + rmult_0 "0 * k = (0::real)"
133.93 + rmult_0_right "k * 0 = (0::real)"
133.94 + radd_0 "0 + k = (k::real)"
133.95 + radd_0_right "k + 0 = (k::real)"
133.96 +
133.97 + radd_real_const_eq
133.98 + "[| a is_const; c is_const; d is_const |] ==> a/d + c/d = (a+c)/(d::real)"
133.99 + radd_real_const
133.100 + "[| a is_const; b is_const; c is_const; d is_const |] ==> a/b + c/d = (a*d + b*c)/(b*(d::real))"
133.101 +
133.102 +(*for AC-operators*)
133.103 + radd_commute "(m::real) + (n::real) = n + m"
133.104 + radd_left_commute "(x::real) + (y + z) = y + (x + z)"
133.105 + radd_assoc "(m::real) + n + k = m + (n + k)"
133.106 + rmult_commute "(m::real) * n = n * m"
133.107 + rmult_left_commute "(x::real) * (y * z) = y * (x * z)"
133.108 + rmult_assoc "(m::real) * n * k = m * (n * k)"
133.109 +
133.110 +(*for equations: 'bdv' is a meta-constant*)
133.111 + risolate_bdv_add "((k::real) + bdv = m) = (bdv = m + (-1)*k)"
133.112 + risolate_bdv_mult_add "((k::real) + n*bdv = m) = (n*bdv = m + (-1)*k)"
133.113 + risolate_bdv_mult "((n::real) * bdv = m) = (bdv = m / n)"
133.114 +
133.115 + rnorm_equation_add
133.116 + "~(b =!= 0) ==> (a = b) = (a + (-1)*b = 0)"
133.117 +
133.118 +(*17.9.02 aus SqRoot.thy------------------------------vvv---*)
133.119 + root_ge0 "0 <= a ==> 0 <= sqrt a"
133.120 + (*should be dropped with better simplification in eval_rls ...*)
133.121 + root_add_ge0
133.122 + "[| 0 <= a; 0 <= b |] ==> (0 <= sqrt a + sqrt b) = True"
133.123 + root_ge0_1
133.124 + "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= a * sqrt b + sqrt c) = True"
133.125 + root_ge0_2
133.126 + "[| 0<=a; 0<=b; 0<=c |] ==> (0 <= sqrt a + b * sqrt c) = True"
133.127 +
133.128 +
133.129 + rroot_square_inv "(sqrt a)^^^ 2 = a"
133.130 + rroot_times_root "sqrt a * sqrt b = sqrt(a*b)"
133.131 + rroot_times_root_assoc "(a * sqrt b) * sqrt c = a * sqrt(b*c)"
133.132 + rroot_times_root_assoc_p "sqrt b * (sqrt c * a)= sqrt(b*c) * a"
133.133 +
133.134 +
133.135 +(*for root-equations*)
133.136 + square_equation_left
133.137 + "[| 0 <= a; 0 <= b |] ==> (((sqrt a)=b)=(a=(b^^^ 2)))"
133.138 + square_equation_right
133.139 + "[| 0 <= a; 0 <= b |] ==> ((a=(sqrt b))=((a^^^ 2)=b))"
133.140 + (*causes frequently non-termination:*)
133.141 + square_equation
133.142 + "[| 0 <= a; 0 <= b |] ==> ((a=b)=((a^^^ 2)=b^^^ 2))"
133.143 +
133.144 + risolate_root_add "(a+ sqrt c = d) = ( sqrt c = d + (-1)*a)"
133.145 + risolate_root_mult "(a+b*sqrt c = d) = (b*sqrt c = d + (-1)*a)"
133.146 + risolate_root_div "(a * sqrt c = d) = ( sqrt c = d / a)"
133.147 +
133.148 +(*for polynomial equations of degree 2; linear case in RatArith*)
133.149 + mult_square "(a*bdv^^^2 = b) = (bdv^^^2 = b / a)"
133.150 + constant_square "(a + bdv^^^2 = b) = (bdv^^^2 = b + -1*a)"
133.151 + constant_mult_square "(a + b*bdv^^^2 = c) = (b*bdv^^^2 = c + -1*a)"
133.152 +
133.153 + square_equality
133.154 + "0 <= a ==> (x^^^2 = a) = ((x=sqrt a) | (x=-1*sqrt a))"
133.155 + square_equality_0
133.156 + "(x^^^2 = 0) = (x = 0)"
133.157 +
133.158 +(*isolate root on the LEFT hand side of the equation
133.159 + otherwise shuffling from left to right would not terminate*)
133.160 +
133.161 + rroot_to_lhs
133.162 + "is_root_free a ==> (a = sqrt b) = (a + (-1)*sqrt b = 0)"
133.163 + rroot_to_lhs_mult
133.164 + "is_root_free a ==> (a = c*sqrt b) = (a + (-1)*c*sqrt b = 0)"
133.165 + rroot_to_lhs_add_mult
133.166 + "is_root_free a ==> (a = d+c*sqrt b) = (a + (-1)*c*sqrt b = d)"
133.167 +
133.168 +
133.169 +(*17.9.02 aus SqRoot.thy------------------------------^^^---*)
133.170 +
133.171 +
133.172 +end
134.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
134.2 +++ b/src/Tools/isac/Knowledge/Trig.thy Wed Aug 25 16:20:07 2010 +0200
134.3 @@ -0,0 +1,4 @@
134.4 +
134.5 +Trig = Real +
134.6 +
134.7 +end
134.8 \ No newline at end of file
135.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
135.2 +++ b/src/Tools/isac/Knowledge/Typefix.thy Wed Aug 25 16:20:07 2010 +0200
135.3 @@ -0,0 +1,32 @@
135.4 +(* Title: fixed type for _RE_parsing of strings from frontend
135.5 + Author: Walther Neuper
135.6 + 9911xx
135.7 + (c) due to copyright terms
135.8 + with hints from Markus Wenzel
135.9 + *)
135.10 +
135.11 +theory Typefix imports "../ProgLang/Script" begin
135.12 +
135.13 +syntax
135.14 +
135.15 + "_plus" :: 'a
135.16 + "_minus" :: 'a
135.17 + "_umin" :: 'a
135.18 + "_times" :: 'a
135.19 +
135.20 +translations
135.21 +
135.22 + "op +" => "_plus :: [real, real] => real" (*infixl 65 *)
135.23 + "op -" => "_minus :: [real, real] => real" (*infixl 65 *)
135.24 + "uminus"=> "_umin :: [real] => real" (*"- _" [80] 80*)
135.25 + "op *" => "_times :: [real, real] => real" (*infixl 70 *)
135.26 +
135.27 +ML {*
135.28 +val parse_translation =
135.29 + [("_plus", curry Term.list_comb (Syntax.const "op +")),
135.30 + ("_minus", curry Term.list_comb (Syntax.const "op -")),
135.31 + ("_umin", curry Term.list_comb (Syntax.const "uminus")),
135.32 + ("_times", curry Term.list_comb (Syntax.const "op *"))];
135.33 +*}
135.34 +
135.35 +end
135.36 \ No newline at end of file
136.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
136.2 +++ b/src/Tools/isac/Knowledge/Vect.thy Wed Aug 25 16:20:07 2010 +0200
136.3 @@ -0,0 +1,5 @@
136.4 +Vect = Real +
136.5 +(*-------------------- consts ------------------------------------------------*)
136.6 +
136.7 +(*-------------------- rules -------------------------------------------------*)
136.8 +end
137.1 --- a/src/Tools/isac/ME/appl.sml Wed Aug 25 15:15:01 2010 +0200
137.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
137.3 @@ -1,782 +0,0 @@
137.4 -(* use"ME/appl.sml";
137.5 - use"appl.sml";
137.6 -
137.7 -12345678901234567890123456789012345678901234567890123456789012345678901234567890
137.8 - 10 20 30 40 50 60 70 80
137.9 -*)
137.10 -val e_cterm' = empty_cterm';
137.11 -
137.12 -
137.13 -fun rew_info (Rls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
137.14 - (rew_ord':rew_ord',erls,ca)
137.15 - | rew_info (Seq {erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
137.16 - (rew_ord',erls,ca)
137.17 - | rew_info (Rrls {erls,rew_ord=(rew_ord',_),calc=ca, ...}) =
137.18 - (rew_ord',erls, ca)
137.19 - | rew_info rls = raise error ("rew_info called with '"^rls2str rls^"'");
137.20 -
137.21 -(*FIXME.3.4.03:re-organize from_pblobj_or_detail_thm after rls' --> rls*)
137.22 -fun from_pblobj_or_detail_thm thm' p pt =
137.23 - let val (pbl,p',rls') = par_pbl_det pt p
137.24 - in if pbl
137.25 - then let (*val _= writeln("### from_pblobj_or_detail_thm: pbl=true")*)
137.26 - val thy' = get_obj g_domID pt p'
137.27 - val {rew_ord',erls,(*asm_thm,*)...} =
137.28 - get_met (get_obj g_metID pt p')
137.29 - (*val _= writeln("### from_pblobj_or_detail_thm: metID= "^
137.30 - (metID2str(get_obj g_metID pt p')))
137.31 - val _= writeln("### from_pblobj_or_detail_thm: erls= "^erls)*)
137.32 - in ("OK",thy',rew_ord',erls,(*put_asm*)false)
137.33 - end
137.34 - else ((*writeln("### from_pblobj_or_detail_thm: pbl=false");*)
137.35 - (*case assoc(!ruleset', rls') of !!!FIXME.3.4.03:re-organize !!!
137.36 - NONE => ("unknown ruleset '"^rls'^"'","","",Erls,false)
137.37 - | SOME rls =>*)
137.38 - let val thy' = get_obj g_domID pt (par_pblobj pt p)
137.39 - val (rew_ord',erls,(*asm_thm,*)_) = rew_info rls'
137.40 - in ("OK",thy',rew_ord',erls,false) end)
137.41 - end;
137.42 -(*FIXME.3.4.03:re-organize from_pblobj_or_detail_calc after rls' --> rls*)
137.43 -fun from_pblobj_or_detail_calc scrop p pt =
137.44 -(* val (scrop, p, pt) = (op_, p, pt);
137.45 - *)
137.46 - let val (pbl,p',rls') = par_pbl_det pt p
137.47 - in if pbl
137.48 - then let val thy' = get_obj g_domID pt p'
137.49 - val {calc = scr_isa_fns,...} =
137.50 - get_met (get_obj g_metID pt p')
137.51 - val opt = assoc (scr_isa_fns, scrop)
137.52 - in case opt of
137.53 - SOME isa_fn => ("OK",thy',isa_fn)
137.54 - | NONE => ("applicable_in Calculate: unknown '"^scrop^"'",
137.55 - "",("",e_evalfn)) end
137.56 - else (*case assoc(!ruleset', rls') of
137.57 - NONE => ("unknown ruleset '"^rls'^"'","",("",e_evalfn))
137.58 - | SOME rls => !!!FIXME.3.4.03:re-organize from_pblobj_or_detai*)
137.59 - (* val SOME rls = assoc(!ruleset', rls');
137.60 - *)
137.61 - let val thy' = get_obj g_domID pt (par_pblobj pt p);
137.62 - val (_,_,(*_,*)scr_isa_fns) = rew_info rls'(*rls*)
137.63 - in case assoc (scr_isa_fns, scrop) of
137.64 - SOME isa_fn => ("OK",thy',isa_fn)
137.65 - | NONE => ("applicable_in Calculate: unknown '"^scrop^"'",
137.66 - "",("",e_evalfn)) end
137.67 - end;
137.68 -(*------------------------------------------------------------------*)
137.69 -
137.70 -val op_and = Const ("op &", [bool, bool] ---> bool);
137.71 -(*> (cterm_of thy) (op_and $ Free("a",bool) $ Free("b",bool));
137.72 -val it = "a & b" : cterm
137.73 -*)
137.74 -fun mk_and a b = op_and $ a $ b;
137.75 -(*> (cterm_of thy)
137.76 - (mk_and (Free("a",bool)) (Free("b",bool)));
137.77 -val it = "a & b" : cterm*)
137.78 -
137.79 -fun mk_and [] = HOLogic.true_const
137.80 - | mk_and (t::[]) = t
137.81 - | mk_and (t::ts) =
137.82 - let fun mk t' (t::[]) = op_and $ t' $ t
137.83 - | mk t' (t::ts) = mk (op_and $ t' $ t) ts
137.84 - in mk t ts end;
137.85 -(*> val pred = map (term_of o the o (parse thy))
137.86 - ["#0 <= #9 + #4 * x","#0 <= sqrt x + sqrt (#-3 + x)"];
137.87 -> (cterm_of thy) (mk_and pred);
137.88 -val it = "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)" : cterm*)
137.89 -
137.90 -
137.91 -
137.92 -
137.93 -(*for Check_elementwise in applicable_in: [x=1,..] Assumptions -> (x,0<=x&..)*)
137.94 -fun mk_set thy pt p (Const ("List.list.Nil",_)) pred = (e_term, [])
137.95 -
137.96 - | mk_set thy pt p (Const ("Tools.UniversalList",_)) pred =
137.97 - (e_term, if pred <> Const ("Script.Assumptions",bool)
137.98 - then [pred]
137.99 - else (map fst) (get_assumptions_ pt (p,Res)))
137.100 -
137.101 -(* val pred = (term_of o the o (parse thy)) pred;
137.102 - val consts as Const ("List.list.Cons",_) $ eq $ _ = ft;
137.103 - mk_set thy pt p consts pred;
137.104 - *)
137.105 - | mk_set thy pt p (consts as Const ("List.list.Cons",_) $ eq $ _) pred =
137.106 - let val (bdv,_) = HOLogic.dest_eq eq;
137.107 - val pred = if pred <> Const ("Script.Assumptions",bool)
137.108 - then [pred]
137.109 - else (map fst) (get_assumptions_ pt (p,Res))
137.110 - in (bdv, pred) end
137.111 -
137.112 - | mk_set thy _ _ l _ =
137.113 - raise error ("check_elementwise: no set "^
137.114 - (Syntax.string_of_term (thy2ctxt thy) l));
137.115 -(*> val consts = str2term "[x=#4]";
137.116 -> val pred = str2term "Assumptions";
137.117 -> val pt = union_asm pt p
137.118 - [("#0 <= sqrt x + sqrt (#5 + x)",[11]),("#0 <= #9 + #4 * x",[22]),
137.119 - ("#0 <= x ^^^ #2 + #5 * x",[33]),("#0 <= #2 + x",[44])];
137.120 -> val p = [];
137.121 -> val (sss,ttt) = mk_set thy pt p consts pred;
137.122 -> (Syntax.string_of_term (thy2ctxt thy) sss,Syntax.string_of_term(thy2ctxt thy) ttt);
137.123 -val it = ("x","((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) & ...
137.124 -
137.125 - val consts = str2term "UniversalList";
137.126 - val pred = str2term "Assumptions";
137.127 -
137.128 -*)
137.129 -
137.130 -
137.131 -
137.132 -(*check a list (/set) of constants [c_1,..,c_n] for c_i:set (: in)*)
137.133 -(* val (erls,consts,(bdv,pred)) = (erl,ft,vp);
137.134 - val (consts,(bdv,pred)) = (ft,vp);
137.135 - *)
137.136 -fun check_elementwise thy erls all_results (bdv, asm) =
137.137 - let (*bdv extracted from ~~~~~~~~~~~ in mk_set already*)
137.138 - fun check sub =
137.139 - let val inst_ = map (subst_atomic [sub]) asm
137.140 - in case eval__true thy 1 inst_ [] erls of
137.141 - (asm', true) => ([HOLogic.mk_eq sub], asm')
137.142 - | (_, false) => ([],[])
137.143 - end;
137.144 - (*val _= writeln("### check_elementwise: res= "^(term2str all_results)^
137.145 - ", bdv= "^(term2str bdv)^", asm= "^(terms2str asm));*)
137.146 - val c' = isalist2list all_results
137.147 - val c'' = map (snd o HOLogic.dest_eq) c' (*assumes [x=1,x=2,..]*)
137.148 - val subs = map (pair bdv) c''
137.149 - in if asm = [] then (all_results, [])
137.150 - else ((apfst ((list2isalist bool) o flat)) o
137.151 - (apsnd flat) o split_list o (map check)) subs end;
137.152 -(* 20.5.03
137.153 -> val all_results = str2term "[x=a+b,x=b,x=3]";
137.154 -> val bdv = str2term "x";
137.155 -> val asm = str2term "(x ~= a) & (x ~= b)";
137.156 -> val erls = e_rls;
137.157 -> val (t, ts) = check_elementwise thy erls all_results (bdv, asm);
137.158 -> term2str t; writeln(terms2str ts);
137.159 -val it = "[x = a + b, x = b, x = c]" : string
137.160 -["a + b ~= a & a + b ~= b","b ~= a & b ~= b","c ~= a & c ~= b"]
137.161 -... with appropriate erls this should be:
137.162 -val it = "[x = a + b, x = c]" : string
137.163 -["b ~= 0 & a ~= 0", "3 ~= a & 3 ~= b"]
137.164 - ////// because b ~= b False*)
137.165 -
137.166 -
137.167 -
137.168 -(*before 5.03-----
137.169 -> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #3) + sqrt (#5 - #3)) &\
137.170 - \ #0 <= #25 + #-1 * #3 ^^^ #2) & #0 <= #4";
137.171 -> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct;
137.172 -val ct' = "True" : cterm'
137.173 -
137.174 -> val ct = "((#0 <= #18 & #0 <= sqrt (#5 + #-3) + sqrt (#5 - #-3)) &\
137.175 - \ #0 <= #25 + #-1 * #-3 ^^^ #2) & #0 <= #4";
137.176 -> val SOME(ct',_) = rewrite_set "Isac.thy" false "eval_rls" ct;
137.177 -val ct' = "True" : cterm'
137.178 -
137.179 -
137.180 -> val const = (term_of o the o (parse thy)) "(#3::real)";
137.181 -> val pred' = subst_atomic [(bdv,const)] pred;
137.182 -
137.183 -
137.184 -> val consts = (term_of o the o (parse thy)) "[x = #-3, x = #3]";
137.185 -> val bdv = (term_of o the o (parse thy)) "(x::real)";
137.186 -> val pred = (term_of o the o (parse thy))
137.187 - "((#0 <= #18 & #0 <= sqrt (#5 + x) + sqrt (#5 - x)) & #0 <= #25 + #-1 * x ^^^ #2) & #0 <= #4";
137.188 -> val ttt = check_elementwise thy consts (bdv, pred);
137.189 -> (cterm_of thy) ttt;
137.190 -val it = "[x = #-3, x = #3]" : cterm
137.191 -
137.192 -> val consts = (term_of o the o (parse thy)) "[x = #4]";
137.193 -> val bdv = (term_of o the o (parse thy)) "(x::real)";
137.194 -> val pred = (term_of o the o (parse thy))
137.195 - "#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #5 * x & #0 <= #2 + x";
137.196 -> val ttt = check_elementwise thy consts (bdv,pred);
137.197 -> (cterm_of thy) ttt;
137.198 -val it = "[x = #4]" : cterm
137.199 -
137.200 -> val consts = (term_of o the o (parse thy)) "[x = #-12 // #5]";
137.201 -> val bdv = (term_of o the o (parse thy)) "(x::real)";
137.202 -> val pred = (term_of o the o (parse thy))
137.203 - " #0 <= sqrt x + sqrt (#-3 + x) & #0 <= #9 + #4 * x & #0 <= x ^^^ #2 + #-3 * x & #0 <= #6 + x";
137.204 -> val ttt = check_elementwise thy consts (bdv,pred);
137.205 -> (cterm_of thy) ttt;
137.206 -val it = "[]" : cterm*)
137.207 -
137.208 -
137.209 -(* 14.1.01: for Tac-dummies in root-equ only: skip str until "("*)
137.210 -fun split_dummy str =
137.211 -let fun scan s' [] = (implode s', "")
137.212 - | scan s' (s::ss) = if s=" " then (implode s', implode ss)
137.213 - else scan (s'@[s]) ss;
137.214 -in ((scan []) o explode) str end;
137.215 -(* split_dummy "subproblem_equation_dummy (x=-#5//#12)";
137.216 -val it = ("subproblem_equation_dummy","(x=-#5//#12)") : string * string
137.217 -> split_dummy "x=-#5//#12";
137.218 -val it = ("x=-#5//#12","") : string * string*)
137.219 -
137.220 -
137.221 -
137.222 -
137.223 -(*.applicability of a tacic wrt. a calc-state (ptree,pos').
137.224 - additionally used by next_tac in the script-interpreter for sequence-tacs.
137.225 - tests for applicability are so expensive, that results (rewrites!)
137.226 - are kept in the return-value of 'type tac_'.
137.227 -.*)
137.228 -fun applicable_in (_:pos') _ (Init_Proof (ct', spec)) =
137.229 - Appl (Init_Proof' (ct', spec))
137.230 -
137.231 - | applicable_in (p,p_) pt Model_Problem =
137.232 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.233 - then Notappl ((tac2str Model_Problem)^
137.234 - " not for pos "^(pos'2str (p,p_)))
137.235 - else let val (PblObj{origin=(_,(_,pI',_),_),...}) = get_obj I pt p
137.236 - val {ppc,...} = get_pbt pI'
137.237 - val pbl = init_pbl ppc
137.238 - in Appl (Model_Problem' (pI', pbl, [])) end
137.239 -(* val Refine_Tacitly pI = m;
137.240 - *)
137.241 - | applicable_in (p,p_) pt (Refine_Tacitly pI) =
137.242 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.243 - then Notappl ((tac2str (Refine_Tacitly pI))^
137.244 - " not for pos "^(pos'2str (p,p_)))
137.245 - else (* val Refine_Tacitly pI = m;
137.246 - *)
137.247 - let val (PblObj {origin = (oris, (dI',_,_),_), ...}) = get_obj I pt p;
137.248 - val opt = refine_ori oris pI;
137.249 - in case opt of
137.250 - SOME pblID =>
137.251 - Appl (Refine_Tacitly' (pI, pblID,
137.252 - e_domID, e_metID, [](*filled in specify*)))
137.253 - | NONE => Notappl ((tac2str (Refine_Tacitly pI))^
137.254 - " not applicable") end
137.255 -(* val (p,p_) = ip;
137.256 - val Refine_Problem pI = m;
137.257 - *)
137.258 - | applicable_in (p,p_) pt (Refine_Problem pI) =
137.259 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.260 - then Notappl ((tac2str (Refine_Problem pI))^
137.261 - " not for pos "^(pos'2str (p,p_)))
137.262 - else
137.263 - let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_),
137.264 - probl=itms, ...}) = get_obj I pt p;
137.265 - val thy = if dI' = e_domID then dI else dI';
137.266 - val rfopt = refine_pbl (assoc_thy thy) pI itms;
137.267 - in case rfopt of
137.268 - NONE => Notappl ((tac2str (Refine_Problem pI))^" not applicable")
137.269 - | SOME (rf as (pI',_)) =>
137.270 -(* val SOME (rf as (pI',_)) = rfopt;
137.271 - *)
137.272 - if pI' = pI
137.273 - then Notappl ((tac2str (Refine_Problem pI))^" not applicable")
137.274 - else Appl (Refine_Problem' rf)
137.275 - end
137.276 -
137.277 - (*the specify-tacs have cterm' instead term:
137.278 - parse+error here!!!: see appl_add*)
137.279 - | applicable_in (p,p_) pt (Add_Given ct') =
137.280 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.281 - then Notappl ((tac2str (Add_Given ct'))^
137.282 - " not for pos "^(pos'2str (p,p_)))
137.283 - else Appl (Add_Given' (ct', [(*filled in specify_additem*)]))
137.284 - (*Add_.. should reject (dsc //) (see fmz=[] in sqrt*)
137.285 -
137.286 - | applicable_in (p,p_) pt (Del_Given ct') =
137.287 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.288 - then Notappl ((tac2str (Del_Given ct'))^
137.289 - " not for pos "^(pos'2str (p,p_)))
137.290 - else Appl (Del_Given' ct')
137.291 -
137.292 - | applicable_in (p,p_) pt (Add_Find ct') =
137.293 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.294 - then Notappl ((tac2str (Add_Find ct'))^
137.295 - " not for pos "^(pos'2str (p,p_)))
137.296 - else Appl (Add_Find' (ct', [(*filled in specify_additem*)]))
137.297 -
137.298 - | applicable_in (p,p_) pt (Del_Find ct') =
137.299 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.300 - then Notappl ((tac2str (Del_Find ct'))^
137.301 - " not for pos "^(pos'2str (p,p_)))
137.302 - else Appl (Del_Find' ct')
137.303 -
137.304 - | applicable_in (p,p_) pt (Add_Relation ct') =
137.305 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.306 - then Notappl ((tac2str (Add_Relation ct'))^
137.307 - " not for pos "^(pos'2str (p,p_)))
137.308 - else Appl (Add_Relation' (ct', [(*filled in specify_additem*)]))
137.309 -
137.310 - | applicable_in (p,p_) pt (Del_Relation ct') =
137.311 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.312 - then Notappl ((tac2str (Del_Relation ct'))^
137.313 - " not for pos "^(pos'2str (p,p_)))
137.314 - else Appl (Del_Relation' ct')
137.315 -
137.316 - | applicable_in (p,p_) pt (Specify_Theory dI) =
137.317 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.318 - then Notappl ((tac2str (Specify_Theory dI))^
137.319 - " not for pos "^(pos'2str (p,p_)))
137.320 - else Appl (Specify_Theory' dI)
137.321 -(* val (p,p_) = p; val Specify_Problem pID = m;
137.322 - val Specify_Problem pID = m;
137.323 - *)
137.324 - | applicable_in (p,p_) pt (Specify_Problem pID) =
137.325 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.326 - then Notappl ((tac2str (Specify_Problem pID))^
137.327 - " not for pos "^(pos'2str (p,p_)))
137.328 - else
137.329 - let val (PblObj {origin=(oris,(dI,pI,_),_),spec=(dI',pI',_),
137.330 - probl=itms, ...}) = get_obj I pt p;
137.331 - val thy = assoc_thy (if dI' = e_domID then dI else dI');
137.332 - val {ppc,where_,prls,...} = get_pbt pID;
137.333 - val pbl = if pI'=e_pblID andalso pI=e_pblID
137.334 - then (false, (init_pbl ppc, []))
137.335 - else match_itms_oris thy itms (ppc,where_,prls) oris;
137.336 - in Appl (Specify_Problem' (pID, pbl)) end
137.337 -(* val Specify_Method mID = nxt; val (p,p_) = p;
137.338 - *)
137.339 - | applicable_in (p,p_) pt (Specify_Method mID) =
137.340 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.341 - then Notappl ((tac2str (Specify_Method mID))^
137.342 - " not for pos "^(pos'2str (p,p_)))
137.343 - else Appl (Specify_Method' (mID,[(*filled in specify*)],
137.344 - [(*filled in specify*)]))
137.345 -
137.346 - | applicable_in (p,p_) pt (Apply_Method mI) =
137.347 - if not (is_pblobj (get_obj I pt p)) orelse p_ = Res
137.348 - then Notappl ((tac2str (Apply_Method mI))^
137.349 - " not for pos "^(pos'2str (p,p_)))
137.350 - else Appl (Apply_Method' (mI, NONE, e_istate (*filled in solve*)))
137.351 -
137.352 - | applicable_in (p,p_) pt (Check_Postcond pI) =
137.353 - if member op = [Pbl,Met] p_
137.354 - then Notappl ((tac2str (Check_Postcond pI))^
137.355 - " not for pos "^(pos'2str (p,p_)))
137.356 - else Appl (Check_Postcond'
137.357 - (pI,(e_term,[(*asm in solve*)])))
137.358 - (* in solve -"- ^^^^^^ gets returnvalue of scr*)
137.359 -
137.360 - (*these are always applicable*)
137.361 - | applicable_in (p,p_) _ (Take str) = Appl (Take' (str2term str))
137.362 - | applicable_in (p,p_) _ (Free_Solve) = Appl (Free_Solve')
137.363 -
137.364 -(* val m as Rewrite_Inst (subs, thm') = m;
137.365 - *)
137.366 - | applicable_in (p,p_) pt (m as Rewrite_Inst (subs, thm')) =
137.367 - if member op = [Pbl,Met] p_
137.368 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.369 - else
137.370 - let
137.371 - val pp = par_pblobj pt p;
137.372 - val thy' = (get_obj g_domID pt pp):theory';
137.373 - val thy = assoc_thy thy';
137.374 - val {rew_ord'=ro',erls=erls,...} =
137.375 - get_met (get_obj g_metID pt pp);
137.376 - val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
137.377 - Frm => (get_obj g_form pt p, p)
137.378 - | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
137.379 - | _ => raise error ("applicable_in: call by "^
137.380 - (pos'2str (p,p_)));
137.381 - in
137.382 - let val subst = subs2subst thy subs;
137.383 - val subs' = subst2subs' subst;
137.384 - in case rewrite_inst_ thy (assoc_rew_ord ro') erls
137.385 - (*put_asm*)false subst (assoc_thm' thy thm') f of
137.386 - SOME (f',asm) => Appl (
137.387 - Rewrite_Inst' (thy',ro',erls,(*put_asm*)false,subst,thm',
137.388 - (*term_of o the o (parse (assoc_thy thy'))*) f,
137.389 - (*(term_of o the o (parse (assoc_thy thy'))*) (f',
137.390 - (*map (term_of o the o (parse (assoc_thy thy')))*) asm)))
137.391 - | NONE => Notappl ((fst thm')^" not applicable") end
137.392 - handle _ => Notappl ("syntax error in "^(subs2str subs)) end
137.393 -
137.394 -(* val ((p,p_), pt, m as Rewrite thm') = (p, pt, m);
137.395 - val ((p,p_), pt, m as Rewrite thm') = (pos, pt, tac);
137.396 - *)
137.397 -| applicable_in (p,p_) pt (m as Rewrite thm') =
137.398 - if member op = [Pbl,Met] p_
137.399 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.400 - else
137.401 - let val (msg,thy',ro,rls',(*put_asm*)_)= from_pblobj_or_detail_thm thm' p pt;
137.402 - val thy = assoc_thy thy';
137.403 - val f = case p_ of
137.404 - Frm => get_obj g_form pt p
137.405 - | Res => (fst o (get_obj g_result pt)) p
137.406 - | _ => raise error ("applicable_in Rewrite: call by "^
137.407 - (pos'2str (p,p_)));
137.408 - in if msg = "OK"
137.409 - then
137.410 - ((*writeln("### applicable_in rls'= "^rls');*)
137.411 - (* val SOME (f',asm)=rewrite thy' ro (id_rls rls') put_asm thm' f;
137.412 - *)
137.413 - case rewrite_ thy (assoc_rew_ord ro)
137.414 - rls' false (assoc_thm' thy thm') f of
137.415 - SOME (f',asm) => Appl (
137.416 - Rewrite' (thy',ro,rls',(*put_asm*)false,thm', f, (f', asm)))
137.417 - | NONE => Notappl ("'"^(fst thm')^"' not applicable") )
137.418 - else Notappl msg
137.419 - end
137.420 -
137.421 -| applicable_in (p,p_) pt (m as Rewrite_Asm thm') =
137.422 - if member op = [Pbl,Met] p_
137.423 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.424 - else
137.425 - let
137.426 - val pp = par_pblobj pt p;
137.427 - val thy' = (get_obj g_domID pt pp):theory';
137.428 - val thy = assoc_thy thy';
137.429 - val {rew_ord'=ro',erls=erls,...} =
137.430 - get_met (get_obj g_metID pt pp);
137.431 - (*val put_asm = true;*)
137.432 - val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
137.433 - Frm => (get_obj g_form pt p, p)
137.434 - | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
137.435 - | _ => raise error ("applicable_in: call by "^
137.436 - (pos'2str (p,p_)));
137.437 - in case rewrite_ thy (assoc_rew_ord ro') erls
137.438 - (*put_asm*)false (assoc_thm' thy thm') f of
137.439 - SOME (f',asm) => Appl (
137.440 - Rewrite' (thy',ro',erls,(*put_asm*)false,thm', f, (f', asm)))
137.441 - | NONE => Notappl ("'"^(fst thm')^"' not applicable") end
137.442 -
137.443 - | applicable_in (p,p_) pt (m as Detail_Set_Inst (subs, rls)) =
137.444 - if member op = [Pbl,Met] p_
137.445 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.446 - else
137.447 - let
137.448 - val pp = par_pblobj pt p;
137.449 - val thy' = (get_obj g_domID pt pp):theory';
137.450 - val thy = assoc_thy thy';
137.451 - val {rew_ord'=ro',...} = get_met (get_obj g_metID pt pp);
137.452 - val f = case p_ of Frm => get_obj g_form pt p
137.453 - | Res => (fst o (get_obj g_result pt)) p
137.454 - | _ => raise error ("applicable_in: call by "^
137.455 - (pos'2str (p,p_)));
137.456 - in
137.457 - let val subst = subs2subst thy subs
137.458 - val subs' = subst2subs' subst
137.459 - in case rewrite_set_inst_ thy false subst (assoc_rls rls) f of
137.460 - SOME (f',asm) => Appl (
137.461 - Detail_Set_Inst' (thy',false,subst,assoc_rls rls, f, (f', asm)))
137.462 - | NONE => Notappl (rls^" not applicable") end
137.463 - handle _ => Notappl ("syntax error in "^(subs2str subs)) end
137.464 -
137.465 - | applicable_in (p,p_) pt (m as Rewrite_Set_Inst (subs, rls)) =
137.466 - if member op = [Pbl,Met] p_
137.467 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.468 - else
137.469 - let
137.470 - val pp = par_pblobj pt p;
137.471 - val thy' = (get_obj g_domID pt pp):theory';
137.472 - val thy = assoc_thy thy';
137.473 - val {rew_ord'=ro',(*asm_rls=asm_rls,*)...} =
137.474 - get_met (get_obj g_metID pt pp);
137.475 - val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
137.476 - Frm => (get_obj g_form pt p, p)
137.477 - | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
137.478 - | _ => raise error ("applicable_in: call by "^
137.479 - (pos'2str (p,p_)));
137.480 - in
137.481 - let val subst = subs2subst thy subs;
137.482 - val subs' = subst2subs' subst;
137.483 - in case rewrite_set_inst_ thy (*put_asm*)false subst (assoc_rls rls) f of
137.484 - SOME (f',asm) => Appl (
137.485 - Rewrite_Set_Inst' (thy',(*put_asm*)false,subst,assoc_rls rls, f, (f', asm)))
137.486 - | NONE => Notappl (rls^" not applicable") end
137.487 - handle _ => Notappl ("syntax error in "^(subs2str subs)) end
137.488 -
137.489 - | applicable_in (p,p_) pt (m as Rewrite_Set rls) =
137.490 - if member op = [Pbl,Met] p_
137.491 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.492 - else
137.493 - let
137.494 - val pp = par_pblobj pt p;
137.495 - val thy' = (get_obj g_domID pt pp):theory';
137.496 - val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
137.497 - Frm => (get_obj g_form pt p, p)
137.498 - | Res => ((fst o (get_obj g_result pt)) p, lev_on p)
137.499 - | _ => raise error ("applicable_in: call by "^
137.500 - (pos'2str (p,p_)));
137.501 - in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of
137.502 - SOME (f',asm) =>
137.503 - ((*writeln("#.# applicable_in Rewrite_Set,2f'= "^f');*)
137.504 - Appl (Rewrite_Set' (thy',(*put_asm*)false,assoc_rls rls, f, (f', asm)))
137.505 - )
137.506 - | NONE => Notappl (rls^" not applicable") end
137.507 -
137.508 - | applicable_in (p,p_) pt (m as Detail_Set rls) =
137.509 - if member op = [Pbl,Met] p_
137.510 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.511 - else
137.512 - let val pp = par_pblobj pt p
137.513 - val thy' = (get_obj g_domID pt pp):theory'
137.514 - val f = case p_ of
137.515 - Frm => get_obj g_form pt p
137.516 - | Res => (fst o (get_obj g_result pt)) p
137.517 - | _ => raise error ("applicable_in: call by "^
137.518 - (pos'2str (p,p_)));
137.519 - in case rewrite_set_ (assoc_thy thy') false (assoc_rls rls) f of
137.520 - SOME (f',asm) =>
137.521 - Appl (Detail_Set' (thy',false,assoc_rls rls, f, (f',asm)))
137.522 - | NONE => Notappl (rls^" not applicable") end
137.523 -
137.524 -
137.525 - | applicable_in p pt (End_Ruleset) =
137.526 - raise error ("applicable_in: not impl. for "^
137.527 - (tac2str End_Ruleset))
137.528 -
137.529 -(* val ((p,p_), pt, (m as Calculate op_)) = (p, pt, m);
137.530 - *)
137.531 -| applicable_in (p,p_) pt (m as Calculate op_) =
137.532 - if member op = [Pbl,Met] p_
137.533 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.534 - else
137.535 - let
137.536 - val (msg,thy',isa_fn) = from_pblobj_or_detail_calc op_ p pt;
137.537 - val f = case p_ of
137.538 - Frm => get_obj g_form pt p
137.539 - | Res => (fst o (get_obj g_result pt)) p
137.540 - in if msg = "OK" then
137.541 - case calculate_ (assoc_thy thy') isa_fn f of
137.542 - SOME (f', (id, thm)) =>
137.543 - Appl (Calculate' (thy',op_, f, (f', (id, string_of_thmI thm))))
137.544 - | NONE => Notappl ("'calculate "^op_^"' not applicable")
137.545 - else Notappl msg
137.546 - end
137.547 -
137.548 -(*Substitute combines two different kind of "substitution":
137.549 - (1) subst_atomic: for ?a..?z
137.550 - (2) Pattern.match: for solving equational systems
137.551 - (which raises exn for ?a..?z)*)
137.552 - | applicable_in (p,p_) pt (m as Substitute sube) =
137.553 - if member op = [Pbl,Met] p_
137.554 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.555 - else let val pp = par_pblobj pt p
137.556 - val thy = assoc_thy (get_obj g_domID pt pp)
137.557 - val f = case p_ of
137.558 - Frm => get_obj g_form pt p
137.559 - | Res => (fst o (get_obj g_result pt)) p
137.560 - val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp)
137.561 - val subte = sube2subte sube
137.562 - val subst = sube2subst thy sube
137.563 - in if foldl and_ (true, map contains_Var subte)
137.564 - (*1*)
137.565 - then let val f' = subst_atomic subst f
137.566 - in if f = f' then Notappl (sube2str sube^" not applicable")
137.567 - else Appl (Substitute' (subte, f, f'))
137.568 - end
137.569 - (*2*)
137.570 - else case rewrite_terms_ thy (assoc_rew_ord rew_ord')
137.571 - erls subte f of
137.572 - SOME (f', _) => Appl (Substitute' (subte, f, f'))
137.573 - | NONE => Notappl (sube2str sube^" not applicable")
137.574 - end
137.575 -(*-------WN08114 interrupted with error in polyminus.sml "11 = 11"
137.576 - | applicable_in (p,p_) pt (m as Substitute sube) =
137.577 - if member op = [Pbl,Met] p_
137.578 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.579 - else let val pp = par_pblobj pt p
137.580 - val thy = assoc_thy (get_obj g_domID pt pp)
137.581 - val f = case p_ of
137.582 - Frm => get_obj g_form pt p
137.583 - | Res => (fst o (get_obj g_result pt)) p
137.584 - val {rew_ord',erls,...} = get_met (get_obj g_metID pt pp)
137.585 - val subte = sube2subte sube
137.586 - in case rewrite_terms_ thy (assoc_rew_ord rew_ord') erls subte f of
137.587 - SOME (f', _) => Appl (Substitute' (subte, f, f'))
137.588 - | NONE => Notappl (sube2str sube^" not applicable")
137.589 - end
137.590 -------------------*)
137.591 -
137.592 - | applicable_in p pt (Apply_Assumption cts') =
137.593 - (raise error ("applicable_in: not impl. for "^
137.594 - (tac2str (Apply_Assumption cts'))))
137.595 -
137.596 - (*'logical' applicability wrt. script in locate: Inconsistent?*)
137.597 - | applicable_in (p,p_) pt (m as Take ct') =
137.598 - if member op = [Pbl,Met] p_
137.599 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.600 - else
137.601 - let val thy' = get_obj g_domID pt (par_pblobj pt p);
137.602 - in (case parse (assoc_thy thy') ct' of
137.603 - SOME ct => Appl (Take' (term_of ct))
137.604 - | NONE => Notappl ("syntax error in "^ct'))
137.605 - end
137.606 -
137.607 - | applicable_in p pt (Take_Inst ct') =
137.608 - raise error ("applicable_in: not impl. for "^
137.609 - (tac2str (Take_Inst ct')))
137.610 -
137.611 - | applicable_in p pt (Group (con, ints)) =
137.612 - raise error ("applicable_in: not impl. for "^
137.613 - (tac2str (Group (con, ints))))
137.614 -
137.615 - | applicable_in (p,p_) pt (m as Subproblem (domID, pblID)) =
137.616 - if member op = [Pbl,Met] p_
137.617 - then (*maybe Apply_Method has already been done*)
137.618 - case get_obj g_env pt p of
137.619 - SOME is => Appl (Subproblem' ((domID, pblID, e_metID), [],
137.620 - e_term, [], subpbl domID pblID))
137.621 - | NONE => Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.622 - else (*somewhere later in the script*)
137.623 - Appl (Subproblem' ((domID, pblID, e_metID), [],
137.624 - e_term, [], subpbl domID pblID))
137.625 -
137.626 - | applicable_in p pt (End_Subproblem) =
137.627 - raise error ("applicable_in: not impl. for "^
137.628 - (tac2str (End_Subproblem)))
137.629 -
137.630 - | applicable_in p pt (CAScmd ct') =
137.631 - raise error ("applicable_in: not impl. for "^
137.632 - (tac2str (CAScmd ct')))
137.633 -
137.634 - | applicable_in p pt (Split_And) =
137.635 - raise error ("applicable_in: not impl. for "^
137.636 - (tac2str (Split_And)))
137.637 - | applicable_in p pt (Conclude_And) =
137.638 - raise error ("applicable_in: not impl. for "^
137.639 - (tac2str (Conclude_And)))
137.640 - | applicable_in p pt (Split_Or) =
137.641 - raise error ("applicable_in: not impl. for "^
137.642 - (tac2str (Split_Or)))
137.643 - | applicable_in p pt (Conclude_Or) =
137.644 - raise error ("applicable_in: not impl. for "^
137.645 - (tac2str (Conclude_Or)))
137.646 -
137.647 - | applicable_in (p,p_) pt (Begin_Trans) =
137.648 - let
137.649 - val (f,p) = case p_ of (*p 12.4.00 unnecessary*)
137.650 - (*_____ implizit Take in gen*)
137.651 - Frm => (get_obj g_form pt p, (lev_on o lev_dn) p)
137.652 - | Res => ((fst o (get_obj g_result pt)) p, (lev_on o lev_dn o lev_on) p)
137.653 - | _ => raise error ("applicable_in: call by "^
137.654 - (pos'2str (p,p_)));
137.655 - val thy' = get_obj g_domID pt (par_pblobj pt p);
137.656 - in (Appl (Begin_Trans' f))
137.657 - handle _ => raise error ("applicable_in: Begin_Trans finds \
137.658 - \syntaxerror in '"^(term2str f)^"'") end
137.659 -
137.660 - (*TODO: check parent branches*)
137.661 - | applicable_in (p,p_) pt (End_Trans) =
137.662 - let val thy' = get_obj g_domID pt (par_pblobj pt p);
137.663 - in if p_ = Res
137.664 - then Appl (End_Trans' (get_obj g_result pt p))
137.665 - else Notappl "'End_Trans' is not applicable at \
137.666 - \the beginning of a transitive sequence"
137.667 - (*TODO: check parent branches*)
137.668 - end
137.669 -
137.670 - | applicable_in p pt (Begin_Sequ) =
137.671 - raise error ("applicable_in: not impl. for "^
137.672 - (tac2str (Begin_Sequ)))
137.673 - | applicable_in p pt (End_Sequ) =
137.674 - raise error ("applicable_in: not impl. for "^
137.675 - (tac2str (End_Sequ)))
137.676 - | applicable_in p pt (Split_Intersect) =
137.677 - raise error ("applicable_in: not impl. for "^
137.678 - (tac2str (Split_Intersect)))
137.679 - | applicable_in p pt (End_Intersect) =
137.680 - raise error ("applicable_in: not impl. for "^
137.681 - (tac2str (End_Intersect)))
137.682 -(* val Appl (Check_elementwse'(t1,"Assumptions",t2)) = it;
137.683 - val (vvv,ppp) = vp;
137.684 -
137.685 - val Check_elementwise pred = m;
137.686 -
137.687 - val ((p,p_), Check_elementwise pred) = (p, m);
137.688 - *)
137.689 - | applicable_in (p,p_) pt (m as Check_elementwise pred) =
137.690 - if member op = [Pbl,Met] p_
137.691 - then Notappl ((tac2str m)^" not for pos "^(pos'2str (p,p_)))
137.692 - else
137.693 - let
137.694 - val pp = par_pblobj pt p;
137.695 - val thy' = (get_obj g_domID pt pp):theory';
137.696 - val thy = assoc_thy thy'
137.697 - val metID = (get_obj g_metID pt pp)
137.698 - val {crls,...} = get_met metID
137.699 - (*val _=writeln("### applicable_in Check_elementwise: crls= "^crls)
137.700 - val _=writeln("### applicable_in Check_elementwise: pred= "^pred)*)
137.701 - (*val erl = the (assoc'(!ruleset',crls))*)
137.702 - val (f,asm) = case p_ of
137.703 - Frm => (get_obj g_form pt p , [])
137.704 - | Res => get_obj g_result pt p;
137.705 - (*val _= writeln("### applicable_in Check_elementwise: f= "^f);*)
137.706 - val vp = mk_set thy pt p f ((term_of o the o (parse thy)) pred);
137.707 - (*val (v,p)=vp;val _=writeln("### applicable_in Check_elementwise: vp= "^
137.708 - pair2str(term2str v,term2str p))*)
137.709 - in case f of
137.710 - Const ("List.list.Cons",_) $ _ $ _ =>
137.711 - Appl (Check_elementwise'
137.712 - (f, pred,
137.713 - ((*writeln("### applicable_in Check_elementwise: --> "^
137.714 - (res2str (check_elementwise thy crls f vp)));*)
137.715 - check_elementwise thy crls f vp)))
137.716 - | Const ("Tools.UniversalList",_) =>
137.717 - Appl (Check_elementwise' (f, pred, (f,asm)))
137.718 - | Const ("List.list.Nil",_) =>
137.719 - (*Notappl "not applicable to empty list" 3.6.03*)
137.720 - Appl (Check_elementwise' (f, pred, (f,asm(*[] 11.6.03???*))))
137.721 - | _ => Notappl ("not applicable: "^(term2str f)^" should be constants")
137.722 - end
137.723 -
137.724 - | applicable_in (p,p_) pt Or_to_List =
137.725 - if member op = [Pbl,Met] p_
137.726 - then Notappl ((tac2str Or_to_List)^" not for pos "^(pos'2str (p,p_)))
137.727 - else
137.728 - let
137.729 - val pp = par_pblobj pt p;
137.730 - val thy' = (get_obj g_domID pt pp):theory';
137.731 - val thy = assoc_thy thy';
137.732 - val f = case p_ of
137.733 - Frm => get_obj g_form pt p
137.734 - | Res => (fst o (get_obj g_result pt)) p;
137.735 - in (let val ls = or2list f
137.736 - in Appl (Or_to_List' (f, ls)) end)
137.737 - handle _ => Notappl ("'Or_to_List' not applicable to "^(term2str f))
137.738 - end
137.739 -
137.740 - | applicable_in p pt (Collect_Trues) =
137.741 - raise error ("applicable_in: not impl. for "^
137.742 - (tac2str (Collect_Trues)))
137.743 -
137.744 - | applicable_in p pt (Empty_Tac) =
137.745 - Notappl "Empty_Tac is not applicable"
137.746 -
137.747 - | applicable_in (p,p_) pt (Tac id) =
137.748 - let
137.749 - val pp = par_pblobj pt p;
137.750 - val thy' = (get_obj g_domID pt pp):theory';
137.751 - val thy = assoc_thy thy';
137.752 - val f = case p_ of
137.753 - Frm => get_obj g_form pt p
137.754 - | Res => (fst o (get_obj g_result pt)) p;
137.755 - in case id of
137.756 - "subproblem_equation_dummy" =>
137.757 - if is_expliceq f
137.758 - then Appl (Tac_ (thy, term2str f, id,
137.759 - "subproblem_equation_dummy ("^(term2str f)^")"))
137.760 - else Notappl "applicable only to equations made explicit"
137.761 - | "solve_equation_dummy" =>
137.762 - let (*val _= writeln("### applicable_in: solve_equation_dummy: f= "
137.763 - ^f);*)
137.764 - val (id',f') = split_dummy (term2str f);
137.765 - (*val _= writeln("### applicable_in: f'= "^f');*)
137.766 - (*val _= (term_of o the o (parse thy)) f';*)
137.767 - (*val _= writeln"### applicable_in: solve_equation_dummy";*)
137.768 - in if id' <> "subproblem_equation_dummy" then Notappl "no subproblem"
137.769 - else if is_expliceq ((term_of o the o (parse thy)) f')
137.770 - then Appl (Tac_ (thy, term2str f, id, "[" ^ f' ^ "]"))
137.771 - else error ("applicable_in: f= " ^ f') end
137.772 - | _ => Appl (Tac_ (thy, term2str f, id, term2str f)) end
137.773 -
137.774 - | applicable_in p pt End_Proof' = Appl End_Proof''
137.775 -
137.776 - | applicable_in _ _ m =
137.777 - raise error ("applicable_in called for "^(tac2str m));
137.778 -
137.779 -(*WN060614 unused*)
137.780 -fun tac2tac_ pt p m =
137.781 - case applicable_in p pt m of
137.782 - Appl (m') => m'
137.783 - | Notappl _ => raise error ("tac2mstp': fails with"^
137.784 - (tac2str m));
137.785 -
138.1 --- a/src/Tools/isac/ME/calchead.sml Wed Aug 25 15:15:01 2010 +0200
138.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
138.3 @@ -1,2257 +0,0 @@
138.4 -(* Specify-phase: specifying and modeling a problem or a subproblem. The
138.5 - most important types are declared in mstools.sml.
138.6 - author: Walther Neuper
138.7 - 991122
138.8 - (c) due to copyright terms
138.9 -
138.10 -use"ME/calchead.sml";
138.11 -use"calchead.sml";
138.12 -12345678901234567890123456789012345678901234567890123456789012345678901234567890
138.13 - 10 20 30 40 50 60 70 80
138.14 -*)
138.15 -
138.16 -(* TODO interne Funktionen aus sig entfernen *)
138.17 -signature CALC_HEAD =
138.18 - sig
138.19 - datatype additm = Add of SpecifyTools.itm | Err of string
138.20 - val all_dsc_in : SpecifyTools.itm_ list -> Term.term list
138.21 - val all_modspec : ptree * pos' -> ptree * pos'
138.22 - datatype appl = Appl of tac_ | Notappl of string
138.23 - val appl_add :
138.24 - theory ->
138.25 - string ->
138.26 - SpecifyTools.ori list ->
138.27 - SpecifyTools.itm list ->
138.28 - (string * (Term.term * Term.term)) list -> cterm' -> additm
138.29 - type calcstate
138.30 - type calcstate'
138.31 - val chk_vars : term ppc -> string * Term.term list
138.32 - val chktyp :
138.33 - theory -> int * term list * term list -> term
138.34 - val chktyps :
138.35 - theory -> term list * term list -> term list
138.36 - val complete_metitms :
138.37 - SpecifyTools.ori list ->
138.38 - SpecifyTools.itm list ->
138.39 - SpecifyTools.itm list -> pat list -> SpecifyTools.itm list
138.40 - val complete_mod_ : ori list * pat list * pat list * itm list ->
138.41 - itm list * itm list
138.42 - val complete_mod : ptree * pos' -> ptree * (pos * pos_)
138.43 - val complete_spec : ptree * pos' -> ptree * pos'
138.44 - val cpy_nam :
138.45 - pat list -> preori list -> pat -> preori
138.46 - val e_calcstate : calcstate
138.47 - val e_calcstate' : calcstate'
138.48 - val eq1 : ''a -> 'b * (''a * 'c) -> bool
138.49 - val eq3 :
138.50 - ''a -> Term.term -> 'b * 'c * 'd * ''a * SpecifyTools.itm_ -> bool
138.51 - val eq4 : ''a -> 'b * ''a list * 'c * 'd * 'e -> bool
138.52 - val eq5 :
138.53 - 'a * 'b * 'c * 'd * SpecifyTools.itm_ ->
138.54 - 'e * 'f * 'g * Term.term * 'h -> bool
138.55 - val eq_dsc : SpecifyTools.itm * SpecifyTools.itm -> bool
138.56 - val eq_pos' : ''a * pos_ -> ''a * pos_ -> bool
138.57 - val f_mout : theory -> mout -> Term.term
138.58 - val filter_outs :
138.59 - SpecifyTools.ori list ->
138.60 - SpecifyTools.itm list -> SpecifyTools.ori list
138.61 - val filter_pbt :
138.62 - SpecifyTools.ori list ->
138.63 - ('a * (Term.term * 'b)) list -> SpecifyTools.ori list
138.64 - val foldl1 : ('a * 'a -> 'a) -> 'a list -> 'a
138.65 - val foldr1 : ('a * 'a -> 'a) -> 'a list -> 'a
138.66 - val form : 'a -> ptree -> (string * ('a * pos_) * Term.term) list
138.67 - val formres : 'a -> ptree -> (string * ('a * pos_) * Term.term) list
138.68 - val gen_ins' : ('a * 'a -> bool) -> 'a * 'a list -> 'a list
138.69 - val get_formress :
138.70 - (string * (pos * pos_) * Term.term) list list ->
138.71 - pos -> ptree list -> (string * (pos * pos_) * Term.term) list
138.72 - val get_forms :
138.73 - (string * (pos * pos_) * Term.term) list list ->
138.74 - posel list -> ptree list -> (string * (pos * pos_) * Term.term) list
138.75 - val get_interval : pos' -> pos' -> int -> ptree -> (pos' * term) list
138.76 - val get_ocalhd : ptree * pos' -> ocalhd
138.77 - val get_spec_form : tac_ -> pos' -> ptree -> mout
138.78 - val geti_ct :
138.79 - theory ->
138.80 - SpecifyTools.ori -> SpecifyTools.itm -> string * cterm'
138.81 - val getr_ct : theory -> SpecifyTools.ori -> string * cterm'
138.82 - val has_list_type : Term.term -> bool
138.83 - val header : pos_ -> pblID -> metID -> pblmet
138.84 - val insert_ppc :
138.85 - theory ->
138.86 - int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ ->
138.87 - SpecifyTools.itm list -> SpecifyTools.itm list
138.88 - val insert_ppc' :
138.89 - SpecifyTools.itm -> SpecifyTools.itm list -> SpecifyTools.itm list
138.90 - val is_complete_mod : ptree * pos' -> bool
138.91 - val is_complete_mod_ : SpecifyTools.itm list -> bool
138.92 - val is_complete_modspec : ptree * pos' -> bool
138.93 - val is_complete_spec : ptree * pos' -> bool
138.94 - val is_copy_named : 'a * ('b * Term.term) -> bool
138.95 - val is_copy_named_idstr : string -> bool
138.96 - val is_error : SpecifyTools.itm_ -> bool
138.97 - val is_field_correct : ''a -> ''b -> (''a * ''b list) list -> bool
138.98 - val is_known :
138.99 - theory ->
138.100 - string ->
138.101 - SpecifyTools.ori list ->
138.102 - Term.term -> string * SpecifyTools.ori * Term.term list
138.103 - val is_list_type : Term.typ -> bool
138.104 - val is_notyet_input :
138.105 - theory ->
138.106 - SpecifyTools.itm list ->
138.107 - Term.term list ->
138.108 - SpecifyTools.ori ->
138.109 - ('a * (Term.term * Term.term)) list -> string * SpecifyTools.itm
138.110 - val is_parsed : SpecifyTools.itm_ -> bool
138.111 - val is_untouched : SpecifyTools.itm -> bool
138.112 - val matc :
138.113 - theory ->
138.114 - pat list ->
138.115 - Term.term list ->
138.116 - (int list * string * Term.term * Term.term list) list ->
138.117 - (int list * string * Term.term * Term.term list) list
138.118 - val match_ags :
138.119 - theory -> pat list -> Term.term list -> SpecifyTools.ori list
138.120 - val maxl : int list -> int
138.121 - val match_ags_msg : string list -> Term.term -> Term.term list -> unit
138.122 - val memI : ''a list -> ''a -> bool
138.123 - val mk_additem : string -> cterm' -> tac
138.124 - val mk_delete : theory -> string -> SpecifyTools.itm_ -> tac
138.125 - val mtc :
138.126 - theory -> pat -> Term.term -> SpecifyTools.preori option
138.127 - val nxt_add :
138.128 - theory ->
138.129 - SpecifyTools.ori list ->
138.130 - (string * (Term.term * 'a)) list ->
138.131 - SpecifyTools.itm list -> (string * cterm') option
138.132 - val nxt_model_pbl : tac_ -> ptree * (int list * pos_) -> tac_
138.133 - val nxt_spec :
138.134 - pos_ ->
138.135 - bool ->
138.136 - SpecifyTools.ori list ->
138.137 - spec ->
138.138 - SpecifyTools.itm list * SpecifyTools.itm list ->
138.139 - (string * (Term.term * 'a)) list * (string * (Term.term * 'b)) list ->
138.140 - spec -> pos_ * tac
138.141 - val nxt_specif : tac -> ptree * (int list * pos_) -> calcstate'
138.142 - val nxt_specif_additem :
138.143 - string -> cterm' -> ptree * (int list * pos_) -> calcstate'
138.144 - val nxt_specify_init_calc : fmz -> calcstate
138.145 - val ocalhd_complete :
138.146 - SpecifyTools.itm list ->
138.147 - (bool * Term.term) list -> domID * pblID * metID -> bool
138.148 - val ori2Coritm :
138.149 - pat list -> ori -> itm
138.150 - val ori_2itm :
138.151 - 'a ->
138.152 - SpecifyTools.itm_ ->
138.153 - Term.term -> Term.term list -> SpecifyTools.ori -> SpecifyTools.itm
138.154 - val overwrite_ppc :
138.155 - theory ->
138.156 - int * SpecifyTools.vats * bool * string * SpecifyTools.itm_ ->
138.157 - SpecifyTools.itm list ->
138.158 - (int * SpecifyTools.vats * bool * string * SpecifyTools.itm_) list
138.159 - val parse_ok : SpecifyTools.itm_ list -> bool
138.160 - val posform2str : pos' * ptform -> string
138.161 - val posforms2str : (pos' * ptform) list -> string
138.162 - val posterms2str : (pos' * term) list -> string (*tests only*)
138.163 - val ppc135list : 'a SpecifyTools.ppc -> 'a list
138.164 - val ppc2list : 'a SpecifyTools.ppc -> 'a list
138.165 - val pt_extract :
138.166 - ptree * (int list * pos_) ->
138.167 - ptform * tac option * Term.term list
138.168 - val pt_form : ppobj -> ptform
138.169 - val pt_model : ppobj -> pos_ -> ptform
138.170 - val reset_calchead : ptree * pos' -> ptree * pos'
138.171 - val seek_oridts :
138.172 - theory ->
138.173 - string ->
138.174 - Term.term * Term.term list ->
138.175 - (int * SpecifyTools.vats * string * Term.term * Term.term list) list
138.176 - -> string * SpecifyTools.ori * Term.term list
138.177 - val seek_orits :
138.178 - theory ->
138.179 - string ->
138.180 - Term.term list ->
138.181 - (int * SpecifyTools.vats * string * Term.term * Term.term list) list
138.182 - -> string * SpecifyTools.ori * Term.term list
138.183 - val seek_ppc :
138.184 - int -> SpecifyTools.itm list -> SpecifyTools.itm option
138.185 - val show_pt : ptree -> unit
138.186 - val some_spec : spec -> spec -> spec
138.187 - val specify :
138.188 - tac_ ->
138.189 - pos' ->
138.190 - cid ->
138.191 - ptree ->
138.192 - (posel list * pos_) * ((posel list * pos_) * istate) * mout * tac *
138.193 - safe * ptree
138.194 - val specify_additem :
138.195 - string ->
138.196 - cterm' * 'a ->
138.197 - int list * pos_ ->
138.198 - 'b ->
138.199 - ptree ->
138.200 - (pos * pos_) * ((pos * pos_) * istate) * mout * tac * safe * ptree
138.201 - val tag_form : theory -> term * term -> term
138.202 - val test_types : theory -> Term.term * Term.term list -> string
138.203 - val typeless : Term.term -> Term.term
138.204 - val unbound_ppc : term SpecifyTools.ppc -> Term.term list
138.205 - val vals_of_oris : SpecifyTools.ori list -> Term.term list
138.206 - val variants_in : Term.term list -> int
138.207 - val vars_of_pbl_ : ('a * ('b * Term.term)) list -> Term.term list
138.208 - val vars_of_pbl_' : ('a * ('b * Term.term)) list -> Term.term list
138.209 - end
138.210 -
138.211 -
138.212 -
138.213 -
138.214 -
138.215 -(*---------------------------------------------------------------------*)
138.216 -structure CalcHead (**): CALC_HEAD(**) =
138.217 -
138.218 -struct
138.219 -(*---------------------------------------------------------------------*)
138.220 -
138.221 -(* datatypes *)
138.222 -
138.223 -(*.the state wich is stored after each step of calculation; it contains
138.224 - the calc-state and a list of [tac,istate](="tacis") to be applied.
138.225 - the last_elem tacis is the first to apply to the calc-state and
138.226 - the (only) one shown to the front-end as the 'proposed tac'.
138.227 - the calc-state resulting from the application of tacis is not stored,
138.228 - because the tacis hold enought information for efficiently rebuilding
138.229 - this state just by "fun generate ".*)
138.230 -type calcstate =
138.231 - (ptree * pos') * (*the calc-state to which the tacis could be applied*)
138.232 - (taci list); (*ev. several (hidden) steps;
138.233 - in REVERSE order: first tac_ to apply is last_elem*)
138.234 -val e_calcstate = ((EmptyPtree, e_pos'), [e_taci]):calcstate;
138.235 -
138.236 -(*the state used during one calculation within the mathengine; it contains
138.237 - a list of [tac,istate](="tacis") which generated the the calc-state;
138.238 - while this state's tacis are extended by each (internal) step,
138.239 - the calc-state is used for creating new nodes in the calc-tree
138.240 - (eg. applicable_in requires several particular nodes of the calc-tree)
138.241 - and then replaced by the the newly created;
138.242 - on leave of the mathengine the resuing calc-state is dropped anyway,
138.243 - because the tacis hold enought information for efficiently rebuilding
138.244 - this state just by "fun generate ".*)
138.245 -type calcstate' =
138.246 - taci list * (*cas. several (hidden) steps;
138.247 - in REVERSE order: first tac_ to apply is last_elem*)
138.248 - pos' list * (*a "continuous" sequence of pos',
138.249 - deleted by application of taci list*)
138.250 - (ptree * pos'); (*the calc-state resulting from the application of tacis*)
138.251 -val e_calcstate' = ([e_taci], [e_pos'], (EmptyPtree, e_pos')):calcstate';
138.252 -
138.253 -(*FIXXXME.WN020430 intermediate hack for fun ass_up*)
138.254 -fun f_mout thy (Form' (FormKF (_,_,_,_,f))) = (term_of o the o (parse thy)) f
138.255 - | f_mout thy _ = raise error "f_mout: not called with formula";
138.256 -
138.257 -
138.258 -(*.is the calchead complete ?.*)
138.259 -fun ocalhd_complete (its: itm list) (pre: (bool * term) list) (dI,pI,mI) =
138.260 - foldl and_ (true, map #3 its) andalso
138.261 - foldl and_ (true, map #1 pre) andalso
138.262 - dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID;
138.263 -
138.264 -
138.265 -(* make a term 'typeless' for comparing with another 'typeless' term;
138.266 - 'type-less' usually is illtyped *)
138.267 -fun typeless (Const(s,_)) = (Const(s,e_type))
138.268 - | typeless (Free(s,_)) = (Free(s,e_type))
138.269 - | typeless (Var(n,_)) = (Var(n,e_type))
138.270 - | typeless (Bound i) = (Bound i)
138.271 - | typeless (Abs(s,_,t)) = Abs(s,e_type, typeless t)
138.272 - | typeless (t1 $ t2) = (typeless t1) $ (typeless t2);
138.273 -(*
138.274 -> val (SOME ct) = parse thy "max_relation (A=#2*a*b - a^^^#2)";
138.275 -> val (_,t1) = split_dsc_t hs (term_of ct);
138.276 -> val (SOME ct) = parse thy "A=#2*a*b - a^^^#2";
138.277 -> val (_,t2) = split_dsc_t hs (term_of ct);
138.278 -> typeless t1 = typeless t2;
138.279 -val it = true : bool
138.280 -*)
138.281 -
138.282 -
138.283 -
138.284 -(*.to an input (d,ts) find the according ori and insert the ts.*)
138.285 -(*WN.11.03: + dont take first inter<>[]*)
138.286 -fun seek_oridts thy sel (d,ts) [] =
138.287 - ("'"^(Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts)))^
138.288 - "' not found (typed)", (0,[],sel,d,ts):ori, [])
138.289 - (* val (id,vat,sel',d',ts')::oris = ori;
138.290 - val (id,vat,sel',d',ts') = ori;
138.291 - *)
138.292 - | seek_oridts thy sel (d,ts) ((id,vat,sel',d',ts')::(oris:ori list)) =
138.293 - if sel = sel' andalso d=d' andalso (inter op = ts ts') <> []
138.294 - then if sel = sel'
138.295 - then ("",
138.296 - (id,vat,sel,d, inter op = ts ts'):ori,
138.297 - ts')
138.298 - else ((Syntax.string_of_term (thy2ctxt thy) (comp_dts thy (d,ts)))
138.299 - ^ " not for " ^ sel,
138.300 - e_ori_,
138.301 - [])
138.302 - else seek_oridts thy sel (d,ts) oris;
138.303 -
138.304 -(*.to an input (_,ts) find the according ori and insert the ts.*)
138.305 -fun seek_orits thy sel ts [] =
138.306 - ("'"^
138.307 - (strs2str (map (Syntax.string_of_term (thy2ctxt thy)) ts))^
138.308 - "' not found (typed)", e_ori_, [])
138.309 - | seek_orits thy sel ts ((id,vat,sel',d,ts')::(oris:ori list)) =
138.310 - if sel = sel' andalso (inter op = ts ts') <> []
138.311 - then if sel = sel'
138.312 - then ("",
138.313 - (id,vat,sel,d, inter op = ts ts'):ori,
138.314 - ts')
138.315 - else (((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts)
138.316 - ^ " not for "^sel,
138.317 - e_ori_,
138.318 - [])
138.319 - else seek_orits thy sel ts oris;
138.320 -(* false
138.321 -> val ((id,vat,sel',d,ts')::(ori':ori)) = ori;
138.322 -> seek_orits thy sel ts [(id,vat,sel',d,ts')];
138.323 -uncaught exception TYPE
138.324 -> seek_orits thy sel ts [];
138.325 -uncaught exception TYPE
138.326 -*)
138.327 -
138.328 -(*find_first item with #1 equal to id*)
138.329 -fun seek_ppc id [] = NONE
138.330 - | seek_ppc id (p::(ppc:itm list)) =
138.331 - if id = #1 p then SOME p else seek_ppc id ppc;
138.332 -
138.333 -
138.334 -
138.335 -(*---------------------------------------------(3) nach ptyps.sml 23.3.02*)
138.336 -
138.337 -
138.338 -datatype appl = Appl of tac_ | Notappl of string;
138.339 -
138.340 -fun ppc2list ({Given=gis,Where=whs,Find=fis,
138.341 - With=wis,Relate=res}: 'a ppc) =
138.342 - gis @ whs @ fis @ wis @ res;
138.343 -fun ppc135list ({Given=gis,Find=fis,Relate=res,...}: 'a ppc) =
138.344 - gis @ fis @ res;
138.345 -
138.346 -
138.347 -
138.348 -
138.349 -(* get the number of variants in a problem in 'original',
138.350 - assumes equal descriptions in immediate sequence *)
138.351 -fun variants_in ts =
138.352 - let fun eq(x,y) = head_of x = head_of y;
138.353 - fun cnt eq [] y n = ([n],[])
138.354 - | cnt eq (x::xs) y n = if eq(x,y) then cnt eq xs y (n+1)
138.355 - else ([n], x::xs);
138.356 - fun coll eq xs [] = xs
138.357 - | coll eq xs (y::ys) =
138.358 - let val (n,ys') = cnt eq (y::ys) y 0;
138.359 - in if ys' = [] then xs @ n else coll eq (xs @ n) ys' end;
138.360 - val vts = subtract op = [1] (distinct (coll eq [] ts));
138.361 - in case vts of [] => 1 | [n] => n
138.362 - | _ => error "different variants in formalization" end;
138.363 -(*
138.364 -> cnt (op=) [2,2,2,4,5,5,5,5,5] 2 0;
138.365 -val it = ([3],[4,5,5,5,5,5]) : int list * int list
138.366 -> coll (op=) [] [1,2,2,2,4,5,5,5,5,5];
138.367 -val it = [1,3,1,5] : int list
138.368 -*)
138.369 -
138.370 -fun is_list_type (Type("List.list",_)) = true
138.371 - | is_list_type _ = false;
138.372 -(* fun destr (Type(str,sort)) = (str,sort);
138.373 -> val (SOME ct) = parse thy "lll::real list";
138.374 -> val ty = (#T o rep_cterm) ct;
138.375 -> is_list_type ty;
138.376 -val it = true : bool
138.377 -> destr ty;
138.378 -val it = ("List.list",["RealDef.real"]) : string * typ list
138.379 -> atomty ((#t o rep_cterm) ct);
138.380 -*** -------------
138.381 -*** Free ( lll, real list)
138.382 -val it = () : unit
138.383 -
138.384 -> val (SOME ct) = parse thy "[lll::real]";
138.385 -> val ty = (#T o rep_cterm) ct;
138.386 -> is_list_type ty;
138.387 -val it = true : bool
138.388 -> destr ty;
138.389 -val it = ("List.list",["'a"]) : string * typ list
138.390 -> atomty ((#t o rep_cterm) ct);
138.391 -*** -------------
138.392 -*** Const ( List.list.Cons, [real, real list] => real list)
138.393 -*** Free ( lll, real)
138.394 -*** Const ( List.list.Nil, real list)
138.395 -
138.396 -> val (SOME ct) = parse thy "lll";
138.397 -> val ty = (#T o rep_cterm) ct;
138.398 -> is_list_type ty;
138.399 -val it = false : bool *)
138.400 -
138.401 -
138.402 -fun has_list_type (Free(_,T)) = is_list_type T
138.403 - | has_list_type _ = false;
138.404 -(*
138.405 -> val (SOME ct) = parse thy "lll::real list";
138.406 -> has_list_type (term_of ct);
138.407 -val it = true : bool
138.408 -> val (SOME ct) = parse thy "[lll::real]";
138.409 -> has_list_type (term_of ct);
138.410 -val it = false : bool *)
138.411 -
138.412 -fun is_parsed (Syn _) = false
138.413 - | is_parsed _ = true;
138.414 -fun parse_ok its = foldl and_ (true, map is_parsed its);
138.415 -
138.416 -fun all_dsc_in itm_s =
138.417 - let
138.418 - fun d_in (Cor ((d,_),_)) = [d]
138.419 - | d_in (Syn c) = []
138.420 - | d_in (Typ c) = []
138.421 - | d_in (Inc ((d,_),_)) = [d]
138.422 - | d_in (Sup (d,_)) = [d]
138.423 - | d_in (Mis (d,_)) = [d];
138.424 - in (flat o (map d_in)) itm_s end;
138.425 -
138.426 -(* 30.1.00 ---
138.427 -fun is_Syn (Syn _) = true
138.428 - | is_Syn (Typ _) = true
138.429 - | is_Syn _ = false;
138.430 - --- *)
138.431 -fun is_error (Cor (_,ts)) = false
138.432 - | is_error (Sup (_,ts)) = false
138.433 - | is_error (Inc (_,ts)) = false
138.434 - | is_error (Mis (_,ts)) = false
138.435 - | is_error _ = true;
138.436 -
138.437 -(* 30.1.00 ---
138.438 -fun ct_in (Syn (c)) = c
138.439 - | ct_in (Typ (c)) = c
138.440 - | ct_in _ = raise error "ct_in called for Cor .. Sup";
138.441 - --- *)
138.442 -
138.443 -(*#############################################################*)
138.444 -(*#############################################################*)
138.445 -(* vvv--- aus nnewcode.sml am 30.1.00 ---vvv *)
138.446 -
138.447 -
138.448 -(* testdaten besorgen:
138.449 - use"test-coil-kernel.sml";
138.450 - val (PblObj{origin=(oris,_,_),meth={ppc=itms,...},...}) =
138.451 - get_obj I pt p;
138.452 - *)
138.453 -
138.454 -(* given oris, ppc,
138.455 - variant V: oris union ppc => int, id ID: oris union ppc => int
138.456 -
138.457 - ppc is_complete ==
138.458 - EX vt:V. ALL r:oris --> EX i:ppc. ID r = ID i & complete i
138.459 -
138.460 - and
138.461 - @vt = max sum(i : ppc) V i
138.462 -*)
138.463 -
138.464 -
138.465 -
138.466 -(*
138.467 -> ((vts_cnt (vts_in itms))) itms;
138.468 -
138.469 -
138.470 -
138.471 ----^^--test 10.3.
138.472 -> val vts = vts_in itms;
138.473 -val vts = [1,2,3] : int list
138.474 -> val nvts = vts_cnt vts itms;
138.475 -val nvts = [(1,6),(2,5),(3,7)] : (int * int) list
138.476 -> val mx = max2 nvts;
138.477 -val mx = (3,7) : int * int
138.478 -> val v = max_vt itms;
138.479 -val v = 3 : int
138.480 ---------------------------
138.481 ->
138.482 -*)
138.483 -
138.484 -(*.get the first term in ts from ori.*)
138.485 -(* val (_,_,fd,d,ts) = hd miss;
138.486 - *)
138.487 -fun getr_ct thy ((_,_,fd,d,ts):ori) =
138.488 - (fd, ((Syntax.string_of_term (thy2ctxt thy)) o
138.489 - (comp_dts thy)) (d,[hd ts]):cterm');
138.490 -(* val t = comp_dts thy (d,[hd ts]);
138.491 - *)
138.492 -
138.493 -(* get a term from ori, notyet input in itm *)
138.494 -fun geti_ct thy ((_,_,_,d,ts):ori) ((_,_,_,fd,itm_):itm) =
138.495 - (fd, ((Syntax.string_of_term (thy2ctxt thy)) o (comp_dts thy))
138.496 - (d, subtract op = (ts_in itm_) ts):cterm');
138.497 -(* test-maximum.sml fmy <> [], Init_Proof ...
138.498 - val (_,_,_,d,ts) = ori; val (_,_,_,fd,itm_) = hd icl;
138.499 - val d' $ ts' = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
138.500 - atomty d;
138.501 - atomty d';
138.502 - atomty (hd ts);
138.503 - atomty ts';
138.504 - cterm_of thy (d $ (hd ts));
138.505 - cterm_of thy (d' $ ts');
138.506 -
138.507 - comp_dts thy (d,ts);
138.508 - *)
138.509 -
138.510 -
138.511 -(* in FE dsc, not dat: this is in itms ...*)
138.512 -fun is_untouched ((_,_,false,_,Inc((_,[]),_)):itm) = true
138.513 - | is_untouched _ = false;
138.514 -
138.515 -
138.516 -(* select an item in oris, notyet input in itms
138.517 - (precondition: in itms are only Cor, Sup, Inc) *)
138.518 -local infix mem;
138.519 -fun x mem [] = false
138.520 - | x mem (y :: ys) = x = y orelse x mem ys;
138.521 -in
138.522 -fun nxt_add thy ([]:ori list) pbt itms = (*root (only) ori...fmz=[]*)
138.523 - let
138.524 - fun test_d d ((i,_,_,_,itm_):itm) = (d = (d_in itm_)) andalso i<>0;
138.525 - fun is_elem itms (f,(d,t)) =
138.526 - case find_first (test_d d) itms of
138.527 - SOME _ => true | NONE => false;
138.528 - in case filter_out (is_elem itms) pbt of
138.529 -(* val ((f,(d,_))::itms) = filter_out (is_elem itms) pbt;
138.530 - *)
138.531 - (f,(d,_))::itms =>
138.532 - SOME (f:string, ((Syntax.string_of_term (thy2ctxt thy)) o comp_dts thy) (d,[]):cterm')
138.533 - | _ => NONE end
138.534 -
138.535 -(* val (thy,itms) = (assoc_thy (if dI=e_domID then dI' else dI),pbl);
138.536 - *)
138.537 - | nxt_add thy oris pbt itms =
138.538 - let
138.539 - fun testr_vt v ori = (curry (op mem) v) (#2 (ori:ori))
138.540 - andalso (#3 ori) <>"#undef";
138.541 - fun testi_vt v itm = (curry (op mem) v) (#2 (itm:itm));
138.542 - fun test_id ids r = curry (op mem) (#1 (r:ori)) ids;
138.543 -(* val itm = hd icl; val (_,_,_,d,ts) = v6;
138.544 - *)
138.545 - fun test_subset (itm:itm) ((_,_,_,d,ts):ori) =
138.546 - (d_in (#5 itm)) = d andalso subset op = (ts_in (#5 itm), ts);
138.547 - fun false_and_not_Sup((i,v,false,f,Sup _):itm) = false
138.548 - | false_and_not_Sup (i,v,false,f, _) = true
138.549 - | false_and_not_Sup _ = false;
138.550 -
138.551 - val v = if itms = [] then 1 else max_vt itms;
138.552 - val vors = if v = 0 then oris else filter (testr_vt v) oris;(*oris..vat*)
138.553 - val vits = if v = 0 then itms (*because of dsc without dat*)
138.554 - else filter (testi_vt v) itms; (*itms..vat*)
138.555 - val icl = filter false_and_not_Sup vits; (* incomplete *)
138.556 - in if icl = []
138.557 - then case filter_out (test_id (map #1 vits)) vors of
138.558 - [] => NONE
138.559 - (* val miss = filter_out (test_id (map #1 vits)) vors;
138.560 - *)
138.561 - | miss => SOME (getr_ct thy (hd miss))
138.562 - else
138.563 - case find_first (test_subset (hd icl)) vors of
138.564 - (* val SOME ori = find_first (test_subset (hd icl)) vors;
138.565 - *)
138.566 - NONE => raise error "nxt_add: EX itm. not(dat(itm)<=dat(ori))"
138.567 - | SOME ori => SOME (geti_ct thy ori (hd icl))
138.568 - end
138.569 -end;
138.570 -
138.571 -
138.572 -
138.573 -fun mk_delete thy "#Given" itm_ = Del_Given (itm_out thy itm_)
138.574 - | mk_delete thy "#Find" itm_ = Del_Find (itm_out thy itm_)
138.575 - | mk_delete thy "#Relate" itm_ = Del_Relation(itm_out thy itm_)
138.576 - | mk_delete thy str _ =
138.577 - raise error ("mk_delete: called with field '"^str^"'");
138.578 -fun mk_additem "#Given" ct = Add_Given ct
138.579 - | mk_additem "#Find" ct = Add_Find ct
138.580 - | mk_additem "#Relate"ct = Add_Relation ct
138.581 - | mk_additem str _ =
138.582 - raise error ("mk_additem: called with field '"^str^"'");
138.583 -
138.584 -
138.585 -
138.586 -
138.587 -
138.588 -(* find the next tac in specify (except nxt_model_pbl)
138.589 - 4.00.: TODO: do not return a pos !!!
138.590 - (sind from DG comes the _OLD_ writepos)*)
138.591 -(*
138.592 -> val (pbl,pbt,mpc) =(pbl',get_pbt cpI,(#ppc o get_met) cmI);
138.593 -> val (dI,pI,mI) = empty_spec;
138.594 -> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*))
138.595 - ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec);
138.596 -
138.597 -at Init_Proof:
138.598 -> val met = [];val (pbt,mpc) = (get_pbt pI',(#ppc o get_met) mI');
138.599 -> val (dI,pI,mI) = empty_spec;
138.600 -> nxt_spec Pbl (oris:ori list) ((dI',pI',mI'):spec(*original*))
138.601 - ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec);
138.602 - *)
138.603 -
138.604 -(*. determine the next step of specification;
138.605 - not done here: Refine_Tacitly (otherwise *** unknown method: (..., no_met))
138.606 -eg. in rootpbl 'no_met':
138.607 -args:
138.608 - preok predicates are _all_ ok, or problem matches completely
138.609 - oris immediately from formalization
138.610 - (dI',pI',mI') specification coming from author/parent-problem
138.611 - (pbl, item lists specified by user
138.612 - met) -"-, tacitly completed by copy_probl
138.613 - (dI,pI,mI) specification explicitly done by the user
138.614 - (pbt, mpc) problem type, guard of method
138.615 -.*)
138.616 -(* val (preok,pbl,pbt,mpc)=(pb,pbl',(#ppc o get_pbt) cpI,(#ppc o get_met) cmI);
138.617 - val (preok,pbl,pbt,mpc)=(pb,pbl',ppc,(#ppc o get_met) cmI);
138.618 - val (Pbl, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) =
138.619 - (p_, pb, oris, (dI',pI',mI'), (probl,meth),
138.620 - (ppc, (#ppc o get_met) cmI), (dI,pI,mI));
138.621 - *)
138.622 -fun nxt_spec Pbl preok (oris:ori list) ((dI',pI',mI'):spec)
138.623 - ((pbl:itm list), (met:itm list)) (pbt,mpc) ((dI,pI,mI):spec) =
138.624 - ((*writeln"### nxt_spec Pbl";*)
138.625 - if dI'=e_domID andalso dI=e_domID then (Pbl, Specify_Theory dI')
138.626 - else if pI'=e_pblID andalso pI=e_pblID then (Pbl, Specify_Problem pI')
138.627 - else case find_first (is_error o #5) (pbl:itm list) of
138.628 - SOME (_,_,_,fd,itm_) =>
138.629 - (Pbl, mk_delete
138.630 - (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_)
138.631 - | NONE =>
138.632 - ((*writeln"### nxt_spec is_error NONE";*)
138.633 - case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))
138.634 - oris pbt pbl of
138.635 -(* val SOME (fd,ct') = nxt_add (assoc_thy (if dI=e_domID then dI' else dI))
138.636 - oris pbt pbl;
138.637 - *)
138.638 - SOME (fd,ct') => ((*writeln"### nxt_spec nxt_add SOME";*)
138.639 - (Pbl, mk_additem fd ct'))
138.640 - | NONE => (*pbl-items complete*)
138.641 - if not preok then (Pbl, Refine_Problem pI')
138.642 - else
138.643 - if dI = e_domID then (Pbl, Specify_Theory dI')
138.644 - else if pI = e_pblID then (Pbl, Specify_Problem pI')
138.645 - else if mI = e_metID then (Pbl, Specify_Method mI')
138.646 - else
138.647 - case find_first (is_error o #5) met of
138.648 - SOME (_,_,_,fd,itm_) =>
138.649 - (Met, mk_delete (assoc_thy dI) fd itm_)
138.650 - | NONE =>
138.651 - (case nxt_add (assoc_thy dI) oris mpc met of
138.652 - SOME (fd,ct') => (*30.8.01: pre?!?*)
138.653 - (Met, mk_additem fd ct')
138.654 - | NONE =>
138.655 - ((*Solv 3.4.00*)Met, Apply_Method mI))))
138.656 -(* val preok=pb; val (pbl, met) = (pbl,met');
138.657 - val (pbt,mpc)=((#ppc o get_pbt) cpI,(#ppc o get_met) cmI);
138.658 - val (Met, preok, oris, (dI',pI',mI'), (pbl,met), (pbt,mpc), (dI,pI,mI)) =
138.659 - (p_, pb, oris, (dI',pI',mI'), (probl,meth),
138.660 - (ppc, (#ppc o get_met) cmI), (dI,pI,mI));
138.661 - *)
138.662 - | nxt_spec Met preok oris (dI',pI',mI') (pbl, met) (pbt,mpc) (dI,pI,mI) =
138.663 - ((*writeln"### nxt_spec Met"; *)
138.664 - case find_first (is_error o #5) met of
138.665 - SOME (_,_,_,fd,itm_) =>
138.666 - (Met, mk_delete (assoc_thy (if dI=e_domID then dI' else dI)) fd itm_)
138.667 - | NONE =>
138.668 - case nxt_add (assoc_thy (if dI=e_domID then dI' else dI))oris mpc met of
138.669 - SOME (fd,ct') => (Met, mk_additem fd ct')
138.670 - | NONE =>
138.671 - ((*writeln"### nxt_spec Met: nxt_add NONE";*)
138.672 - if dI = e_domID then (Met, Specify_Theory dI')
138.673 - else if pI = e_pblID then (Met, Specify_Problem pI')
138.674 - else if not preok then (Met, Specify_Method mI)
138.675 - else (Met, Apply_Method mI)));
138.676 -
138.677 -(* di_ pI_ mI_ pos_
138.678 -val itms = [(1,[1],true,"#Find",Cor(e_term,[e_term])):itm,
138.679 - (2,[2],true,"#Find",Syn("empty"))];
138.680 -*)
138.681 -
138.682 -
138.683 -(* ^^^--- aus nnewcode.sml am 30.1.00 ---^^^ *)
138.684 -(*#############################################################*)
138.685 -(*#############################################################*)
138.686 -(* vvv--- aus nnewcode.sml vor 29.1.00 ---vvv *)
138.687 -
138.688 -(*3.3.--
138.689 -fun update_itm (cl,d,ts) ((id,vt,_,sl,Cor (_,_)):itm) =
138.690 - (id,vt,cl,sl,Cor (d,ts)):itm
138.691 - | update_itm (cl,d,ts) (id,vt,_,sl,Syn (_)) =
138.692 - raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^
138.693 - " not not for Syn (s:cterm')")
138.694 - | update_itm (cl,d,ts) (id,vt,_,sl,Typ (_)) =
138.695 - raise error ("update_itm "^((Syntax.string_of_term (thy2ctxt thy)) (comp_dts thy (d,ts)))^
138.696 - " not not for Typ (s:cterm')")
138.697 - | update_itm (cl,d,ts) (id,vt,_,sl,Fal (_,_)) =
138.698 - (id,vt,cl,sl,Fal (d,ts))
138.699 - | update_itm (cl,d,ts) (id,vt,_,sl,Inc (_,_)) =
138.700 - (id,vt,cl,sl,Inc (d,ts))
138.701 - | update_itm (cl,d,ts) (id,vt,_,sl,Sup (_,_)) =
138.702 - (id,vt,cl,sl,Sup (d,ts));
138.703 -*)
138.704 -
138.705 -
138.706 -
138.707 -
138.708 -fun is_field_correct sel d dscpbt =
138.709 - case assoc (dscpbt, sel) of
138.710 - NONE => false
138.711 - | SOME ds => member op = ds d;
138.712 -
138.713 -(*. update the itm_ already input, all..from ori .*)
138.714 -(* val (id,vt,fd,d,ts) = (i,v,f,d,ts\\ts');
138.715 - *)
138.716 -fun ori_2itm thy itm_ pid all ((id,vt,fd,d,ts):ori) =
138.717 - let
138.718 - val ts' = union op = (ts_in itm_) ts;
138.719 - val pval = pbl_ids' thy d ts'
138.720 - (*WN.9.5.03: FIXXXME [#0, epsilon]
138.721 - here would upd_penv be called for [#0, epsilon] etc. *)
138.722 - val complete = if eq_set op = (ts', all) then true else false;
138.723 - in case itm_ of
138.724 - (Cor _) =>
138.725 - (if fd = "#undef" then (id,vt,complete,fd,Sup(d,ts'))
138.726 - else (id,vt,complete,fd,Cor((d,ts'),(pid, pval)))):itm
138.727 - | (Syn c) => raise error ("ori_2itm wants to overwrite "^c)
138.728 - | (Typ c) => raise error ("ori_2itm wants to overwrite "^c)
138.729 - | (Inc _) => if complete
138.730 - then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval)))
138.731 - else (id,vt,false,fd, Inc ((d,ts'),(pid, pval)))
138.732 - | (Sup ((*_,_*)d,ts')) => (*4.9.01 lost env*)
138.733 - (*if fd = "#undef" then*) (id,vt,complete,fd,Sup(d,ts'))
138.734 - (*else (id,vt,complete,fd,Cor((d,ts'),e))*)
138.735 -(* 28.1.00: not completely clear ---^^^ etc.*)
138.736 -(* 4.9.01: Mis just copied---vvv *)
138.737 - | (Mis _) => if complete
138.738 - then (id,vt,true ,fd, Cor ((d,ts'),(pid, pval)))
138.739 - else (id,vt,false,fd, Inc ((d,ts'),(pid, pval)))
138.740 - end;
138.741 -
138.742 -
138.743 -fun eq1 d (_,(d',_)) = (d = d');
138.744 -fun eq3 f d (_,_,_,f',itm_) = f = f' andalso d = (d_in itm_);
138.745 -
138.746 -
138.747 -(* 'all' ts from ori; ts is the input; (ori carries rest of info)
138.748 - 9.01: this + ori_2itm is _VERY UNCLEAR_ ? overhead ?
138.749 - pval: value for problem-environment _NOT_ checked for 'inter' --
138.750 - -- FIXXME.WN.11.03 the generation of penv has to go to insert_ppc
138.751 - (as it has been done for input_icalhd+insert_ppc' in 11.03)*)
138.752 -(*. is_input ori itms <=>
138.753 - EX itm. (1) ori(field,dsc) = itm(field,dsc) & (2..4)
138.754 - (2) ori(ts) subset itm(ts) --- Err "already input"
138.755 - (3) ori(ts) inter itm(ts) = empty --- new: ori(ts)
138.756 - (4) -"- <> empty --- new: ori(ts) \\ inter .*)
138.757 -(* val(itms,(i,v,f,d,ts)) = (ppc,ori');
138.758 - *)
138.759 -fun is_notyet_input thy (itms:itm list) all ((i,v,f,d,ts):ori) pbt =
138.760 - case find_first (eq1 d) pbt of
138.761 - SOME (_,(_,pid)) =>(* val SOME (_,(_,pid)) = find_first (eq1 d) pbt;
138.762 - val SOME (_,_,_,_,itm_)=find_first (eq3 f d) itms;
138.763 - *)
138.764 - (case find_first (eq3 f d) itms of
138.765 - SOME (_,_,_,_,itm_) =>
138.766 - let
138.767 - val ts' = inter op = (ts_in itm_) ts;
138.768 - in if subset op = (ts, ts')
138.769 - then (((strs2str' o
138.770 - map (Syntax.string_of_term (thy2ctxt thy))) ts')^
138.771 - " already input", e_itm) (*2*)
138.772 - else ("",
138.773 - ori_2itm thy itm_ pid all (i,v,f,d,
138.774 - subtract op = ts' ts)) (*3,4*)
138.775 - end
138.776 - | NONE => ("", ori_2itm thy (Inc ((e_term,[]),(pid,[])))
138.777 - pid all (i,v,f,d,ts)) (*1*)
138.778 - )
138.779 - | NONE => ("", ori_2itm thy (Sup (d,ts))
138.780 - e_term all (i,v,f,d,ts));
138.781 -
138.782 -fun test_types thy (d,ts) =
138.783 - let
138.784 - val s = !show_types; val _ = show_types:= true;
138.785 - val opt = (try (comp_dts thy)) (d,ts);
138.786 - val msg = case opt of
138.787 - SOME _ => ""
138.788 - | NONE => ((Syntax.string_of_term (thy2ctxt thy) d)^" "^
138.789 - ((strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) ts)
138.790 - ^ " is illtyped");
138.791 - val _ = show_types:= s
138.792 - in msg end;
138.793 -
138.794 -
138.795 -
138.796 -fun maxl [] = raise error "maxl of []"
138.797 - | maxl (y::ys) =
138.798 - let fun mx x [] = x
138.799 - | mx x (y::ys) = if x < (y:int) then mx y ys else mx x ys
138.800 - in mx y ys end;
138.801 -
138.802 -
138.803 -(*. is the input term t known in oris ?
138.804 - give feedback on all(?) strange input;
138.805 - return _all_ terms already input to this item (e.g. valuesFor a,b) .*)
138.806 -(*WN.11.03: from lists*)
138.807 -fun is_known thy sel ori t =
138.808 -(* val (ori,t)=(oris,term_of ct);
138.809 - *)
138.810 - let
138.811 - val ots = (distinct o flat o (map #5)) (ori:ori list);
138.812 - val oids = ((map (fst o dest_Free)) o distinct o
138.813 - flat o (map vars)) ots;
138.814 - val (d,ts(*,pval*)) = split_dts thy t;
138.815 - val ids = map (fst o dest_Free)
138.816 - ((distinct o (flat o (map vars))) ts);
138.817 - in if (subtract op = oids ids) <> []
138.818 - then (("identifiers "^(strs2str' (subtract op = oids ids))^
138.819 - " not in example"), e_ori_, [])
138.820 - else
138.821 - if d = e_term
138.822 - then
138.823 - if not (subset op = (map typeless ts, map typeless ots))
138.824 - then (("terms '"^
138.825 - ((strs2str' o (map (Syntax.string_of_term
138.826 - (thy2ctxt thy)))) ts)^
138.827 - "' not in example (typeless)"), e_ori_, [])
138.828 - else (case seek_orits thy sel ts ori of
138.829 - ("", ori_ as (_,_,_,d,ts), all) =>
138.830 - (case test_types thy (d,ts) of
138.831 - "" => ("", ori_, all)
138.832 - | msg => (msg, e_ori_, []))
138.833 - | (msg,_,_) => (msg, e_ori_, []))
138.834 - else
138.835 - if member op = (map #4 ori) d
138.836 - then seek_oridts thy sel (d,ts) ori
138.837 - else ((Syntax.string_of_term (thy2ctxt thy) d)^
138.838 - (*" not in example", e_ori_, []) ///11.11.03*)
138.839 - " not in example", (0,[],sel,d,ts), [])
138.840 - end;
138.841 -
138.842 -
138.843 -(*. for return-value of appl_add .*)
138.844 -datatype additm =
138.845 - Add of itm
138.846 - | Err of string; (*error-message*)
138.847 -
138.848 -
138.849 -(*. add an item; check wrt. oris and pbt .*)
138.850 -
138.851 -(* in contrary to oris<>[] below, this part handles user-input
138.852 - extremely acceptive, i.e. accept input instead error-msg *)
138.853 -fun appl_add thy sel ([]:ori list) ppc pbt ct' =
138.854 -(* val (ppc,pbt,ct',env) = (pbl, (#ppc o get_pbt) cpI, ct, []:envv);
138.855 - !!!! 28.8.01: env tested _minimally_ !!!
138.856 - *)
138.857 - let
138.858 - val i = 1 + (if ppc=[] then 0 else maxl (map #1 ppc));
138.859 - in case parse thy ct' of (*should be done in applicable_in 4.00.FIXME*)
138.860 - NONE => Add (i,[],false,sel,Syn ct')
138.861 -(* val (SOME ct) = parse thy ct';
138.862 - *)
138.863 - | SOME ct =>
138.864 - let
138.865 - val (d,ts(*,pval*)) = split_dts thy (term_of ct);
138.866 - in if d = e_term
138.867 - then Add (i,[],false,sel,Mis (dsc_unknown,hd ts(*24.3.02*)))
138.868 -
138.869 - else
138.870 - (case find_first (eq1 d) pbt of
138.871 - NONE => Add (i,[],true,sel,Sup ((d,ts)))
138.872 - | SOME (f,(_,id)) =>
138.873 -(* val SOME (f,(_,id)) = find_first (eq1 d) pbt;
138.874 - *)
138.875 - let
138.876 - fun eq2 d ((i,_,_,_,itm_):itm) =
138.877 - (d = (d_in itm_)) andalso i<>0;
138.878 - in case find_first (eq2 d) ppc of
138.879 - NONE => Add (i,[],true,f, Cor ((d,ts), (id, (*pval*)
138.880 - pbl_ids' thy d ts)))
138.881 - | SOME (i',_,_,_,itm_) =>
138.882 -(* val SOME (i',_,_,_,itm_) = find_first (eq2 d) ppc;
138.883 - val NONE = find_first (eq2 d) ppc;
138.884 - *)
138.885 - if is_list_dsc d
138.886 - then let val ts = union op = ts (ts_in itm_)
138.887 - in Add (if ts_in itm_ = [] then i else i',
138.888 - [],true,f,Cor ((d, ts), (id, (*pval*)
138.889 - pbl_ids' thy d ts)))
138.890 - end
138.891 - else Add (i',[],true,f,Cor ((d,ts),(id, (*pval*)
138.892 - pbl_ids' thy d ts)))
138.893 - end
138.894 - )
138.895 - end
138.896 - end
138.897 -(*. add ct to ppc .*)
138.898 -(*FIXXME: accept items as Sup, Syn here, too (like appl_add..oris=[] above)*)
138.899 -(* val (ppc,pbt) = (pbl, ppc);
138.900 - val (ppc,pbt) = (met, (#ppc o get_met) cmI);
138.901 -
138.902 - val (ppc,pbt) = (pbl, (#ppc o get_pbt) cpI);
138.903 - *)
138.904 - | appl_add thy sel oris ppc pbt(*only for upd_envv*) ct =
138.905 - let
138.906 - val ctopt = parse thy ct;
138.907 - in case ctopt of
138.908 - NONE => Err ("syntax error in "^ct)
138.909 - | SOME ct =>(* val SOME ct = ctopt;
138.910 - val (msg,ori',all) = is_known thy sel oris (term_of ct);
138.911 - val (msg,itm) = is_notyet_input thy ppc all ori' pbt;
138.912 - *)
138.913 - (case is_known thy sel oris (term_of ct) of
138.914 - ("",ori'(*ts='ct'*), all) =>
138.915 - (case is_notyet_input thy ppc all ori' pbt of
138.916 - ("",itm) => Add itm
138.917 - | (msg,_) => Err msg)
138.918 - | (msg,_,_) => Err msg)
138.919 - end;
138.920 -(*
138.921 -> val (msg,itm) = is_notyet_input thy ppc all ori';
138.922 -val itm = (12,[3],false,"#Relate",Cor (Const #,[#,#])) : itm
138.923 -> val itm_ = #5 itm;
138.924 -> val ts = ts_in itm_;
138.925 -> map (atomty) ts;
138.926 -*)
138.927 -
138.928 -(*---------------------------------------------(4) nach ptyps.sml 23.3.02*)
138.929 -
138.930 -
138.931 -(** make oris from args of the stac SubProblem and from pbt **)
138.932 -
138.933 -(*.can this formal argument (of a model-pattern) be omitted in the arg-list
138.934 - of a SubProblem ? see ME/ptyps.sml 'type met '.*)
138.935 -fun is_copy_named_idstr str =
138.936 - case (rev o explode) str of
138.937 - "_"::_::"_"::_ => true
138.938 - | _ => false;
138.939 -(*> is_copy_named_idstr "v_i_";
138.940 -val it = true : bool
138.941 - > is_copy_named_idstr "e_";
138.942 -val it = false : bool
138.943 - > is_copy_named_idstr "L___";
138.944 -val it = true : bool
138.945 -*)
138.946 -(*.should this formal argument (of a model-pattern) create a new identifier?.*)
138.947 -fun is_copy_named_generating_idstr str =
138.948 - if is_copy_named_idstr str
138.949 - then case (rev o explode) str of
138.950 - "_"::"_"::"_"::_ => false
138.951 - | _ => true
138.952 - else false;
138.953 -(*> is_copy_named_generating_idstr "v_i_";
138.954 -val it = true : bool
138.955 - > is_copy_named_generating_idstr "L___";
138.956 -val it = false : bool
138.957 -*)
138.958 -
138.959 -(*.can this formal argument (of a model-pattern) be omitted in the arg-list
138.960 - of a SubProblem ? see ME/ptyps.sml 'type met '.*)
138.961 -fun is_copy_named (_,(_,t)) = (is_copy_named_idstr o free2str) t;
138.962 -(*.should this formal argument (of a model-pattern) create a new identifier?.*)
138.963 -fun is_copy_named_generating (_,(_,t)) =
138.964 - (is_copy_named_generating_idstr o free2str) t;
138.965 -
138.966 -
138.967 -(*.split type-wrapper from scr-arg and build part of an ori;
138.968 - an type-error is reported immediately, raises an exn,
138.969 - subsequent handling of exn provides 2nd part of error message.*)
138.970 -(*fun mtc thy ((str, (dsc, _)):pat) (ty $ var) = WN100820 made cterm to term
138.971 - (* val (thy, (str, (dsc, _)), (ty $ var)) =
138.972 - (thy, p, a);
138.973 - *)
138.974 - (cterm_of thy (dsc $ var);(*type check*)
138.975 - SOME ((([1], str, dsc, (*[var]*)
138.976 - split_dts' (dsc, var))): preori)(*:ori without leading #*))
138.977 - handle e as TYPE _ =>
138.978 - (writeln (dashs 70^"\n"
138.979 - ^"*** ERROR while creating the items for the model of the ->problem\n"
138.980 - ^"*** from the ->stac with ->typeconstructor in arglist:\n"
138.981 - ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n"
138.982 - ^"*** description: "^(term_detail2str dsc)
138.983 - ^"*** value: "^(term_detail2str var)
138.984 - ^"*** typeconstructor in script: "^(term_detail2str ty)
138.985 - ^"*** checked by theory: "^(theory2str thy)^"\n"
138.986 - ^"*** "^dots 66);
138.987 - print_exn e; (*raises exn again*)
138.988 - NONE);*)
138.989 -fun mtc thy ((str, (dsc, _)):pat) (ty $ var) =
138.990 - (* val (thy, (str, (dsc, _)), (ty $ var)) =
138.991 - (thy, p, a);
138.992 - *)
138.993 - (cterm_of thy (dsc $ var);(*type check*)
138.994 - SOME ((([1], str, dsc, (*[var]*)
138.995 - split_dts' (dsc, var))): preori)(*:ori without leading #*))
138.996 - handle e as TYPE _ =>
138.997 - (writeln (dashs 70^"\n"
138.998 - ^"*** ERROR while creating the items for the model of the ->problem\n"
138.999 - ^"*** from the ->stac with ->typeconstructor in arglist:\n"
138.1000 - ^"*** item (->description ->value): "^term2str dsc^" "^term2str var^"\n"
138.1001 - ^"*** description: "^(term_detail2str dsc)
138.1002 - ^"*** value: "^(term_detail2str var)
138.1003 - ^"*** typeconstructor in script: "^(term_detail2str ty)
138.1004 - ^"*** checked by theory: "^(theory2str thy)^"\n"
138.1005 - ^"*** "^dots 66);
138.1006 - (*WN100820 postponed: print_exn e; raises exn again*)
138.1007 - NONE);
138.1008 -(*> val pbt = (#ppc o get_pbt) ["univariate","equation"];
138.1009 -> val Const ("Script.SubProblem",_) $
138.1010 - (Const ("Pair",_) $ Free (thy', _) $
138.1011 - (Const ("Pair",_) $ pblID' $ metID')) $ ags =
138.1012 - str2term"(SubProblem (SqRoot_,[univariate,equation],\
138.1013 - \[SqRoot_,solve_linear]) [bool_ (x+1- 2=0), real_ x])::bool list";
138.1014 -> val ags = isalist2list ags;
138.1015 -> mtc thy (hd pbt) (hd ags);
138.1016 -val it = SOME ([1],"#Given",Const (#,#),[# $ #]) *)
138.1017 -
138.1018 -(*.match each pat of the model-pattern with an actual argument;
138.1019 - precondition: copy-named vars are filtered out.*)
138.1020 -fun matc thy ([]:pat list) _ (oris:preori list) = oris
138.1021 - | matc thy pbt [] _ =
138.1022 - (writeln (dashs 70);
138.1023 - raise error ("actual arg(s) missing for '"^pats2str pbt
138.1024 - ^"' i.e. should be 'copy-named' by '*_._'"))
138.1025 - | matc thy ((p as (s,(d,t)))::pbt) (a::ags) oris =
138.1026 - (* val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) =
138.1027 - (thy, pbt', ags, []);
138.1028 - (*recursion..*)
138.1029 - val (thy, ((p as (s,(d,t)))::pbt), (a::ags), oris) =
138.1030 - (thy, pbt, ags, (oris @ [ori]));
138.1031 - *)
138.1032 - (*del?..*)if (is_copy_named_idstr o free2str) t then oris
138.1033 - else(*..del?*) let val opt = mtc thy p a;
138.1034 - in case opt of
138.1035 - (* val SOME ori = mtc thy p a;
138.1036 - *)
138.1037 - SOME ori => matc thy pbt ags (oris @ [ori])
138.1038 - | NONE => [](*WN050903 skipped by exn handled in match_ags*)
138.1039 - end;
138.1040 -(* run subp-rooteq.sml until Init_Proof before ...
138.1041 -> val Nd (PblObj {origin=(oris,_,_),...},_) = pt;(*from test/subp-rooteq.sml*)
138.1042 -> fun xxxfortest (_,a,b,c,d) = (a,b,c,d);val oris = map xxxfortest oris;
138.1043 -
138.1044 - other vars as in mtc ..
138.1045 -> matc thy (drop_last pbt) ags [];
138.1046 -val it = ([[1],"#Given",Const #,[#]),(0,[#],"#Given",Const #,[#])],2)*)
138.1047 -
138.1048 -
138.1049 -(*WN051014 outcommented with redesign copy-named (for omitting '#Find'
138.1050 - in SubProblem);
138.1051 - kept as initial idea for generating x_1, x_2, ... for equations*)
138.1052 -fun cpy_nam (pbt:pat list) (oris:preori list) (p as (field,(dsc,t)):pat) =
138.1053 -(* val ((pbt:pat list), (oris:preori list), ((field,(dsc,t)):pat)) =
138.1054 - (pbt', oris', hd (*!!!!!*) cy);
138.1055 - *)
138.1056 - (if is_copy_named_generating p
138.1057 - then (*WN051014 kept strange old code ...*)
138.1058 - let fun sel (_,_,d,ts) = comp_ts (d, ts)
138.1059 - val cy' = (implode o drop_last o drop_last o explode o free2str) t
138.1060 - val ext = (last_elem o drop_last o explode o free2str) t
138.1061 - val vars' = map (free2str o snd o snd) pbt(*cpy-nam filtered_out*)
138.1062 - val vals = map sel oris
138.1063 - val cy_ext = (free2str o the) (assoc (vars'~~vals, cy'))^"_"^ext
138.1064 - in ([1], field, dsc, [mk_free (type_of t) cy_ext]):preori end
138.1065 - else ([1], field, dsc, [t])
138.1066 - )
138.1067 - handle _ => raise error ("cpy_nam: for "^(term2str t));
138.1068 -
138.1069 -(*> val (field,(dsc,t)) = last_elem pbt;
138.1070 -> cpy_nam pbt (drop_last oris) (field,(dsc,t));
138.1071 -val it = ([1],"#Find",
138.1072 - Const ("Descript.solutions","bool List.list => Tools.toreall"),
138.1073 - [Free ("x_i","bool List.list")]) *)
138.1074 -
138.1075 -
138.1076 -(*.match the actual arguments of a SubProblem with a model-pattern
138.1077 - and create an ori list (in root-pbl created from formalization).
138.1078 - expects ags:pats = 1:1, while copy-named are filtered out of pats;
138.1079 - copy-named pats are appended in order to get them into the model-items.*)
138.1080 -fun match_ags thy (pbt:pat list) ags =
138.1081 -(* val (thy, pbt, ags) = (thy, (#ppc o get_pbt) pI, ags);
138.1082 - val (thy, pbt, ags) = (thy, pats, ags);
138.1083 - *)
138.1084 - let fun flattup (i,(var,bool,str,itm_)) = (i,var,bool,str,itm_);
138.1085 - val pbt' = filter_out is_copy_named pbt;
138.1086 - val cy = filter is_copy_named pbt;
138.1087 - val oris' = matc thy pbt' ags [];
138.1088 - val cy' = map (cpy_nam pbt' oris') cy;
138.1089 - val ors = add_id (oris' @ cy');
138.1090 - (*appended in order to get ^^^^^ them into the model-items*)
138.1091 - in (map flattup ors):ori list end;
138.1092 -(*vars as above ..
138.1093 -> match_ags thy pbt ags;
138.1094 -val it =
138.1095 - [(1,[1],"#Given",Const ("Descript.equality","bool => Tools.una"),
138.1096 - [Const # $ (# $ #) $ Free (#,#)]),
138.1097 - (2,[1],"#Given",Const ("Descript.solveFor","RealDef.real => Tools.una"),
138.1098 - [Free ("x","RealDef.real")]),
138.1099 - (3,[1],"#Find",
138.1100 - Const ("Descript.solutions","bool List.list => Tools.toreall"),
138.1101 - [Free ("x_i","bool List.list")])] : ori list*)
138.1102 -
138.1103 -(*.report part of the error-msg which is not available in match_args.*)
138.1104 -fun match_ags_msg pI stac ags =
138.1105 - let val s = !show_types
138.1106 - val _ = show_types:= true
138.1107 - val pats = (#ppc o get_pbt) pI
138.1108 - val msg = (dots 70^"\n"
138.1109 - ^"*** problem "^strs2str pI^" has the ...\n"
138.1110 - ^"*** model-pattern "^pats2str pats^"\n"
138.1111 - ^"*** stac '"^term2str stac^"' has the ...\n"
138.1112 - ^"*** arg-list "^terms2str ags^"\n"
138.1113 - ^dashs 70)
138.1114 - val _ = show_types:= s
138.1115 - in writeln msg end;
138.1116 -
138.1117 -
138.1118 -(*get the variables out of a pbl_; FIXME.WN.0311: is_copy_named ...obscure!!!*)
138.1119 -fun vars_of_pbl_ pbl_ =
138.1120 - let fun var_of_pbl_ (gfr,(dsc,t)) = t
138.1121 - in ((map var_of_pbl_) o (filter_out is_copy_named)) pbl_ end;
138.1122 -fun vars_of_pbl_' pbl_ =
138.1123 - let fun var_of_pbl_ (gfr,(dsc,t)) = t:term
138.1124 - in ((map var_of_pbl_)(* o (filter_out is_copy_named)*)) pbl_ end;
138.1125 -
138.1126 -fun overwrite_ppc thy itm ppc =
138.1127 - let
138.1128 - fun repl ppc' (_,_,_,_,itm_) [] =
138.1129 - raise error ("overwrite_ppc: " ^ (itm_2str_ (thy2ctxt thy) itm_) ^
138.1130 - " not found")
138.1131 - | repl ppc' itm (p::ppc) =
138.1132 - if (#1 itm) = (#1 (p:itm)) then ppc' @ [itm] @ ppc
138.1133 - else repl (ppc' @ [p]) itm ppc
138.1134 - in repl [] itm ppc end;
138.1135 -
138.1136 -(*10.3.00: insert the already compiled itm into model;
138.1137 - ev. filter_out untouched (in FE: (0,...)) item related to insert-item *)
138.1138 -(* val ppc=pbl;
138.1139 - *)
138.1140 -fun insert_ppc thy itm ppc =
138.1141 - let
138.1142 - fun eq_untouched d ((0,_,_,_,itm_):itm) = (d = d_in itm_)
138.1143 - | eq_untouched _ _ = false;
138.1144 - val ppc' =
138.1145 - (
138.1146 - (*writeln("### insert_ppc: itm= "^(itm2str_ itm));*)
138.1147 - case seek_ppc (#1 itm) ppc of
138.1148 - (* val SOME xxx = seek_ppc (#1 itm) ppc;
138.1149 - *)
138.1150 - SOME _ => (*itm updated in is_notyet_input WN.11.03*)
138.1151 - overwrite_ppc thy itm ppc
138.1152 - | NONE => (ppc @ [itm]));
138.1153 - in filter_out (eq_untouched ((d_in o #5) itm)) ppc' end;
138.1154 -
138.1155 -(*from Isabelle/src/Pure/library.ML, _appends_ a new element*)
138.1156 -fun gen_ins' eq (x, xs) = if gen_mem eq (x, xs) then xs else xs @ [x];
138.1157 -
138.1158 -fun eq_dsc ((_,_,_,_,itm_):itm, (_,_,_,_,iitm_):itm) =
138.1159 - (d_in itm_) = (d_in iitm_);
138.1160 -(*insert_ppc = insert_ppc' for appl_add', input_icalhd 11.03,
138.1161 - handles superfluous items carelessly*)
138.1162 -fun insert_ppc' itm itms = gen_ins' eq_dsc (itm, itms);
138.1163 -(* val eee = op=;
138.1164 - > gen_ins' eee (4,[1,3,5,7]);
138.1165 -val it = [1, 3, 5, 7, 4] : int list*)
138.1166 -
138.1167 -
138.1168 -(*. output the headline to a ppc .*)
138.1169 -fun header p_ pI mI =
138.1170 - case p_ of Pbl => Problem (if pI = e_pblID then [] else pI)
138.1171 - | Met => Method mI
138.1172 - | pos => raise error ("header called with "^ pos_2str pos);
138.1173 -
138.1174 -
138.1175 -
138.1176 -(* test-printouts ---
138.1177 -val _=writeln("### insert_ppc: (d,ts)="^((Syntax.string_of_term (thy2ctxt thy))(comp_dts thy(d,ts))));
138.1178 - val _=writeln("### insert_ppc: pts= "^
138.1179 -(strs2str' o map (Syntax.string_of_term (thy2ctxt thy))) pts);
138.1180 -
138.1181 -
138.1182 - val sel = "#Given"; val Add_Given' ct = m;
138.1183 -
138.1184 - val sel = "#Find"; val Add_Find' (ct,_) = m;
138.1185 - val (p,_) = p;
138.1186 - val (_,_,f,nxt',_,pt')= specify_additem sel (ct,[]) (p,Pbl(*!!!!!!!*)) c pt;
138.1187 ---------------
138.1188 - val sel = "#Given"; val Add_Given' (ct,_) = nxt; val (p,_) = p;
138.1189 - *)
138.1190 -fun specify_additem sel (ct,_) (p,Met) c pt =
138.1191 - let
138.1192 - val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_),
138.1193 - probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
138.1194 - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
138.1195 - (*val ppt = if pI = e_pblID then get_pbt pI' else get_pbt pI;*)
138.1196 - val cpI = if pI = e_pblID then pI' else pI;
138.1197 - val cmI = if mI = e_metID then mI' else mI;
138.1198 - val {ppc,pre,prls,...} = get_met cmI
138.1199 - in case appl_add thy sel oris met ppc ct of
138.1200 - Add itm (*..union old input *) =>
138.1201 - let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct;
138.1202 - *)
138.1203 - val met' = insert_ppc thy itm met;
138.1204 - (*val pt' = update_met pt p met';*)
138.1205 - val ((p,Met),_,_,pt') =
138.1206 - generate1 thy (case sel of
138.1207 - "#Given" => Add_Given' (ct, met')
138.1208 - | "#Find" => Add_Find' (ct, met')
138.1209 - | "#Relate"=> Add_Relation'(ct, met'))
138.1210 - Uistate (p,Met) pt
138.1211 - val pre' = check_preconds thy prls pre met'
138.1212 - val pb = foldl and_ (true, map fst pre')
138.1213 - (*val _=writeln("@@@ specify_additem: Met Add before nxt_spec")*)
138.1214 - val (p_,nxt) =
138.1215 - nxt_spec Met pb oris (dI',pI',mI') (pbl,met')
138.1216 - ((#ppc o get_pbt) cpI,ppc) (dI,pI,mI);
138.1217 - in ((p,p_), ((p,p_),Uistate),
138.1218 - Form' (PpcKF (0,EdUndef,(length p),Nundef,
138.1219 - (Method cmI, itms2itemppc thy met' pre'))),
138.1220 - nxt,Safe,pt') end
138.1221 - | Err msg =>
138.1222 - let val pre' = check_preconds thy prls pre met
138.1223 - val pb = foldl and_ (true, map fst pre')
138.1224 - (*val _=writeln("@@@ specify_additem: Met Err before nxt_spec")*)
138.1225 - val (p_,nxt) =
138.1226 - nxt_spec Met pb oris (dI',pI',mI') (pbl,met)
138.1227 - ((#ppc o get_pbt) cpI,(#ppc o get_met) cmI) (dI,pI,mI);
138.1228 - in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end
138.1229 - end
138.1230 -(* val (p,_) = p;
138.1231 - *)
138.1232 -| specify_additem sel (ct,_) (p,_(*Frm, Pbl*)) c pt =
138.1233 - let
138.1234 - val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_),
138.1235 - probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
138.1236 - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
138.1237 - val cpI = if pI = e_pblID then pI' else pI;
138.1238 - val cmI = if mI = e_metID then mI' else mI;
138.1239 - val {ppc,where_,prls,...} = get_pbt cpI;
138.1240 - in case appl_add thy sel oris pbl ppc ct of
138.1241 - Add itm (*..union old input *) =>
138.1242 - (* val Add itm = appl_add thy sel oris pbl ppc ct;
138.1243 - *)
138.1244 - let
138.1245 - (*val _= writeln("###specify_additem: itm= "^(itm2str_ itm));*)
138.1246 - val pbl' = insert_ppc thy itm pbl
138.1247 - val ((p,Pbl),_,_,pt') =
138.1248 - generate1 thy (case sel of
138.1249 - "#Given" => Add_Given' (ct, pbl')
138.1250 - | "#Find" => Add_Find' (ct, pbl')
138.1251 - | "#Relate"=> Add_Relation'(ct, pbl'))
138.1252 - Uistate (p,Pbl) pt
138.1253 - val pre = check_preconds thy prls where_ pbl'
138.1254 - val pb = foldl and_ (true, map fst pre)
138.1255 - (*val _=writeln("@@@ specify_additem: Pbl Add before nxt_spec")*)
138.1256 - val (p_,nxt) =
138.1257 - nxt_spec Pbl pb oris (dI',pI',mI') (pbl',met)
138.1258 - (ppc,(#ppc o get_met) cmI) (dI,pI,mI);
138.1259 - val ppc = if p_= Pbl then pbl' else met;
138.1260 - in ((p,p_), ((p,p_),Uistate),
138.1261 - Form' (PpcKF (0,EdUndef,(length p),Nundef,
138.1262 - (header p_ pI cmI,
138.1263 - itms2itemppc thy ppc pre))), nxt,Safe,pt') end
138.1264 -
138.1265 - | Err msg =>
138.1266 - let val pre = check_preconds thy prls where_ pbl
138.1267 - val pb = foldl and_ (true, map fst pre)
138.1268 - (*val _=writeln("@@@ specify_additem: Pbl Err before nxt_spec")*)
138.1269 - val (p_,nxt) =
138.1270 - nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met)
138.1271 - (ppc,(#ppc o get_met) cmI) (dI,pI,mI);
138.1272 - in ((p,p_), ((p,p_),Uistate), Error' (Error_ msg), nxt, Safe,pt) end
138.1273 - end;
138.1274 -(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt;
138.1275 - val (_,_,f,nxt',_,pt')= specify_additem sel ct (p,Met) c pt;
138.1276 - *)
138.1277 -
138.1278 -(* ori
138.1279 -val (msg,itm) = appl_add thy sel oris ppc ct;
138.1280 -val (Cor(d,ts)) = #5 itm;
138.1281 -map (atomty) ts;
138.1282 -
138.1283 -pre
138.1284 -*)
138.1285 -
138.1286 -
138.1287 -(* val Init_Proof' (fmz,(dI',pI',mI')) = m;
138.1288 - specify (Init_Proof' (fmz,(dI',pI',mI'))) e_pos' [] EmptyPtree;
138.1289 - *)
138.1290 -fun specify (Init_Proof' (fmz,(dI',pI',mI'))) (_:pos') (_:cid) (_:ptree)=
138.1291 - let (* either """"""""""""""" all empty or complete *)
138.1292 - val thy = assoc_thy dI';
138.1293 - val oris = if dI' = e_domID orelse pI' = e_pblID then ([]:ori list)
138.1294 - else prep_ori fmz thy ((#ppc o get_pbt) pI');
138.1295 - val (pt,c) = cappend_problem e_ptree [] e_istate (fmz,(dI',pI',mI'))
138.1296 - (oris,(dI',pI',mI'),e_term);
138.1297 - val {ppc,prls,where_,...} = get_pbt pI'
138.1298 - (*val pbl = init_pbl ppc; WN.9.03: done in Model/Refine_Problem
138.1299 - val pt = update_pbl pt [] pbl;
138.1300 - val pre = check_preconds thy prls where_ pbl
138.1301 - val pb = foldl and_ (true, map fst pre)*)
138.1302 - val (pbl, pre, pb) = ([], [], false)
138.1303 - in case mI' of
138.1304 - ["no_met"] =>
138.1305 - (([],Pbl), (([],Pbl),Uistate),
138.1306 - Form' (PpcKF (0,EdUndef,(length []),Nundef,
138.1307 - (Problem [], itms2itemppc (assoc_thy dI') pbl pre))),
138.1308 - Refine_Tacitly pI', Safe,pt)
138.1309 - | _ =>
138.1310 - (([],Pbl), (([],Pbl),Uistate),
138.1311 - Form' (PpcKF (0,EdUndef,(length []),Nundef,
138.1312 - (Problem [], itms2itemppc (assoc_thy dI') pbl pre))),
138.1313 - Model_Problem,
138.1314 - Safe,pt)
138.1315 - end
138.1316 - (*ONLY for STARTING modeling phase*)
138.1317 - | specify (Model_Problem' (_,pbl,met)) (pos as (p,p_)) c pt =
138.1318 - let (* val (Model_Problem' (_,pbl), pos as (p,p_)) = (m, (p,p_));
138.1319 - *)
138.1320 - val (PblObj{origin=(oris,(dI',pI',mI'),_), spec=(dI,_,_),...}) =
138.1321 - get_obj I pt p
138.1322 - val thy' = if dI = e_domID then dI' else dI
138.1323 - val thy = assoc_thy thy'
138.1324 - val {ppc,prls,where_,...} = get_pbt pI'
138.1325 - val pre = check_preconds thy prls where_ pbl
138.1326 - val pb = foldl and_ (true, map fst pre)
138.1327 - val ((p,_),_,_,pt) =
138.1328 - generate1 thy (Model_Problem'([],pbl,met)) Uistate pos pt
138.1329 - val (_,nxt) = nxt_spec Pbl pb oris (dI',pI',mI') (pbl,met)
138.1330 - (ppc,(#ppc o get_met) mI') (dI',pI',mI');
138.1331 - in ((p,Pbl), ((p,p_),Uistate),
138.1332 - Form' (PpcKF (0,EdUndef,(length p),Nundef,
138.1333 - (Problem pI', itms2itemppc (assoc_thy dI') pbl pre))),
138.1334 - nxt, Safe, pt) end
138.1335 -
138.1336 -(*. called only if no_met is specified .*)
138.1337 - | specify (Refine_Tacitly' (pI,pIre,_,_,_)) (pos as (p,_)) c pt =
138.1338 - let (* val Refine_Tacitly' (pI,pIre,_,_,_) = m;
138.1339 - *)
138.1340 - val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met, ...}) =
138.1341 - get_obj I pt p;
138.1342 - val {prls,met,ppc,thy,where_,...} = get_pbt pIre
138.1343 - (*val pbl = init_pbl ppc --- Model_Problem recognizes probl=[]*)
138.1344 - (*val pt = update_pbl pt p pbl;
138.1345 - val pt = update_orispec pt p
138.1346 - (string_of_thy thy, pIre,
138.1347 - if length met = 0 then e_metID else hd met);*)
138.1348 - val (domID, metID) = (string_of_thy thy,
138.1349 - if length met = 0 then e_metID else hd met)
138.1350 - val ((p,_),_,_,pt) =
138.1351 - generate1 thy (Refine_Tacitly'(pI,pIre,domID,metID,(*pbl*)[]))
138.1352 - Uistate pos pt
138.1353 - (*val pre = check_preconds thy prls where_ pbl
138.1354 - val pb = foldl and_ (true, map fst pre)*)
138.1355 - val (pbl, pre, pb) = ([], [], false)
138.1356 - in ((p,Pbl), (pos,Uistate),
138.1357 - Form' (PpcKF (0,EdUndef,(length p),Nundef,
138.1358 - (Problem pIre, itms2itemppc (assoc_thy dI') pbl pre))),
138.1359 - Model_Problem, Safe, pt) end
138.1360 -
138.1361 - | specify (Refine_Problem' (rfd as (pI,_))) pos c pt =
138.1362 - let val (pos,_,_,pt) = generate1 (assoc_thy "Isac.thy")
138.1363 - (Refine_Problem' rfd) Uistate pos pt
138.1364 - in (pos(*p,Pbl*), (pos(*p,Pbl*),Uistate), Problems (RefinedKF rfd),
138.1365 - Model_Problem, Safe, pt) end
138.1366 -
138.1367 -(* val (Specify_Problem' (pI, (ok, (itms, pre)))) = nxt; val (p,_) = p;
138.1368 - val (Specify_Problem' (pI, (ok, (itms, pre)))) = m; val (p,_) = p;
138.1369 - *)
138.1370 - | specify (Specify_Problem' (pI, (ok, (itms, pre)))) (pos as (p,_)) c pt =
138.1371 - let val (PblObj {origin=(oris,(dI',pI',mI'),_), spec=(dI,_,mI),
138.1372 - meth=met, ...}) = get_obj I pt p;
138.1373 - (*val pt = update_pbl pt p itms;
138.1374 - val pt = update_pblID pt p pI;*)
138.1375 - val thy = assoc_thy dI
138.1376 - val ((p,Pbl),_,_,pt)=
138.1377 - generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate pos pt
138.1378 - val dI'' = assoc_thy (if dI=e_domID then dI' else dI);
138.1379 - val mI'' = if mI=e_metID then mI' else mI;
138.1380 - (*val _=writeln("@@@ specify (Specify_Problem) before nxt_spec")*)
138.1381 - val (_,nxt) = nxt_spec Pbl ok oris (dI',pI',mI') (itms, met)
138.1382 - ((#ppc o get_pbt) pI,(#ppc o get_met) mI'') (dI,pI,mI);
138.1383 - in ((p,Pbl), (pos,Uistate),
138.1384 - Form' (PpcKF (0,EdUndef,(length p),Nundef,
138.1385 - (Problem pI, itms2itemppc dI'' itms pre))),
138.1386 - nxt, Safe, pt) end
138.1387 -(* val Specify_Method' mID = nxt; val (p,_) = p;
138.1388 - val Specify_Method' mID = m;
138.1389 - specify (Specify_Method' mID) (p,p_) c pt;
138.1390 - *)
138.1391 - | specify (Specify_Method' (mID,_,_)) (pos as (p,_)) c pt =
138.1392 - let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI),
138.1393 - meth=met, ...}) = get_obj I pt p;
138.1394 - val {ppc,pre,prls,...} = get_met mID
138.1395 - val thy = assoc_thy dI
138.1396 - val oris = add_field' thy ppc oris;
138.1397 - (*val pt = update_oris pt p oris; 20.3.02: repl. "#undef"*)
138.1398 - val dI'' = if dI=e_domID then dI' else dI;
138.1399 - val pI'' = if pI = e_pblID then pI' else pI;
138.1400 - val met = if met=[] then pbl else met;
138.1401 - val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris;
138.1402 - (*val pt = update_met pt p itms;
138.1403 - val pt = update_metID pt p mID*)
138.1404 - val (pos,_,_,pt)=
138.1405 - generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt
138.1406 - (*val _=writeln("@@@ specify (Specify_Method) before nxt_spec")*)
138.1407 - val (_,nxt) = nxt_spec Met (*ok*)true oris (dI',pI',mI') (pbl, itms)
138.1408 - ((#ppc o get_pbt) pI'',ppc) (dI'',pI'',mID);
138.1409 - in (pos, (pos,Uistate),
138.1410 - Form' (PpcKF (0,EdUndef,(length p),Nundef,
138.1411 - (Method mID, itms2itemppc (assoc_thy dI'') itms pre'))),
138.1412 - nxt, Safe, pt) end
138.1413 -(* val Add_Find' ct = nxt; val sel = "#Find";
138.1414 - *)
138.1415 - | specify (Add_Given' ct) p c pt = specify_additem "#Given" ct p c pt
138.1416 - | specify (Add_Find' ct) p c pt = specify_additem "#Find" ct p c pt
138.1417 - | specify (Add_Relation' ct) p c pt=specify_additem"#Relate"ct p c pt
138.1418 -(* val Specify_Theory' domID = m;
138.1419 - val (Specify_Theory' domID, (p,p_)) = (m, pos);
138.1420 - *)
138.1421 - | specify (Specify_Theory' domID) (pos as (p,p_)) c pt =
138.1422 - let val p_ = case p_ of Met => Met | _ => Pbl
138.1423 - val thy = assoc_thy domID;
138.1424 - val (PblObj{origin=(oris,(dI',pI',mI'),_), meth=met,
138.1425 - probl=pbl, spec=(dI,pI,mI),...}) = get_obj I pt p;
138.1426 - val mppc = case p_ of Met => met | _ => pbl;
138.1427 - val cpI = if pI = e_pblID then pI' else pI;
138.1428 - val {prls=per,ppc,where_=pwh,...} = get_pbt cpI
138.1429 - val cmI = if mI = e_metID then mI' else mI;
138.1430 - val {prls=mer,ppc=mpc,pre=mwh,...} = get_met cmI
138.1431 - val pre =
138.1432 - case p_ of
138.1433 - Met => (check_preconds thy mer mwh met)
138.1434 - | _ => (check_preconds thy per pwh pbl)
138.1435 - val pb = foldl and_ (true, map fst pre)
138.1436 - in if domID = dI
138.1437 - then let
138.1438 - (*val _=writeln("@@@ specify (Specify_Theory) THEN before nxt_spec")*)
138.1439 - val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI')
138.1440 - (pbl,met) (ppc,mpc) (dI,pI,mI);
138.1441 - in ((p,p_), (pos,Uistate),
138.1442 - Form'(PpcKF (0,EdUndef,(length p), Nundef,
138.1443 - (header p_ pI cmI, itms2itemppc thy mppc pre))),
138.1444 - nxt,Safe,pt) end
138.1445 - else (*FIXME: check ppc wrt. (new!) domID ..? still parsable?*)
138.1446 - let
138.1447 - (*val pt = update_domID pt p domID;11.8.03*)
138.1448 - val ((p,p_),_,_,pt) = generate1 thy (Specify_Theory' domID)
138.1449 - Uistate (p,p_) pt
138.1450 - (*val _=writeln("@@@ specify (Specify_Theory) ELSE before nxt_spec")*)
138.1451 - val (p_,nxt) = nxt_spec p_ pb oris (dI',pI',mI') (pbl,met)
138.1452 - (ppc,mpc) (domID,pI,mI);
138.1453 - in ((p,p_), (pos,Uistate),
138.1454 - Form' (PpcKF (0, EdUndef, (length p),Nundef,
138.1455 - (header p_ pI cmI, itms2itemppc thy mppc pre))),
138.1456 - nxt, Safe,pt) end
138.1457 - end
138.1458 -(* itms2itemppc thy [](*mpc*) pre
138.1459 - *)
138.1460 - | specify m' _ _ _ =
138.1461 - raise error ("specify: not impl. for "^tac_2str m');
138.1462 -
138.1463 -(* val (sel, Add_Given ct, ptp as (pt,(p,Pbl))) = ("#Given", tac, ptp);
138.1464 - val (sel, Add_Find ct, ptp as (pt,(p,Pbl))) = ("#Find", tac, ptp);
138.1465 - *)
138.1466 -fun nxt_specif_additem sel ct (ptp as (pt,(p,Pbl))) =
138.1467 - let
138.1468 - val (PblObj{meth=met,origin=(oris,(dI',pI',_),_),
138.1469 - probl=pbl,spec=(dI,pI,_),...}) = get_obj I pt p;
138.1470 - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
138.1471 - val cpI = if pI = e_pblID then pI' else pI;
138.1472 - in case appl_add thy sel oris pbl ((#ppc o get_pbt) cpI) ct of
138.1473 - Add itm (*..union old input *) =>
138.1474 -(* val Add itm = appl_add thy sel oris pbl ppc ct;
138.1475 - *)
138.1476 - let
138.1477 - (*val _=writeln("###nxt_specif_additem: itm= "^(itm2str_ itm));*)
138.1478 - val pbl' = insert_ppc thy itm pbl
138.1479 - val (tac,tac_) =
138.1480 - case sel of
138.1481 - "#Given" => (Add_Given ct, Add_Given' (ct, pbl'))
138.1482 - | "#Find" => (Add_Find ct, Add_Find' (ct, pbl'))
138.1483 - | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, pbl'))
138.1484 - val ((p,Pbl),c,_,pt') =
138.1485 - generate1 thy tac_ Uistate (p,Pbl) pt
138.1486 - in ([(tac,tac_,((p,Pbl),Uistate))], c, (pt',(p,Pbl))):calcstate' end
138.1487 -
138.1488 - | Err msg =>
138.1489 - (*TODO.WN03 pass error-msgs to the frontend..
138.1490 - FIXME ..and dont abuse a tactic for that purpose*)
138.1491 - ([(Tac msg,
138.1492 - Tac_ (theory "Pure", msg,msg,msg),
138.1493 - (e_pos', e_istate))], [], ptp)
138.1494 - end
138.1495 -
138.1496 -(* val sel = "#Find"; val (p,_) = p; val Add_Find' ct = nxt;
138.1497 - val (_,_,f,nxt',_,pt')= nxt_specif_additem sel ct (p,Met) c pt;
138.1498 - *)
138.1499 - | nxt_specif_additem sel ct (ptp as (pt,(p,Met))) =
138.1500 - let
138.1501 - val (PblObj{meth=met,origin=(oris,(dI',pI',mI'),_),
138.1502 - probl=pbl,spec=(dI,pI,mI),...}) = get_obj I pt p;
138.1503 - val thy = if dI = e_domID then assoc_thy dI' else assoc_thy dI;
138.1504 - val cmI = if mI = e_metID then mI' else mI;
138.1505 - in case appl_add thy sel oris met ((#ppc o get_met) cmI) ct of
138.1506 - Add itm (*..union old input *) =>
138.1507 - let (* val Add itm = appl_add thy sel oris met (#ppc (get_met cmI)) ct;
138.1508 - *)
138.1509 - val met' = insert_ppc thy itm met;
138.1510 - val (tac,tac_) =
138.1511 - case sel of
138.1512 - "#Given" => (Add_Given ct, Add_Given' (ct, met'))
138.1513 - | "#Find" => (Add_Find ct, Add_Find' (ct, met'))
138.1514 - | "#Relate"=> (Add_Relation ct, Add_Relation'(ct, met'))
138.1515 - val ((p,Met),c,_,pt') =
138.1516 - generate1 thy tac_ Uistate (p,Met) pt
138.1517 - in ([(tac,tac_,((p,Met), Uistate))], c, (pt',(p,Met))) end
138.1518 -
138.1519 - | Err msg => ([(*tacis*)], [], ptp)
138.1520 - (*nxt_me collects tacis until not hide; here just no progress*)
138.1521 - end;
138.1522 -
138.1523 -(* ori
138.1524 -val (msg,itm) = appl_add thy sel oris ppc ct;
138.1525 -val (Cor(d,ts)) = #5 itm;
138.1526 -map (atomty) ts;
138.1527 -
138.1528 -pre
138.1529 -*)
138.1530 -fun ori2Coritm pbt ((i,v,f,d,ts):ori) =
138.1531 - (i,v,true,f, Cor ((d,ts),(((snd o snd o the o (find_first (eq1 d))) pbt)
138.1532 - handle _ => raise error ("ori2Coritm: dsc "^
138.1533 - term2str d^
138.1534 - "in ori, but not in pbt")
138.1535 - ,ts))):itm;
138.1536 -fun ori2Coritm (pbt:pat list) ((i,v,f,d,ts):ori) =
138.1537 - ((i,v,true,f, Cor ((d,ts),((snd o snd o the o
138.1538 - (find_first (eq1 d))) pbt,ts))):itm)
138.1539 - handle _ => (*dsc in oris, but not in pbl pat list: keep this dsc*)
138.1540 - ((i,v,true,f, Cor ((d,ts),(d,ts))):itm);
138.1541 -
138.1542 -
138.1543 -(*filter out oris which have same description in itms*)
138.1544 -fun filter_outs oris [] = oris
138.1545 - | filter_outs oris (i::itms) =
138.1546 - let val ors = filter_out ((curry op= ((d_in o #5) (i:itm))) o
138.1547 - (#4:ori -> term)) oris;
138.1548 - in filter_outs ors itms end;
138.1549 -
138.1550 -fun memI a b = member op = a b;
138.1551 -(*filter oris which are in pbt, too*)
138.1552 -fun filter_pbt oris pbt =
138.1553 - let val dscs = map (fst o snd) pbt
138.1554 - in filter ((memI dscs) o (#4: ori -> term)) oris end;
138.1555 -
138.1556 -(*.combine itms from pbl + met and complete them wrt. pbt.*)
138.1557 -(*FIXXXME.WN031205 complete_metitms doesnt handle incorrect itms !*)
138.1558 -local infix mem;
138.1559 -fun x mem [] = false
138.1560 - | x mem (y :: ys) = x = y orelse x mem ys;
138.1561 -in
138.1562 -fun complete_metitms (oris:ori list) (pits:itm list) (mits:itm list) met =
138.1563 -(* val met = (#ppc o get_met) ["DiffApp","max_by_calculus"];
138.1564 - *)
138.1565 - let val vat = max_vt pits;
138.1566 - val itms = pits @
138.1567 - (filter ((curry (op mem) vat) o (#2:itm -> int list)) mits);
138.1568 - val ors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris;
138.1569 - val os = filter_outs ors itms;
138.1570 - (*WN.12.03?: does _NOT_ add itms from met ?!*)
138.1571 - in itms @ (map (ori2Coritm met) os) end
138.1572 -end;
138.1573 -
138.1574 -
138.1575 -
138.1576 -(*.complete model and guard of a calc-head .*)
138.1577 -local infix mem;
138.1578 -fun x mem [] = false
138.1579 - | x mem (y :: ys) = x = y orelse x mem ys;
138.1580 -in
138.1581 -fun complete_mod_ (oris, mpc, ppc, probl) =
138.1582 - let val pits = filter_out ((curry op= false) o (#3: itm -> bool)) probl
138.1583 - val vat = if probl = [] then 1 else max_vt probl
138.1584 - val pors = filter ((curry (op mem) vat) o (#2:ori -> int list)) oris
138.1585 - val pors = filter_outs pors pits (*which are in pbl already*)
138.1586 - val pors = (filter_pbt pors ppc) (*which are in pbt, too*)
138.1587 -
138.1588 - val pits = pits @ (map (ori2Coritm ppc) pors)
138.1589 - val mits = complete_metitms oris pits [] mpc
138.1590 - in (pits, mits) end
138.1591 -end;
138.1592 -
138.1593 -fun some_spec ((odI, opI, omI):spec) ((dI, pI, mI):spec) =
138.1594 - (if dI = e_domID then odI else dI,
138.1595 - if pI = e_pblID then opI else pI,
138.1596 - if mI = e_metID then omI else mI):spec;
138.1597 -
138.1598 -
138.1599 -(*.find a next applicable tac (for calcstate) and update ptree
138.1600 - (for ev. finding several more tacs due to hide).*)
138.1601 -(*FIXXXME: unify ... fun nxt_specif = nxt_spec + applicable_in + specify !!*)
138.1602 -(*WN.24.10.03 ~~~~~~~~~~~~~~ -> tac -> tac_ -> -"- as arg*)
138.1603 -(*WN.24.10.03 fun nxt_solv = ...................................??*)
138.1604 -fun nxt_specif (tac as Model_Problem) (pt, pos as (p,p_)) =
138.1605 - let
138.1606 - val (PblObj{origin=(oris,ospec,_),probl,spec,...}) = get_obj I pt p
138.1607 - val (dI,pI,mI) = some_spec ospec spec
138.1608 - val thy = assoc_thy dI
138.1609 - val mpc = (#ppc o get_met) mI (*just for reuse complete_mod_*)
138.1610 - val {cas,ppc,...} = get_pbt pI
138.1611 - val pbl = init_pbl ppc (*fill in descriptions*)
138.1612 - (*--------------if you think, this should be done by the Dialog
138.1613 - in the java front-end, search there for WN060225-modelProblem----*)
138.1614 - val (pbl,met) = case cas of NONE => (pbl,[])
138.1615 - | _ => complete_mod_ (oris, mpc, ppc, probl)
138.1616 - (*----------------------------------------------------------------*)
138.1617 - val tac_ = Model_Problem' (pI, pbl, met)
138.1618 - val (pos,c,_,pt) = generate1 thy tac_ Uistate pos pt
138.1619 - in ([(tac,tac_, (pos, Uistate))], c, (pt,pos)):calcstate' end
138.1620 -
138.1621 -(* val Add_Find ct = tac;
138.1622 - *)
138.1623 - | nxt_specif (Add_Given ct) ptp = nxt_specif_additem "#Given" ct ptp
138.1624 - | nxt_specif (Add_Find ct) ptp = nxt_specif_additem "#Find" ct ptp
138.1625 - | nxt_specif (Add_Relation ct) ptp = nxt_specif_additem"#Relate" ct ptp
138.1626 -
138.1627 -(*. called only if no_met is specified .*)
138.1628 - | nxt_specif (Refine_Tacitly pI) (ptp as (pt, pos as (p,_))) =
138.1629 - let val (PblObj {origin = (oris, (dI,_,_),_), ...}) = get_obj I pt p
138.1630 - val opt = refine_ori oris pI
138.1631 - in case opt of
138.1632 - SOME pI' =>
138.1633 - let val {met,ppc,...} = get_pbt pI'
138.1634 - val pbl = init_pbl ppc
138.1635 - (*val pt = update_pbl pt p pbl ..done by Model_Problem*)
138.1636 - val mI = if length met = 0 then e_metID else hd met
138.1637 - val thy = assoc_thy dI
138.1638 - val (pos,c,_,pt) =
138.1639 - generate1 thy (Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[]))
138.1640 - Uistate pos pt
138.1641 - in ([(Refine_Tacitly pI, Refine_Tacitly' (pI,pI',dI,mI,(*pbl*)[]),
138.1642 - (pos, Uistate))], c, (pt,pos)) end
138.1643 - | NONE => ([], [], ptp)
138.1644 - end
138.1645 -
138.1646 - | nxt_specif (Refine_Problem pI) (ptp as (pt, pos as (p,_))) =
138.1647 - let val (PblObj {origin=(_,(dI,_,_),_),spec=(dI',_,_),
138.1648 - probl, ...}) = get_obj I pt p
138.1649 - val thy = if dI' = e_domID then dI else dI'
138.1650 - in case refine_pbl (assoc_thy thy) pI probl of
138.1651 - NONE => ([], [], ptp)
138.1652 - | SOME (rfd as (pI',_)) =>
138.1653 - let val (pos,c,_,pt) =
138.1654 - generate1 (assoc_thy thy)
138.1655 - (Refine_Problem' rfd) Uistate pos pt
138.1656 - in ([(Refine_Problem pI, Refine_Problem' rfd,
138.1657 - (pos, Uistate))], c, (pt,pos)) end
138.1658 - end
138.1659 -
138.1660 - | nxt_specif (Specify_Problem pI) (pt, pos as (p,_)) =
138.1661 - let val (PblObj {origin=(oris,(dI,_,_),_),spec=(dI',pI',_),
138.1662 - probl, ...}) = get_obj I pt p;
138.1663 - val thy = assoc_thy (if dI' = e_domID then dI else dI');
138.1664 - val {ppc,where_,prls,...} = get_pbt pI
138.1665 - val pbl as (_,(itms,_)) =
138.1666 - if pI'=e_pblID andalso pI=e_pblID
138.1667 - then (false, (init_pbl ppc, []))
138.1668 - else match_itms_oris thy probl (ppc,where_,prls) oris(*FIXXXXXME?*)
138.1669 - (*FIXXXME~~~~~~~~~~~~~~~: take pbl and compare with new pI WN.8.03*)
138.1670 - val ((p,Pbl),c,_,pt)=
138.1671 - generate1 thy (Specify_Problem' (pI, pbl)) Uistate pos pt
138.1672 - in ([(Specify_Problem pI, Specify_Problem' (pI, pbl),
138.1673 - (pos,Uistate))], c, (pt,pos)) end
138.1674 -
138.1675 - (*transfers oris (not required in pbl) to met-model for script-env
138.1676 - FIXME.WN.8.03: application of several mIDs to SAME model?*)
138.1677 - | nxt_specif (Specify_Method mID) (ptp as (pt, pos as (p,_))) =
138.1678 - let val (PblObj {origin=(oris,(dI',pI',mI'),_), probl=pbl, spec=(dI,pI,mI),
138.1679 - meth=met, ...}) = get_obj I pt p;
138.1680 - val {ppc,pre,prls,...} = get_met mID
138.1681 - val thy = assoc_thy dI
138.1682 - val oris = add_field' thy ppc oris;
138.1683 - val dI'' = if dI=e_domID then dI' else dI;
138.1684 - val pI'' = if pI = e_pblID then pI' else pI;
138.1685 - val met = if met=[] then pbl else met;(*WN0602 what if more itms in met?*)
138.1686 - val (ok, (itms, pre')) = match_itms_oris thy met (ppc,pre,prls ) oris;
138.1687 - val (pos,c,_,pt)=
138.1688 - generate1 thy (Specify_Method' (mID, oris, itms)) Uistate pos pt
138.1689 - in ([(Specify_Method mID, Specify_Method' (mID, oris, itms),
138.1690 - (pos,Uistate))], c, (pt,pos)) end
138.1691 -
138.1692 - | nxt_specif (Specify_Theory dI) (pt, pos as (p,Pbl)) =
138.1693 - let val (dI',_,_) = get_obj g_spec pt p
138.1694 - val (pos,c,_,pt) =
138.1695 - generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI)
138.1696 - Uistate pos pt
138.1697 - in (*FIXXXME: check if pbl can still be parsed*)
138.1698 - ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c,
138.1699 - (pt, pos)) end
138.1700 -
138.1701 - | nxt_specif (Specify_Theory dI) (pt, pos as (p,Met)) =
138.1702 - let val (dI',_,_) = get_obj g_spec pt p
138.1703 - val (pos,c,_,pt) =
138.1704 - generate1 (assoc_thy "Isac.thy") (Specify_Theory' dI)
138.1705 - Uistate pos pt
138.1706 - in (*FIXXXME: check if met can still be parsed*)
138.1707 - ([(Specify_Theory dI, Specify_Theory' dI, (pos,Uistate))], c,
138.1708 - (pt, pos)) end
138.1709 -
138.1710 - | nxt_specif m' _ =
138.1711 - raise error ("nxt_specif: not impl. for "^tac2str m');
138.1712 -
138.1713 -(*.get the values from oris; handle the term list w.r.t. penv.*)
138.1714 -
138.1715 -local infix mem;
138.1716 -fun x mem [] = false
138.1717 - | x mem (y :: ys) = x = y orelse x mem ys;
138.1718 -in
138.1719 -fun vals_of_oris oris =
138.1720 - ((map (mkval' o (#5:ori -> term list))) o
138.1721 - (filter ((curry (op mem) 1) o (#2:ori -> int list)))) oris
138.1722 -end;
138.1723 -
138.1724 -
138.1725 -
138.1726 -(*.create a calc-tree with oris via an cas.refined pbl.*)
138.1727 -fun nxt_specify_init_calc (([],(dI,pI,mI)): fmz) =
138.1728 -(* val ([],(dI,pI,mI)) = (fmz, sp);
138.1729 - *)
138.1730 - if pI <> [] then (*comes from pbl-browser*)
138.1731 - let val {cas,met,ppc,thy,...} = get_pbt pI
138.1732 - val dI = if dI = "" then theory2theory' thy else dI
138.1733 - val thy = assoc_thy dI
138.1734 - val mI = if mI = [] then hd met else mI
138.1735 - val hdl = case cas of NONE => pblterm dI pI | SOME t => t
138.1736 - val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI))
138.1737 - ([], (dI,pI,mI), hdl)
138.1738 - val pt = update_spec pt [] (dI,pI,mI)
138.1739 - val pits = init_pbl' ppc
138.1740 - val pt = update_pbl pt [] pits
138.1741 - in ((pt,([],Pbl)), []): calcstate end
138.1742 - else if mI <> [] then (*comes from met-browser*)
138.1743 - let val {ppc,...} = get_met mI
138.1744 - val dI = if dI = "" then "Isac.thy" else dI
138.1745 - val thy = assoc_thy dI
138.1746 - val (pt,_) = cappend_problem e_ptree [] e_istate ([], (dI,pI,mI))
138.1747 - ([], (dI,pI,mI), e_term(*FIXME met*))
138.1748 - val pt = update_spec pt [] (dI,pI,mI)
138.1749 - val mits = init_pbl' ppc
138.1750 - val pt = update_met pt [] mits
138.1751 - in ((pt,([],Met)), []) end
138.1752 - else (*completely new example*)
138.1753 - let val (pt,_) = cappend_problem e_ptree [] e_istate ([], e_spec)
138.1754 - ([], e_spec, e_term)
138.1755 - in ((pt,([],Pbl)), []) end
138.1756 -(* val (fmz, (dI,pI,mI)) = (fmz, sp);
138.1757 - *)
138.1758 - | nxt_specify_init_calc (fmz:fmz_,(dI,pI,mI):spec) =
138.1759 - let (* either """"""""""""""" all empty or complete *)
138.1760 - val thy = assoc_thy dI
138.1761 - val (pI, pors, mI) =
138.1762 - if mI = ["no_met"]
138.1763 - then let val pors = prep_ori fmz thy ((#ppc o get_pbt) pI)
138.1764 - val pI' = refine_ori' pors pI;
138.1765 - in (pI', pors (*refinement over models with diff.prec only*),
138.1766 - (hd o #met o get_pbt) pI') end
138.1767 - else (pI, prep_ori fmz thy ((#ppc o get_pbt) pI), mI)
138.1768 - val {cas,ppc,thy=thy',...} = get_pbt pI (*take dI from _refined_ pbl*)
138.1769 - val dI = theory2theory' (maxthy thy thy');
138.1770 - val hdl = case cas of
138.1771 - NONE => pblterm dI pI
138.1772 - | SOME t => subst_atomic ((vars_of_pbl_' ppc)
138.1773 - ~~~ vals_of_oris pors) t
138.1774 - val (pt,_) = cappend_problem e_ptree [] e_istate (fmz,(dI,pI,mI))
138.1775 - (pors,(dI,pI,mI),hdl)
138.1776 - (*val pbl = init_pbl ppc WN.9.03: done by Model/Refine_Problem
138.1777 - val pt = update_pbl pt [] pbl*)
138.1778 - in ((pt,([],Pbl)), fst3 (nxt_specif Model_Problem (pt, ([],Pbl))))
138.1779 - end;
138.1780 -
138.1781 -
138.1782 -
138.1783 -(*18.12.99*)
138.1784 -fun get_spec_form (m:tac_) ((p,p_):pos') (pt:ptree) =
138.1785 -(* case appl_spec p pt m of /// 19.1.00
138.1786 - Notappl e => Error' (Error_ e)
138.1787 - | Appl =>
138.1788 -*) let val (_,_,f,_,_,_) = specify m (p,p_) [] pt
138.1789 - in f end;
138.1790 -
138.1791 -
138.1792 -(*fun tag_form thy (formal, given) = cterm_of thy
138.1793 - (((head_of o term_of) given) $ (term_of formal)); WN100819*)
138.1794 -fun tag_form thy (formal, given) =
138.1795 - (let val gf = (head_of given) $ formal;
138.1796 - val _ = cterm_of thy gf
138.1797 - in gf end)
138.1798 - handle _ => raise error ("calchead.tag_form: " ^
138.1799 - Syntax.string_of_term (thy2ctxt thy) given ^
138.1800 - " .. " ^
138.1801 - Syntax.string_of_term (thy2ctxt thy) formal ^
138.1802 - " ..types do not match");
138.1803 -(* val formal = (the o (parse thy)) "[R::real]";
138.1804 -> val given = (the o (parse thy)) "fixed_values (cs::real list)";
138.1805 -> tag_form thy (formal, given);
138.1806 -val it = "fixed_values [R]" : cterm
138.1807 -*)
138.1808 -fun chktyp thy (n, fs, gs) =
138.1809 - ((writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) fs;
138.1810 - (writeln o (Syntax.string_of_term (thy2ctxt thy)) o (nth n)) gs;
138.1811 - tag_form thy (nth n fs, nth n gs));
138.1812 -
138.1813 -fun chktyps thy (fs, gs) = map (tag_form thy) (fs ~~ gs);
138.1814 -
138.1815 -(* #####################################################
138.1816 - find the failing item:
138.1817 -> val n = 2;
138.1818 -> val tag__form = chktyp (n,formals,givens);
138.1819 -> (type_of o term_of o (nth n)) formals;
138.1820 -> (type_of o term_of o (nth n)) givens;
138.1821 -> atomty ((term_of o (nth n)) formals);
138.1822 -> atomty ((term_of o (nth n)) givens);
138.1823 -> atomty (term_of tag__form);
138.1824 -> use_thy"isa-98-1-HOL-plus/knowl-base/DiffAppl";
138.1825 - ##################################################### *)
138.1826 -
138.1827 -(* #####################################################
138.1828 - testdata setup
138.1829 -val origin = ["sqrt(9+4*x)=sqrt x + sqrt(5+x)","x::rat","(+0)"];
138.1830 -val formals = map (the o (parse thy)) origin;
138.1831 -
138.1832 -val given = ["equation (lhs=rhs)",
138.1833 - "bound_variable bdv", (* TODO type *)
138.1834 - "error_bound apx"];
138.1835 -val where_ = ["e is_root_equation_in bdv",
138.1836 - "bdv is_var",
138.1837 - "apx is_const_expr"];
138.1838 -val find = ["L::rat set"];
138.1839 -val with_ = ["L = {bdv. || ((%x. lhs) bdv) - ((%x. rhs) bdv) || < apx}"];
138.1840 -val chkpbl = map (the o (parse thy)) (given @ where_ @ find @ with_);
138.1841 -val givens = map (the o (parse thy)) given;
138.1842 -
138.1843 -val tag__forms = chktyps (formals, givens);
138.1844 -map ((atomty) o term_of) tag__forms;
138.1845 - ##################################################### *)
138.1846 -
138.1847 -
138.1848 -(* check pbltypes, announces one failure a time *)
138.1849 -(*fun chk_vars ctppc =
138.1850 - let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} =
138.1851 - appc flat (mappc (vars o term_of) ctppc)
138.1852 - in if (wh\\gi) <> [] then ("wh\\gi",wh\\gi)
138.1853 - else if (re\\(gi union fi)) <> []
138.1854 - then ("re\\(gi union fi)",re\\(gi union fi))
138.1855 - else ("ok",[]) end;*)
138.1856 -fun chk_vars ctppc =
138.1857 - let val {Given=gi,Where=wh,Find=fi,With=wi,Relate=re} =
138.1858 - appc flat (mappc vars ctppc)
138.1859 - val chked = subtract op = gi wh
138.1860 - in if chked <> [] then ("wh\\gi", chked)
138.1861 - else let val chked = subtract op = (union op = gi fi) re
138.1862 - in if chked <> []
138.1863 - then ("re\\(gi union fi)", chked)
138.1864 - else ("ok", [])
138.1865 - end
138.1866 - end;
138.1867 -
138.1868 -(* check a new pbltype: variables (Free) unbound by given, find*)
138.1869 -fun unbound_ppc ctppc =
138.1870 - let val {Given=gi,Find=fi,Relate=re,...} =
138.1871 - appc flat (mappc vars ctppc)
138.1872 - in distinct (*re\\(gi union fi)*)
138.1873 - (subtract op = (union op = gi fi) re) end;
138.1874 -(*
138.1875 -> val org = {Given=["[R=(R::real)]"],Where=[],
138.1876 - Find=["[A::real]"],With=[],
138.1877 - Relate=["[A=#2*a*b - a^^^#2, (a//#2)^^^#2 + (b//#2)^^^#2 = R^^^#2]"]
138.1878 - }:string ppc;
138.1879 -> val ctppc = mappc (the o (parse thy)) org;
138.1880 -> unbound_ppc ctppc;
138.1881 -val it = [("a","RealDef.real"),("b","RealDef.real")] : (string * typ) list
138.1882 -*)
138.1883 -
138.1884 -
138.1885 -(* f, a binary operator, is nested rightassociative *)
138.1886 -fun foldr1 f xs =
138.1887 - let
138.1888 - fun fld f (x::[]) = x
138.1889 - | fld f (x::x'::[]) = f (x',x)
138.1890 - | fld f (x::x'::xs) = f (fld f (x'::xs),x);
138.1891 - in ((fld f) o rev) xs end;
138.1892 -(*
138.1893 -> val (SOME ct) = parse thy "[a=b,c=d,e=f]";
138.1894 -> val ces = map (cterm_of thy) (isalist2list (term_of ct));
138.1895 -> val conj = foldr1 HOLogic.mk_conj (isalist2list (term_of ct));
138.1896 -> cterm_of thy conj;
138.1897 -val it = "(a = b & c = d) & e = f" : cterm
138.1898 -*)
138.1899 -
138.1900 -(* f, a binary operator, is nested leftassociative *)
138.1901 -fun foldl1 f (x::[]) = x
138.1902 - | foldl1 f (x::x'::[]) = f (x,x')
138.1903 - | foldl1 f (x::x'::xs) = f (x,foldl1 f (x'::xs));
138.1904 -(*
138.1905 -> val (SOME ct) = parse thy "[a=b,c=d,e=f,g=h]";
138.1906 -> val ces = map (cterm_of thy) (isalist2list (term_of ct));
138.1907 -> val conj = foldl1 HOLogic.mk_conj (isalist2list (term_of ct));
138.1908 -> cterm_of thy conj;
138.1909 -val it = "a = b & c = d & e = f & g = h" : cterm
138.1910 -*)
138.1911 -
138.1912 -
138.1913 -(* called only once, if a Subproblem has been located in the script*)
138.1914 -fun nxt_model_pbl (Subproblem'((_,pblID,metID),_,_,_,_)) ptp =
138.1915 -(* val (Subproblem'((_,pblID,metID),_,_,_,_),ptp) = (m', (pt,(p,p_)));
138.1916 - *)
138.1917 - (case metID of
138.1918 - ["no_met"] =>
138.1919 - (snd3 o hd o fst3) (nxt_specif (Refine_Tacitly pblID) ptp)
138.1920 - | _ => (snd3 o hd o fst3) (nxt_specif Model_Problem ptp))
138.1921 - (*all stored in tac_ itms ^^^^^^^^^^*)
138.1922 - | nxt_model_pbl tac_ _ =
138.1923 - raise error ("nxt_model_pbl: called by tac= "^tac_2str tac_);
138.1924 -(* run subp_rooteq.sml ''
138.1925 - until nxt=("Subproblem",Subproblem ("SqRoot.thy",["univariate","equation"]))
138.1926 -> val (_, (Subproblem'((_,pblID,metID),_,_,_,_),_,_,_,_,_)) =
138.1927 - (last_elem o drop_last) ets'';
138.1928 -> val mst = (last_elem o drop_last) ets'';
138.1929 -> nxt_model_pbl mst;
138.1930 -val it = Refine_Tacitly ["univariate","equation"] : tac
138.1931 -*)
138.1932 -
138.1933 -(*fun eq1 d (_,(d',_)) = (d = d'); ---modspec.sml*)
138.1934 -fun eq4 v (_,vts,_,_,_) = member op = vts v;
138.1935 -fun eq5 (_,_,_,_,itm_) (_,_,_,d,_) = d_in itm_ = d;
138.1936 -
138.1937 -
138.1938 -
138.1939 -(*
138.1940 - writeln (oris2str pors);
138.1941 -
138.1942 - writeln (itms2str_ thy pits);
138.1943 - writeln (itms2str_ thy mits);
138.1944 - *)
138.1945 -
138.1946 -
138.1947 -(*.complete _NON_empty calc-head for autocalc (sub-)pbl from oris
138.1948 - + met from fmz; assumes pos on PblObj, meth = [].*)
138.1949 -fun complete_mod (pt, pos as (p, p_):pos') =
138.1950 -(* val (pt, (p, _)) = (pt, p);
138.1951 - val (pt, (p, _)) = (pt, pos);
138.1952 - *)
138.1953 - let val _= if p_ <> Pbl
138.1954 - then writeln("###complete_mod: only impl.for Pbl, called with "^
138.1955 - pos'2str pos) else ()
138.1956 - val (PblObj{origin=(oris, ospec, hdl), probl, spec,...}) =
138.1957 - get_obj I pt p
138.1958 - val (dI,pI,mI) = some_spec ospec spec
138.1959 - val mpc = (#ppc o get_met) mI
138.1960 - val ppc = (#ppc o get_pbt) pI
138.1961 - val (pits, mits) = complete_mod_ (oris, mpc, ppc, probl)
138.1962 - val pt = update_pblppc pt p pits
138.1963 - val pt = update_metppc pt p mits
138.1964 - in (pt, (p,Met):pos') end
138.1965 -;
138.1966 -(*| complete_mod (pt, pos as (p, Met):pos') =
138.1967 - raise error ("###complete_mod: only impl.for Pbl, called with "^
138.1968 - pos'2str pos);*)
138.1969 -
138.1970 -(*.complete _EMPTY_ calc-head for autocalc (sub-)pbl from oris(+met from fmz);
138.1971 - oris and spec (incl. pbl-refinement) given from init_calc or SubProblem .*)
138.1972 -fun all_modspec (pt, (p,_):pos') =
138.1973 -(* val (pt, (p,_)) = ptp;
138.1974 - *)
138.1975 - let val (PblObj{fmz=(fmz_,_), origin=(pors, spec as (dI,pI,mI), hdl),
138.1976 - ...}) = get_obj I pt p;
138.1977 - val thy = assoc_thy dI;
138.1978 - val {ppc,...} = get_met mI;
138.1979 - val mors = prep_ori fmz_ thy ppc;
138.1980 - val pt = update_pblppc pt p (map (ori2Coritm ppc) pors);
138.1981 - val pt = update_metppc pt p (map (ori2Coritm ppc) mors);
138.1982 - val pt = update_spec pt p (dI,pI,mI);
138.1983 - in (pt, (p,Met): pos') end;
138.1984 -
138.1985 -(*WN.12.03: use in nxt_spec, too ? what about variants ???*)
138.1986 -fun is_complete_mod_ ([]: itm list) = false
138.1987 - | is_complete_mod_ itms =
138.1988 - foldl and_ (true, (map #3 itms));
138.1989 -fun is_complete_mod (pt, pos as (p, Pbl): pos') =
138.1990 - if (is_pblobj o (get_obj I pt)) p
138.1991 - then (is_complete_mod_ o (get_obj g_pbl pt)) p
138.1992 - else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos)
138.1993 - | is_complete_mod (pt, pos as (p, Met)) =
138.1994 - if (is_pblobj o (get_obj I pt)) p
138.1995 - then (is_complete_mod_ o (get_obj g_met pt)) p
138.1996 - else raise error ("is_complete_mod: called by PrfObj at "^pos'2str pos)
138.1997 - | is_complete_mod (_, pos) =
138.1998 - raise error ("is_complete_mod called by "^pos'2str pos^
138.1999 - " (should be Pbl or Met)");
138.2000 -
138.2001 -(*.have (thy, pbl, met) _all_ been specified explicitly ?.*)
138.2002 -fun is_complete_spec (pt, pos as (p,_): pos') =
138.2003 - if (not o is_pblobj o (get_obj I pt)) p
138.2004 - then raise error ("is_complete_spec: called by PrfObj at "^pos'2str pos)
138.2005 - else let val (dI,pI,mI) = get_obj g_spec pt p
138.2006 - in dI<>e_domID andalso pI<>e_pblID andalso mI<>e_metID end;
138.2007 -(*.complete empty items in specification from origin (pbl, met ev.refined);
138.2008 - assumes 'is_complete_mod'.*)
138.2009 -fun complete_spec (pt, pos as (p,_): pos') =
138.2010 - let val PblObj {origin = (_,ospec,_), spec,...} = get_obj I pt p
138.2011 - val pt = update_spec pt p (some_spec ospec spec)
138.2012 - in (pt, pos) end;
138.2013 -
138.2014 -fun is_complete_modspec ptp =
138.2015 - is_complete_mod ptp andalso is_complete_spec ptp;
138.2016 -
138.2017 -
138.2018 -
138.2019 -
138.2020 -fun pt_model (PblObj {meth,spec,origin=(_,spec',hdl),...}) Met =
138.2021 -(* val ((PblObj {meth,spec,origin=(_,spec',hdl),...}), Met) = (ppobj, p_);
138.2022 - *)
138.2023 - let val (_,_,metID) = get_somespec' spec spec'
138.2024 - val pre =
138.2025 - if metID = e_metID then []
138.2026 - else let val {prls,pre=where_,...} = get_met metID
138.2027 - val pre = check_preconds' prls where_ meth 0
138.2028 - in pre end
138.2029 - val allcorrect = is_complete_mod_ meth
138.2030 - andalso foldl and_ (true, (map #1 pre))
138.2031 - in ModSpec (allcorrect, Met, hdl, meth, pre, spec) end
138.2032 - | pt_model (PblObj {probl,spec,origin=(_,spec',hdl),...}) _(*Frm,Pbl*) =
138.2033 -(* val ((PblObj {probl,spec,origin=(_,spec',hdl),...}),_) = (ppobj, p_);
138.2034 - *)
138.2035 - let val (_,pI,_) = get_somespec' spec spec'
138.2036 - val pre =
138.2037 - if pI = e_pblID then []
138.2038 - else let val {prls,where_,cas,...} = get_pbt pI
138.2039 - val pre = check_preconds' prls where_ probl 0
138.2040 - in pre end
138.2041 - val allcorrect = is_complete_mod_ probl
138.2042 - andalso foldl and_ (true, (map #1 pre))
138.2043 - in ModSpec (allcorrect, Pbl, hdl, probl, pre, spec) end;
138.2044 -
138.2045 -
138.2046 -fun pt_form (PrfObj {form,...}) = Form form
138.2047 - | pt_form (PblObj {probl,spec,origin=(_,spec',_),...}) =
138.2048 - let val (dI, pI, _) = get_somespec' spec spec'
138.2049 - val {cas,...} = get_pbt pI
138.2050 - in case cas of
138.2051 - NONE => Form (pblterm dI pI)
138.2052 - | SOME t => Form (subst_atomic (mk_env probl) t)
138.2053 - end;
138.2054 -(*vvv takes the tac _generating_ the formula=result, asm ok....
138.2055 -fun pt_result (PrfObj {result=(t,asm), tac,...}) =
138.2056 - (Form t,
138.2057 - if null asm then NONE else SOME asm,
138.2058 - SOME tac)
138.2059 - | pt_result (PblObj {result=(t,asm), origin = (_,ospec,_), spec,...}) =
138.2060 - let val (_,_,metID) = some_spec ospec spec
138.2061 - in (Form t,
138.2062 - if null asm then NONE else SOME asm,
138.2063 - if metID = e_metID then NONE else SOME (Apply_Method metID)) end;
138.2064 --------------------------------------------------------------------------*)
138.2065 -
138.2066 -
138.2067 -(*.pt_extract returns
138.2068 - # the formula at pos
138.2069 - # the tactic applied to this formula
138.2070 - # the list of assumptions generated at this formula
138.2071 - (by application of another tac to the preceding formula !)
138.2072 - pos is assumed to come from the frontend, ie. generated by moveDown.*)
138.2073 -(*cannot be in ctree.sml, because ModSpec has to be calculated*)
138.2074 -fun pt_extract (pt,([],Res)) =
138.2075 -(* val (pt,([],Res)) = ptp;
138.2076 - *)
138.2077 - let val (f, asm) = get_obj g_result pt []
138.2078 - in (Form f, NONE, asm) end
138.2079 -(* val p = [3,2];
138.2080 - *)
138.2081 - | pt_extract (pt,(p,Res)) =
138.2082 -(* val (pt,(p,Res)) = ptp;
138.2083 - *)
138.2084 - let val (f, asm) = get_obj g_result pt p
138.2085 - val tac = if last_onlev pt p
138.2086 - then if is_pblobj' pt (lev_up p)
138.2087 - then let val (PblObj{spec=(_,pI,_),...}) =
138.2088 - get_obj I pt (lev_up p)
138.2089 - in if pI = e_pblID then NONE
138.2090 - else SOME (Check_Postcond pI) end
138.2091 - else SOME End_Trans (*WN0502 TODO for other branches*)
138.2092 - else let val p' = lev_on p
138.2093 - in if is_pblobj' pt p'
138.2094 - then let val (PblObj{origin = (_,(dI,pI,_),_),...}) =
138.2095 - get_obj I pt p'
138.2096 - in SOME (Subproblem (dI, pI)) end
138.2097 - else if f = get_obj g_form pt p'
138.2098 - then SOME (get_obj g_tac pt p')
138.2099 - (*because this Frm ~~~is not on worksheet*)
138.2100 - else SOME (Take (term2str (get_obj g_form pt p')))
138.2101 - end
138.2102 - in (Form f, tac, asm) end
138.2103 -
138.2104 - | pt_extract (pt, pos as (p,p_(*Frm,Pbl*))) =
138.2105 -(* val (pt, pos as (p,p_(*Frm,Pbl*))) = ptp;
138.2106 - val (pt, pos as (p,p_(*Frm,Pbl*))) = (pt, p);
138.2107 - *)
138.2108 - let val ppobj = get_obj I pt p
138.2109 - val f = if is_pblobj ppobj then pt_model ppobj p_
138.2110 - else get_obj pt_form pt p
138.2111 - val tac = g_tac ppobj
138.2112 - in (f, SOME tac, []) end;
138.2113 -
138.2114 -
138.2115 -(**. get the formula from a ctree-node:
138.2116 - take form+res from PblObj and 1.PrfObj and (PrfObj after PblObj)
138.2117 - take res from all other PrfObj's .**)
138.2118 -(*designed for interSteps, outcommented 04 in favour of calcChangedEvent*)
138.2119 -fun formres p (Nd (PblObj {origin = (_,_, h), result = (r, _),...}, _)) =
138.2120 - [("headline", (p, Frm), h),
138.2121 - ("stepform", (p, Res), r)]
138.2122 - | formres p (Nd (PrfObj {form, result = (r, _),...}, _)) =
138.2123 - [("stepform", (p, Frm), form),
138.2124 - ("stepform", (p, Res), r)];
138.2125 -
138.2126 -fun form p (Nd (PrfObj {result = (r, _),...}, _)) =
138.2127 - [("stepform", (p, Res), r)]
138.2128 -
138.2129 -(*assumes to take whole level, in particular hd -- for use in interSteps*)
138.2130 -fun get_formress fs p [] = flat fs
138.2131 - | get_formress fs p (nd::nds) =
138.2132 - (* start with 'form+res' and continue with trying 'res' only*)
138.2133 - get_forms (fs @ [formres p nd]) (lev_on p) nds
138.2134 -and get_forms fs p [] = flat fs
138.2135 - | get_forms fs p (nd::nds) =
138.2136 - if is_pblnd nd
138.2137 - (* start again with 'form+res' ///ugly repeat with Check_elementwise
138.2138 - then get_formress (fs @ [formres p nd]) (lev_on p) nds *)
138.2139 - then get_forms (fs @ [formres p nd]) (lev_on p) nds
138.2140 - (* continue with trying 'res' only*)
138.2141 - else get_forms (fs @ [form p nd]) (lev_on p) nds;
138.2142 -
138.2143 -(**.get an 'interval' 'from' 'to' of formulae from a ptree.**)
138.2144 -(*WN050219 made robust against _'to' below or after Complete nodes
138.2145 - by handling exn caused by move_dn*)
138.2146 -(*WN0401 this functionality belongs to ctree.sml,
138.2147 -but fetching a calc_head requires calculations defined in modspec.sml
138.2148 -transfer to ME/me.sml !!!
138.2149 -WN051224 ^^^ doesnt hold any longer, since only the headline of a calc_head
138.2150 -is returned !!!!!!!!!!!!!
138.2151 -*)
138.2152 -fun eq_pos' (p1,Frm) (p2,Frm) = p1 = p2
138.2153 - | eq_pos' (p1,Res) (p2,Res) = p1 = p2
138.2154 - | eq_pos' (p1,Pbl) (p2,p2_) = p1 = p2 andalso (case p2_ of
138.2155 - Pbl => true
138.2156 - | Met => true
138.2157 - | _ => false)
138.2158 - | eq_pos' (p1,Met) (p2,p2_) = p1 = p2 andalso (case p2_ of
138.2159 - Pbl => true
138.2160 - | Met => true
138.2161 - | _ => false)
138.2162 - | eq_pos' _ _ = false;
138.2163 -
138.2164 -(*.get an 'interval' from the ctree; 'interval' is w.r.t. the
138.2165 - total ordering Position#compareTo(Position p) in the java-code
138.2166 -val get_interval = fn
138.2167 - : pos' -> : from is "move_up 1st-element" to return
138.2168 - pos' -> : to the last element to be returned; from < to
138.2169 - int -> : level: 0 gets the flattest sub-tree possible
138.2170 - >999 gets the deepest sub-tree possible
138.2171 - ptree -> :
138.2172 - (pos' * : of the formula
138.2173 - Term.term) : the formula
138.2174 - list
138.2175 -.*)
138.2176 -fun get_interval from to level pt =
138.2177 -(* val (from,level) = (f,lev);
138.2178 - val (from, to, level) = (([3, 2, 1], Res), ([],Res), 9999);
138.2179 - *)
138.2180 - let fun get_inter c (from:pos') (to:pos') lev pt =
138.2181 -(* val (c, from, to, lev) = ([], from, to, level);
138.2182 - ------for recursion.......
138.2183 - val (c, from:pos', to:pos') = (c @ [(from, f)], move_dn [] pt from, to);
138.2184 - *)
138.2185 - if eq_pos' from to orelse from = ([],Res)
138.2186 - (*orelse ... avoids Exception- PTREE "end of calculation" raised,
138.2187 - if 'to' has values NOT generated by move_dn, see systest/me.sml
138.2188 - TODO.WN0501: introduce an order on pos' and check "from > to"..
138.2189 - ...there is an order in Java!
138.2190 - WN051224 the hack got worse with returning term instead ptform*)
138.2191 - then let val (f,_,_) = pt_extract (pt, from)
138.2192 - in case f of
138.2193 - ModSpec (_,_,headline,_,_,_) => c @ [(from, headline)]
138.2194 - | Form t => c @ [(from, t)]
138.2195 - end
138.2196 - else
138.2197 - if lev < lev_of from
138.2198 - then (get_inter c (move_dn [] pt from) to lev pt)
138.2199 - handle (PTREE _(*from move_dn too far*)) => c
138.2200 - else let val (f,_,_) = pt_extract (pt, from)
138.2201 - val term = case f of
138.2202 - ModSpec (_,_,headline,_,_,_)=> headline
138.2203 - | Form t => t
138.2204 - in (get_inter (c @ [(from, term)])
138.2205 - (move_dn [] pt from) to lev pt)
138.2206 - handle (PTREE _(*from move_dn too far*))
138.2207 - => c @ [(from, term)] end
138.2208 - in get_inter [] from to level pt end;
138.2209 -
138.2210 -(*for tests*)
138.2211 -fun posform2str (pos:pos', form) =
138.2212 - "("^ pos'2str pos ^", "^
138.2213 - (case form of
138.2214 - Form f => term2str f
138.2215 - | ModSpec c => term2str (#3 c(*the headline*)))
138.2216 - ^")";
138.2217 -fun posforms2str pfs = (strs2str' o (map (curry op ^ "\n")) o
138.2218 - (map posform2str)) pfs;
138.2219 -fun posterm2str (pos:pos', t) =
138.2220 - "("^ pos'2str pos ^", "^term2str t^")";
138.2221 -fun posterms2str pfs = (strs2str' o (map (curry op ^ "\n")) o
138.2222 - (map posterm2str)) pfs;
138.2223 -
138.2224 -
138.2225 -(*WN050225 omits the last step, if pt is incomplete*)
138.2226 -fun show_pt pt =
138.2227 - writeln (posterms2str (get_interval ([],Frm) ([],Res) 99999 pt));
138.2228 -
138.2229 -(*.get a calchead from a PblObj-node in the ctree;
138.2230 - preconditions must be calculated.*)
138.2231 -fun get_ocalhd (pt, pos' as (p,Pbl):pos') =
138.2232 - let val PblObj {origin = (oris, ospec, hdf'), spec, probl,...} =
138.2233 - get_obj I pt p
138.2234 - val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec))
138.2235 - val pre = check_preconds (assoc_thy"Isac.thy") prls where_ probl
138.2236 - in (ocalhd_complete probl pre spec, Pbl, hdf', probl, pre, spec):ocalhd end
138.2237 -| get_ocalhd (pt, pos' as (p,Met):pos') =
138.2238 - let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'),
138.2239 - spec, meth,...} =
138.2240 - get_obj I pt p
138.2241 - val {prls,pre,...} = get_met (#3 (some_spec ospec spec))
138.2242 - val pre = check_preconds (assoc_thy"Isac.thy") prls pre meth
138.2243 - in (ocalhd_complete meth pre spec, Met, hdf', meth, pre, spec):ocalhd end;
138.2244 -
138.2245 -(*.at the activeFormula set the Model, the Guard and the Specification
138.2246 - to empty and return a CalcHead;
138.2247 - the 'origin' remains (for reconstructing all that).*)
138.2248 -fun reset_calchead (pt, pos' as (p,_):pos') =
138.2249 - let val PblObj {origin = (_, _, hdf'),...} = get_obj I pt p
138.2250 - val pt = update_pbl pt p []
138.2251 - val pt = update_met pt p []
138.2252 - val pt = update_spec pt p e_spec
138.2253 - in (pt, (p,Pbl):pos') end;
138.2254 -
138.2255 -(*---------------------------------------------------------------------*)
138.2256 -end
138.2257 -
138.2258 -open CalcHead;
138.2259 -(*---------------------------------------------------------------------*)
138.2260 -
139.1 --- a/src/Tools/isac/ME/ctree.sml Wed Aug 25 15:15:01 2010 +0200
139.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
139.3 @@ -1,2154 +0,0 @@
139.4 -(* use"../ME/ctree.sml";
139.5 - use"ME/ctree.sml";
139.6 - use"ctree.sml";
139.7 - W.N.26.10.99
139.8 -
139.9 -writeln (pr_ptree pr_short pt);
139.10 -
139.11 -val Nd ( _, ns) = pt;
139.12 -
139.13 -*)
139.14 -
139.15 -(*structure Ptree (**): PTREE (**) = ###### outcommented ######*)
139.16 -signature PTREE =
139.17 -sig
139.18 - type ptree
139.19 - type envp
139.20 - val e_ptree : ptree
139.21 - exception PTREE of string
139.22 - type branch
139.23 - type ostate
139.24 - type cellID
139.25 - type cid
139.26 - type posel
139.27 - type pos
139.28 - type pos'
139.29 - type loc
139.30 - type domID
139.31 - type pblID
139.32 - type metID
139.33 - type spec
139.34 - type 'a ppc
139.35 - type con
139.36 - type subs
139.37 - type subst
139.38 - type env
139.39 - type ets
139.40 - val ets2str : ets -> string
139.41 - type item
139.42 - type tac
139.43 - type tac_
139.44 - val tac_2str : tac_ -> string
139.45 - type safe
139.46 - val safe2str : safe -> string
139.47 -
139.48 - type meth
139.49 - val cappend_atomic : ptree -> pos -> loc -> cterm' -> tac
139.50 - -> cterm' -> ostate -> cid -> ptree * posel list * cid
139.51 - val cappend_form : ptree
139.52 - -> pos -> loc -> cterm' -> cid -> ptree * pos * cid
139.53 - val cappend_parent : ptree -> pos -> loc -> cterm' -> tac
139.54 - -> branch -> cid -> ptree * int list * cid
139.55 - val cappend_problem : ptree -> posel list(*FIXME*) -> loc
139.56 - -> cterm' list * spec -> cid -> ptree * int list * cellID list
139.57 - val append_result : ptree -> pos -> cterm' -> ostate -> ptree * pos
139.58 -
139.59 - type ppobj
139.60 - val g_branch : ppobj -> branch
139.61 - val g_cell : ppobj -> cid
139.62 - val g_args : ppobj -> (int * (term list)) list (*args of scr*)
139.63 - val g_form : ppobj -> cterm'
139.64 - val g_loc : ppobj -> loc
139.65 - val g_met : ppobj -> meth
139.66 - val g_domID : ppobj -> domID
139.67 - val g_metID : ppobj -> metID
139.68 - val g_model : ppobj -> cterm' ppc
139.69 - val g_tac : ppobj -> tac
139.70 - val g_origin : ppobj -> cterm' list * spec
139.71 - val g_ostate : ppobj -> ostate
139.72 - val g_pbl : ppobj -> pblID * item ppc
139.73 - val g_result : ppobj -> cterm'
139.74 - val g_spec : ppobj -> spec
139.75 -(* val get_all : (ppobj -> 'a) -> ptree -> 'a list
139.76 - val get_alls : (ppobj -> 'a) -> ptree list -> 'a list *)
139.77 - val get_obj : (ppobj -> 'a) -> ptree -> pos -> 'a
139.78 - val gpt_cell : ptree -> cid
139.79 - val par_pblobj : ptree -> pos -> pos
139.80 - val pre_pos : pos -> pos
139.81 - val lev_dn : int list -> int list
139.82 - val lev_on : pos -> posel list
139.83 - val lev_pred : pos -> pos
139.84 - val lev_up : pos -> pos
139.85 -(* val pr_cell : pos -> ppobj -> string
139.86 - val pr_pos : int list -> string *)
139.87 - val pr_ptree : (pos -> ppobj -> string) -> ptree -> string
139.88 - val pr_short : pos -> ppobj -> string
139.89 -(* val repl : 'a list -> int -> 'a -> 'a list
139.90 - val repl_app : 'a list -> int -> 'a -> 'a list
139.91 - val repl_branch : branch -> ppobj -> ppobj
139.92 - val repl_domID : domID -> ppobj -> ppobj
139.93 - val repl_form : cterm' -> ppobj -> ppobj
139.94 - val repl_met : item ppc -> ppobj -> ppobj
139.95 - val repl_metID : metID -> ppobj -> ppobj
139.96 - val repl_model : cterm' list -> ppobj -> ppobj
139.97 - val repl_tac : tac -> ppobj -> ppobj
139.98 - val repl_pbl : item ppc -> ppobj -> ppobj
139.99 - val repl_pblID : pblID -> ppobj -> ppobj
139.100 - val repl_result : cterm' -> ostate -> ppobj -> ppobj
139.101 - val repl_spec : spec -> ppobj -> ppobj
139.102 - val repl_subs : (string * string) list -> ppobj -> ppobj *)
139.103 - val rootthy : ptree -> domID
139.104 -(* val test_trans : ppobj -> bool
139.105 - val uni__asm : (string * pos) list -> ppobj -> ppobj
139.106 - val uni__cid : cellID list -> ppobj -> ppobj *)
139.107 - val union_asm : ptree -> pos -> (string * pos) list -> ptree
139.108 - val union_cid : ptree -> pos -> cellID list -> ptree
139.109 - val update_branch : ptree -> pos -> branch -> ptree
139.110 - val update_domID : ptree -> pos -> domID -> ptree
139.111 - val update_met : ptree -> pos -> meth -> ptree
139.112 - val update_metppc : ptree -> pos -> item ppc -> ptree
139.113 - val update_metID : ptree -> pos -> metID -> ptree
139.114 - val update_tac : ptree -> pos -> tac -> ptree
139.115 - val update_pbl : ptree -> pos -> pblID * item ppc -> ptree
139.116 - val update_pblppc : ptree -> pos -> item ppc -> ptree
139.117 - val update_pblID : ptree -> pos -> pblID -> ptree
139.118 - val update_spec : ptree -> pos -> spec -> ptree
139.119 - val update_subs : ptree -> pos -> (string * string) list -> ptree
139.120 -
139.121 - val rep_pblobj : ppobj
139.122 - -> {branch:branch, cell:cid, env:envp, loc:loc, meth:meth, model:cterm' ppc,
139.123 - origin:cterm' list * spec, ostate:ostate, probl:pblID * item ppc,
139.124 - result:cterm', spec:spec}
139.125 - val rep_prfobj : ppobj
139.126 - -> {branch:branch, cell:cid, form:cterm', loc:loc, tac:tac,
139.127 - ostate:ostate, result:cterm'}
139.128 -end
139.129 -
139.130 -(* --------------
139.131 -structure Ptree (**): PTREE (**) =
139.132 -struct
139.133 - -------------- *)
139.134 -
139.135 -type env = (term * term) list;
139.136 -
139.137 -
139.138 -datatype branch =
139.139 - NoBranch | AndB | OrB
139.140 - | TransitiveB (* FIXXXME.8.03: set branch from met in Apply_Method
139.141 - FIXXXME.0402: -"- in Begin_Trans'*)
139.142 - | SequenceB | IntersectB | CollectB | MapB;
139.143 -fun branch2str NoBranch = "NoBranch"
139.144 - | branch2str AndB = "AndB"
139.145 - | branch2str OrB = "OrB"
139.146 - | branch2str TransitiveB = "TransitiveB"
139.147 - | branch2str SequenceB = "SequenceB"
139.148 - | branch2str IntersectB = "IntersectB"
139.149 - | branch2str CollectB = "CollectB"
139.150 - | branch2str MapB = "MapB";
139.151 -
139.152 -datatype ostate =
139.153 - Incomplete | Complete | Inconsistent(*WN041020 latter unused*);
139.154 -fun ostate2str Incomplete = "Incomplete"
139.155 - | ostate2str Complete = "Complete"
139.156 - | ostate2str Inconsistent = "Inconsistent";
139.157 -
139.158 -type cellID = int;
139.159 -type cid = cellID list;
139.160 -
139.161 -type posel = int; (* roundabout for (some of) nice signatures *)
139.162 -type pos = posel list;
139.163 -val pos2str = ints2str';
139.164 -datatype pos_ =
139.165 - Pbl (*PblObj-position: problem-type*)
139.166 - | Met (*PblObj-position: method*)
139.167 - | Frm (*PblObj-position: -> Pbl in ME (not by moveDown !)
139.168 - | PrfObj-position: formula*)
139.169 - | Res (*PblObj | PrfObj-position: result*)
139.170 - | Und; (*undefined*)
139.171 -fun pos_2str Pbl = "Pbl"
139.172 - | pos_2str Met = "Met"
139.173 - | pos_2str Frm = "Frm"
139.174 - | pos_2str Res = "Res"
139.175 - | pos_2str Und = "Und";
139.176 -
139.177 -type pos' = pos * pos_;
139.178 -(*WN.12.03 remembering interator (pos * pos_) for ptree
139.179 - pos : lev_on, lev_dn, lev_up,
139.180 - lev_onFrm, lev_dnRes (..see solve Apply_Method !)
139.181 - pos_:
139.182 -# generate1 sets pos_ if possible ...?WN0502?NOT...
139.183 -# generate1 does NOT set pos, because certain nodes can be lev_on OR lev_dn
139.184 - exceptions: Begin/End_Trans
139.185 -# thus generate(1) called in
139.186 -.# assy, locate_gen
139.187 -.# nxt_solv (tac_ -cases); general case:
139.188 - val pos' = case pos' of (p,Res) => (lev_on p',Res) | _ => pos'
139.189 -# WN050220, S(604):
139.190 - generate1...(Rewrite(f,..,res))..(pos, pos_)
139.191 - cappend_atomic.................pos ////// gets f+res always!!!
139.192 - cut_tree....................pos, pos_
139.193 -*)
139.194 -fun pos'2str (p,p_) = pair2str (ints2str' p, pos_2str p_);
139.195 -fun pos's2str ps = (strs2str' o (map pos'2str)) ps;
139.196 -val e_pos' = ([],Und):pos';
139.197 -
139.198 -fun res2str (t, ts) = pair2str (term2str t, terms2str ts);
139.199 -fun asm2str (t, p:pos) = pair2str (term2str t, ints2str' p);
139.200 -fun asms2str asms = (strs2str' o (map asm2str)) asms;
139.201 -
139.202 -
139.203 -
139.204 -(*26.4.02: never used after introduction of scripts !!!
139.205 -type loc = loc_ * (* + interpreter-state *)
139.206 - (loc_ * rls') (* -"- for script of the ruleset*)
139.207 - option;
139.208 -val e_loc = ([],NONE):loc;
139.209 -val ee_loc = (e_loc,e_loc);*)
139.210 -
139.211 -
139.212 -datatype safe = Sundef | Safe | Unsafe | Helpless;
139.213 -fun safe2str Sundef = "Sundef"
139.214 - | safe2str Safe = "Safe"
139.215 - | safe2str Unsafe = "Unsafe"
139.216 - | safe2str Helpless = "Helpless";
139.217 -
139.218 -type subs = cterm' list; (*16.11.00 for FE-KE*)
139.219 -val e_subs = ["(bdv, x)"];
139.220 -
139.221 -(*._sub_stitution as strings of _e_qualities.*)
139.222 -type sube = cterm' list;
139.223 -val e_sube = []:cterm' list;
139.224 -fun sube2str s = strs2str s;
139.225 -
139.226 -(*._sub_stitution as _t_erms of _e_qualities.*)
139.227 -type subte = term list;
139.228 -val e_subte = []:term list;
139.229 -fun subte2str ss = terms2str ss;
139.230 -
139.231 -fun subte2sube ss = map term2str ss;
139.232 -
139.233 -fun subst2subs s = map (pair2str o
139.234 - (apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o
139.235 - (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s;
139.236 -fun subst2subs' s = map ((apfst (Syntax.string_of_term (thy2ctxt' "Isac"))) o
139.237 - (apsnd (Syntax.string_of_term (thy2ctxt' "Isac")))) s;
139.238 -fun subs2subst thy s = map (isapair2pair o term_of o the o (parse thy)) s;
139.239 -(*> subs2subst thy ["(bdv,x)","(err,#0)"];
139.240 -val it =
139.241 - [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real")),
139.242 - (Free ("err","RealDef.real"),Free ("#0","RealDef.real"))]
139.243 - : (term * term) list*)
139.244 -(*["bdv=x","err=0"] ---> [(bdv,x), (err,0)]*)
139.245 -fun sube2subst thy s = map (dest_equals' o term_of o the o (parse thy)) s;
139.246 -(* val ts = sube2subst thy ["bdv=x","err=0"];
139.247 - subst2str' ts;
139.248 - *)
139.249 -fun sube2subte ss = map str2term ss;
139.250 -
139.251 -
139.252 -fun isasub2subst isasub = ((map isapair2pair) o isalist2list) isasub;
139.253 -
139.254 -
139.255 -type scrstate = (*state for script interpreter*)
139.256 - env(*stack*) (*used to instantiate tac for checking assod
139.257 - 12.03.noticed: e_ not updated during execution ?!?*)
139.258 - * loc_ (*location of tac in script*)
139.259 - * term option(*argument of curried functions*)
139.260 - * term (*value obtained by tac executed
139.261 - updated also after a derivation by 'new_val'*)
139.262 - * safe (*estimation of how result will be obtained*)
139.263 - * bool; (*true = strongly .., false = weakly associated:
139.264 - only used during ass_dn/up*)
139.265 -val e_scrstate = ([],[],NONE,e_term,Sundef,false):scrstate;
139.266 -
139.267 -
139.268 -(*21.8.02 ---> definitions.sml for datatype scr
139.269 -type rrlsstate = (*state for reverse rewriting*)
139.270 - (term * (*the current formula*)
139.271 - rule list (*of reverse rewrite set (#1#)*)
139.272 - list * (*may be serveral, eg. in norm_rational*)
139.273 - (rule * (*Thm (+ Thm generated from Calc) resulting in ...*)
139.274 - (term * (*... rewrite with ...*)
139.275 - term list)) (*... assumptions*)
139.276 - list); (*derivation from given term to normalform
139.277 - in reverse order with sym_thm;
139.278 - (#1#) could be extracted from here #1*) --------*)
139.279 -
139.280 -datatype istate = (*interpreter state*)
139.281 - Uistate (*undefined in modspec, in '_deriv'ation*)
139.282 - | ScrState of scrstate (*for script interpreter*)
139.283 - | RrlsState of rrlsstate; (*for reverse rewriting*)
139.284 -val e_istate = (ScrState ([],[],NONE,e_term,Sundef,false)):istate;
139.285 -
139.286 -type iist = istate option * istate option;
139.287 -(*val e_iist = (e_istate, e_istate); --- sinnlos f"ur NICHT-equality-type*)
139.288 -
139.289 -
139.290 -fun rta2str (r,(t,a)) = "\n("^(rule2str r)^",("^(term2str t)^", "^
139.291 - (terms2str a)^"))";
139.292 -fun istate2str Uistate = "Uistate"
139.293 - | istate2str (ScrState (e,l,to,t,s,b):istate) =
139.294 - "ScrState ("^ subst2str e ^",\n "^
139.295 - loc_2str l ^", "^ termopt2str to ^",\n "^
139.296 - term2str t ^", "^ safe2str s ^", "^ bool2str b ^")"
139.297 - | istate2str (RrlsState (t,t1,rss,rtas)) =
139.298 - "RrlsState ("^(term2str t)^", "^(term2str t1)^", "^
139.299 - ((strs2str o (map (strs2str o (map rule2str)))) rss)^", "^
139.300 - ((strs2str o (map rta2str)) rtas)^")";
139.301 -fun istates2str (NONE, NONE) = "(#NONE, #NONE)"
139.302 - | istates2str (NONE, SOME ist) = "(#NONE,\n#SOME "^istate2str ist^")"
139.303 - | istates2str (SOME ist, NONE) = "(#SOME "^istate2str ist^",\n #NONE)"
139.304 - | istates2str (SOME i1, SOME i2) = "(#SOME "^istate2str i1^",\n #SOME "^
139.305 - istate2str i2^")";
139.306 -
139.307 -fun new_val v (ScrState (env, loc_, topt, _, safe, bool)) =
139.308 - (ScrState (env, loc_, topt, v, safe, bool))
139.309 - | new_val _ _ = raise error "new_val: only for ScrState";
139.310 -
139.311 -datatype con = land | lor;
139.312 -
139.313 -
139.314 -type spec =
139.315 - domID * (*WN.12.03: is replaced by thy from get_met ?FIXME? in:
139.316 - specify (Init_Proof..), nxt_specify_init_calc,
139.317 - assod (.SubProblem...), stac2tac (.SubProblem...)*)
139.318 - pblID *
139.319 - metID;
139.320 -fun spec2str ((dom,pbl,met)(*:spec*)) =
139.321 - "(" ^ (quote dom) ^ ", " ^ (strs2str pbl) ^
139.322 - ", " ^ (strs2str met) ^ ")";
139.323 -(*> spec2str empty_spec;
139.324 -val it = "(\"\", [], (\"\", \"\"))" : string *)
139.325 -val empty_spec = (e_domID,e_pblID,e_metID):spec;
139.326 -val e_spec = empty_spec;
139.327 -
139.328 -
139.329 -
139.330 -(*.tactics propagate the construction of the calc-tree;
139.331 - there are
139.332 - (a) 'specsteps' for the specify-phase, and others for the solve-phase
139.333 - (b) those of the solve-phase are 'initac's and others;
139.334 - initacs start with a formula different from the preceding formula.
139.335 - see 'type tac_' for the internal representation of tactics.*)
139.336 -datatype tac =
139.337 - Init_Proof of ((cterm' list) * spec)
139.338 -(*'specsteps'...*)
139.339 -| Model_Problem
139.340 -| Refine_Problem of pblID | Refine_Tacitly of pblID
139.341 -
139.342 -| Add_Given of cterm' | Del_Given of cterm'
139.343 -| Add_Find of cterm' | Del_Find of cterm'
139.344 -| Add_Relation of cterm' | Del_Relation of cterm'
139.345 -
139.346 -| Specify_Theory of domID | Specify_Problem of pblID
139.347 -| Specify_Method of metID
139.348 -(*...'specsteps'*)
139.349 -| Apply_Method of metID
139.350 -(*.creates an 'istate' in PblObj.env; in case of 'init_form'
139.351 - creates a formula at ((lev_on o lev_dn) p, Frm) and in this ppobj.'loc'
139.352 - 'SOME istate' (at fst of 'loc').
139.353 - As each step (in the solve-phase) has a resulting formula (at the front-end)
139.354 - Apply_Method also does the 1st step in the script (an 'initac') if there
139.355 - is no 'init_form' .*)
139.356 -| Check_Postcond of pblID
139.357 -| Free_Solve
139.358 -
139.359 -| Rewrite_Inst of ( subs * thm') | Rewrite of thm'
139.360 - | Rewrite_Asm of thm'
139.361 -| Rewrite_Set_Inst of ( subs * rls') | Rewrite_Set of rls'
139.362 -| Detail_Set_Inst of ( subs * rls') | Detail_Set of rls'
139.363 -| End_Detail (*end of script from next_tac,
139.364 - in solve: switches back to parent script WN0509 drop!*)
139.365 -| Derive of rls' (*an input formula using rls WN0509 drop!*)
139.366 -| Calculate of string (* plus | minus | times | cancel | pow | sqrt *)
139.367 -| End_Ruleset
139.368 -| Substitute of sube | Apply_Assumption of cterm' list
139.369 -
139.370 -| Take of cterm' (*an 'initac'*)
139.371 -| Take_Inst of cterm'
139.372 -| Group of (con * int list )
139.373 -| Subproblem of (domID * pblID) (*an 'initac'*)
139.374 -| CAScmd of cterm' (*6.6.02 URD: Function formula; WN0509 drop!*)
139.375 -| End_Subproblem (*WN0509 drop!*)
139.376 -
139.377 -| Split_And | Conclude_And
139.378 -| Split_Or | Conclude_Or
139.379 -| Begin_Trans | End_Trans
139.380 -| Begin_Sequ | End_Sequ(* substitute root.env *)
139.381 -| Split_Intersect | End_Intersect
139.382 -| Check_elementwise of cterm' | Collect_Trues
139.383 -| Or_to_List
139.384 -
139.385 -| Empty_Tac (*TODO.11.6.03 ... of string: could carry msg of (Notappl msg)
139.386 - in 'helpless'*)
139.387 -| Tac of string(* eg.'repeat'*WN0509 drop!*)
139.388 -| User (*internal, for ets*WN0509 drop!*)
139.389 -| End_Proof';(* inout*)
139.390 -
139.391 -(* tac2str /--> library.sml: needed in dialog.sml for 'separable *)
139.392 -fun tac2str (ma:tac) = case ma of
139.393 - Init_Proof (ppc, spec) =>
139.394 - "Init_Proof "^(pair2str (strs2str ppc, spec2str spec))
139.395 - | Model_Problem => "Model_Problem "
139.396 - | Refine_Tacitly pblID => "Refine_Tacitly "^(strs2str pblID)
139.397 - | Refine_Problem pblID => "Refine_Problem "^(strs2str pblID)
139.398 - | Add_Given cterm' => "Add_Given "^cterm'
139.399 - | Del_Given cterm' => "Del_Given "^cterm'
139.400 - | Add_Find cterm' => "Add_Find "^cterm'
139.401 - | Del_Find cterm' => "Del_Find "^cterm'
139.402 - | Add_Relation cterm' => "Add_Relation "^cterm'
139.403 - | Del_Relation cterm' => "Del_Relation "^cterm'
139.404 -
139.405 - | Specify_Theory domID => "Specify_Theory "^(quote domID )
139.406 - | Specify_Problem pblID => "Specify_Problem "^(strs2str pblID )
139.407 - | Specify_Method metID => "Specify_Method "^(strs2str metID)
139.408 - | Apply_Method metID => "Apply_Method "^(strs2str metID)
139.409 - | Check_Postcond pblID => "Check_Postcond "^(strs2str pblID)
139.410 - | Free_Solve => "Free_Solve"
139.411 -
139.412 - | Rewrite_Inst (subs,thm')=>
139.413 - "Rewrite_Inst "^(pair2str (subs2str subs, spair2str thm'))
139.414 - | Rewrite thm' => "Rewrite "^(spair2str thm')
139.415 - | Rewrite_Asm thm' => "Rewrite_Asm "^(spair2str thm')
139.416 - | Rewrite_Set_Inst (subs, rls) =>
139.417 - "Rewrite_Set_Inst "^(pair2str (subs2str subs, quote rls))
139.418 - | Rewrite_Set rls => "Rewrite_Set "^(quote rls )
139.419 - | Detail_Set rls => "Detail_Set "^(quote rls )
139.420 - | Detail_Set_Inst (subs, rls) =>
139.421 - "Detail_Set_Inst "^(pair2str (subs2str subs, quote rls))
139.422 - | End_Detail => "End_Detail"
139.423 - | Derive rls' => "Derive "^rls'
139.424 - | Calculate op_ => "Calculate "^op_
139.425 - | Substitute sube => "Substitute "^sube2str sube
139.426 - | Apply_Assumption ct's => "Apply_Assumption "^(strs2str ct's)
139.427 -
139.428 - | Take cterm' => "Take "^(quote cterm' )
139.429 - | Take_Inst cterm' => "Take_Inst "^(quote cterm' )
139.430 - | Group (con, ints) =>
139.431 - "Group "^(pair2str (con2str con, ints2str ints))
139.432 - | Subproblem (domID, pblID) =>
139.433 - "Subproblem "^(pair2str (domID, strs2str pblID))
139.434 -(*| Subproblem_Full (spec, cts') =>
139.435 - "Subproblem_Full "^(pair2str (spec2str spec, strs2str cts'))*)
139.436 - | End_Subproblem => "End_Subproblem"
139.437 - | CAScmd cterm' => "CAScmd "^(quote cterm')
139.438 -
139.439 - | Check_elementwise cterm'=> "Check_elementwise "^(quote cterm')
139.440 - | Or_to_List => "Or_to_List "
139.441 - | Collect_Trues => "Collect_Trues"
139.442 -
139.443 - | Empty_Tac => "Empty_Tac"
139.444 - | Tac string => "Tac "^string
139.445 - | User => "User"
139.446 - | End_Proof' => "tac End_Proof'"
139.447 - | _ => "tac2str not impl. for ?!";
139.448 -
139.449 -fun is_rewset (Rewrite_Set_Inst _) = true
139.450 - | is_rewset (Rewrite_Set _) = true
139.451 - | is_rewset _ = false;
139.452 -fun is_rewtac (Rewrite _) = true
139.453 - | is_rewtac (Rewrite_Inst _) = true
139.454 - | is_rewtac (Rewrite_Asm _) = true
139.455 - | is_rewtac tac = is_rewset tac;
139.456 -
139.457 -fun tac2IDstr (ma:tac) = case ma of
139.458 - Model_Problem => "Model_Problem"
139.459 - | Refine_Tacitly pblID => "Refine_Tacitly"
139.460 - | Refine_Problem pblID => "Refine_Problem"
139.461 - | Add_Given cterm' => "Add_Given"
139.462 - | Del_Given cterm' => "Del_Given"
139.463 - | Add_Find cterm' => "Add_Find"
139.464 - | Del_Find cterm' => "Del_Find"
139.465 - | Add_Relation cterm' => "Add_Relation"
139.466 - | Del_Relation cterm' => "Del_Relation"
139.467 -
139.468 - | Specify_Theory domID => "Specify_Theory"
139.469 - | Specify_Problem pblID => "Specify_Problem"
139.470 - | Specify_Method metID => "Specify_Method"
139.471 - | Apply_Method metID => "Apply_Method"
139.472 - | Check_Postcond pblID => "Check_Postcond"
139.473 - | Free_Solve => "Free_Solve"
139.474 -
139.475 - | Rewrite_Inst (subs,thm')=> "Rewrite_Inst"
139.476 - | Rewrite thm' => "Rewrite"
139.477 - | Rewrite_Asm thm' => "Rewrite_Asm"
139.478 - | Rewrite_Set_Inst (subs, rls) => "Rewrite_Set_Inst"
139.479 - | Rewrite_Set rls => "Rewrite_Set"
139.480 - | Detail_Set rls => "Detail_Set"
139.481 - | Detail_Set_Inst (subs, rls) => "Detail_Set_Inst"
139.482 - | Derive rls' => "Derive "
139.483 - | Calculate op_ => "Calculate "
139.484 - | Substitute subs => "Substitute"
139.485 - | Apply_Assumption ct's => "Apply_Assumption"
139.486 -
139.487 - | Take cterm' => "Take"
139.488 - | Take_Inst cterm' => "Take_Inst"
139.489 - | Group (con, ints) => "Group"
139.490 - | Subproblem (domID, pblID) => "Subproblem"
139.491 - | End_Subproblem => "End_Subproblem"
139.492 - | CAScmd cterm' => "CAScmd"
139.493 -
139.494 - | Check_elementwise cterm'=> "Check_elementwise"
139.495 - | Or_to_List => "Or_to_List "
139.496 - | Collect_Trues => "Collect_Trues"
139.497 -
139.498 - | Empty_Tac => "Empty_Tac"
139.499 - | Tac string => "Tac "
139.500 - | User => "User"
139.501 - | End_Proof' => "End_Proof'"
139.502 - | _ => "tac2str not impl. for ?!";
139.503 -
139.504 -fun rls_of (Rewrite_Set_Inst (_, rls)) = rls
139.505 - | rls_of (Rewrite_Set rls) = rls
139.506 - | rls_of tac = raise error ("rls_of: called with tac '"^tac2IDstr tac^"'");
139.507 -
139.508 -fun thm_of_rew (Rewrite_Inst (subs,(thmID,_))) =
139.509 - (thmID, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst))
139.510 - | thm_of_rew (Rewrite (thmID,_)) = (thmID, NONE)
139.511 - | thm_of_rew (Rewrite_Asm (thmID,_)) = (thmID, NONE);
139.512 -
139.513 -fun rls_of_rewset (Rewrite_Set_Inst (subs,rls)) =
139.514 - (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst))
139.515 - | rls_of_rewset (Rewrite_Set rls) = (rls, NONE)
139.516 - | rls_of_rewset (Detail_Set rls) = (rls, NONE)
139.517 - | rls_of_rewset (Detail_Set_Inst (subs, rls)) =
139.518 - (rls, SOME ((subs2subst (assoc_thy "Isac.thy") subs):subst));
139.519 -
139.520 -fun rule2tac _ (Calc (opID, thm)) = Calculate (calID2calcID opID)
139.521 - | rule2tac [] (Thm (thmID, thm)) = Rewrite (thmID, string_of_thmI thm)
139.522 - | rule2tac subst (Thm (thmID, thm)) =
139.523 - Rewrite_Inst (subst2subs subst, (thmID, string_of_thmI thm))
139.524 - | rule2tac [] (Rls_ rls) = Rewrite_Set (id_rls rls)
139.525 - | rule2tac subst (Rls_ rls) =
139.526 - Rewrite_Set_Inst (subst2subs subst, (id_rls rls))
139.527 - | rule2tac _ rule =
139.528 - raise error ("rule2tac: called with '" ^ rule2str rule ^ "'");
139.529 -
139.530 -type fmz_ = cterm' list;
139.531 -
139.532 -(*.a formalization of an example containing data
139.533 - sufficient for mechanically finding the solution for the example.*)
139.534 -(*FIXME.WN051014: dont store fmz = (_,spec) in the PblObj,
139.535 - this is done in origin*)
139.536 -type fmz = fmz_ * spec;
139.537 -val e_fmz = ([],e_spec);
139.538 -
139.539 -(*tac_ is made from tac in applicable_in,
139.540 - and carries all data necessary for generate;*)
139.541 -datatype tac_ =
139.542 -(* datatype tac = *)
139.543 - Init_Proof' of ((cterm' list) * spec)
139.544 - (* ori list !: code specify -> applicable*)
139.545 -| Model_Problem' of pblID *
139.546 - itm list * (*the 'untouched' pbl*)
139.547 - itm list (*the casually completed met*)
139.548 -| Refine_Tacitly' of pblID * (*input*)
139.549 - pblID * (*the refined from applicable_in*)
139.550 - domID * (*from new pbt?! filled in specify*)
139.551 - metID * (*from new pbt?! filled in specify*)
139.552 - itm list (*drop ! 9.03: remains [] for
139.553 - Model_Problem recognizing its activation*)
139.554 -| Refine_Problem' of (pblID * (itm list * (bool * Term.term) list))
139.555 - (*FIXME?040215 drop: done automatically in init_proof + Subproblem'*)
139.556 -| Add_Given' of cterm' *
139.557 - itm list (*updated with input in fun specify_additem*)
139.558 -| Add_Find' of cterm' *
139.559 - itm list (*updated with input in fun specify_additem*)
139.560 -| Add_Relation' of cterm' *
139.561 - itm list (*updated with input in fun specify_additem*)
139.562 -| Del_Given' of cterm' | Del_Find' of cterm' | Del_Relation' of cterm'
139.563 - (*4.00.: all.. term: in applicable_in ..? Syn ?only for FormFK?*)
139.564 -
139.565 -| Specify_Theory' of domID
139.566 -| Specify_Problem' of (pblID * (* *)
139.567 - (bool * (* matches *)
139.568 - (itm list * (* ppc *)
139.569 - (bool * term) list))) (* preconditions *)
139.570 -| Specify_Method' of metID *
139.571 - ori list * (*repl. "#undef"*)
139.572 - itm list (*... updated from pbl to met*)
139.573 -| Apply_Method' of metID *
139.574 - (term option) * (*init_form*)
139.575 - istate
139.576 -| Check_Postcond' of
139.577 - pblID *
139.578 - (term * (*returnvalue of script in solve*)
139.579 - cterm' list)(*collect by get_assumptions_ in applicable_in, except if
139.580 - butlast tac is Check_elementwise: take only these asms*)
139.581 -| Free_Solve'
139.582 -
139.583 -| Rewrite_Inst' of theory' * rew_ord' * rls
139.584 - * bool * subst * thm' * term * (term * term list)
139.585 -| Rewrite' of theory' * rew_ord' * rls * bool * thm' *
139.586 - term * (term * term list)
139.587 -| Rewrite_Asm' of theory' * rew_ord' * rls * bool * thm' *
139.588 - term * (term * term list)
139.589 -| Rewrite_Set_Inst' of theory' * bool * subst * rls *
139.590 - term * (term * term list)
139.591 -| Detail_Set_Inst' of theory' * bool * subst * rls *
139.592 - term * (term * term list)
139.593 -| Rewrite_Set' of theory' * bool * rls * term * (term * term list)
139.594 -| Detail_Set' of theory' * bool * rls * term * (term * term list)
139.595 -| End_Detail' of (term * (term list)) (*see End_Trans'*)
139.596 -| End_Ruleset' of term
139.597 -| Derive' of rls
139.598 -| Calculate' of theory' * string * term * (term * thm')
139.599 - (*WN.29.4.03 asm?: * term list??*)
139.600 -| Substitute' of subte (*the 'substitution': terms of type bool*)
139.601 - * term (*to be substituted in*)
139.602 - * term (*resulting from the substitution*)
139.603 -| Apply_Assumption' of term list * term
139.604 -
139.605 -| Take' of term | Take_Inst' of term
139.606 -| Group' of (con * int list * term)
139.607 -| Subproblem' of (spec *
139.608 - (ori list) * (*filled in assod Subproblem'*)
139.609 - term * (*-"-, headline of calc-head *)
139.610 - fmz_ *
139.611 - term) (*Subproblem(dom,pbl)*)
139.612 -| CAScmd' of term
139.613 -| End_Subproblem' of term (*???*)
139.614 -| Split_And' of term | Conclude_And' of term
139.615 -| Split_Or' of term | Conclude_Or' of term
139.616 -| Begin_Trans' of term | End_Trans' of (term * (term list))
139.617 -| Begin_Sequ' | End_Sequ'(* substitute root.env*)
139.618 -| Split_Intersect' of term | End_Intersect' of term
139.619 -| Check_elementwise' of (*special case:*)
139.620 - term * (*(1)the current formula: [x=1,x=...]*)
139.621 - string * (*(2)the pred from Check_elementwise *)
139.622 - (term * (*(3)composed from (1) and (2): {x. pred}*)
139.623 - term list) (*20.5.03 assumptions*)
139.624 -
139.625 -| Or_to_List' of term * term (* (a | b, [a,b]) *)
139.626 -| Collect_Trues' of term
139.627 -
139.628 -| Empty_Tac_ | Tac_ of (*for dummies*)
139.629 - theory *
139.630 - string * (*form*)
139.631 - string * (*in Tac*)
139.632 - string (*result of Tac".."*)
139.633 -| User' (*internal for ets*) | End_Proof'';(*End_Proof:inout*)
139.634 -
139.635 -fun tac_2str ma = case ma of
139.636 - Init_Proof' (ppc, spec) =>
139.637 - "Init_Proof' "^(pair2str (strs2str ppc, spec2str spec))
139.638 - | Model_Problem' (pblID,_,_) => "Model_Problem' "^(strs2str pblID )
139.639 - | Refine_Tacitly'(p,prefin,domID,metID,itms)=>
139.640 - "Refine_Tacitly' ("
139.641 - ^(strs2str p)^", "^(strs2str prefin)^", "
139.642 - ^domID^", "^(strs2str metID)^", pbl-itms)"
139.643 - | Refine_Problem' ms => "Refine_Problem' ("^(*matchs2str ms*)"..."^")"
139.644 -(*| Match_Problem' (pI, (ok, (itms, pre))) =>
139.645 - "Match_Problem' "^(spair2str (strs2str pI,
139.646 - spair2str (bool2str ok,
139.647 - spair2str ("itms2str_ itms",
139.648 - "items2str pre"))))*)
139.649 - | Add_Given' cterm' => "Add_Given' "(*^cterm'*)
139.650 - | Del_Given' cterm' => "Del_Given' "(*^cterm'*)
139.651 - | Add_Find' cterm' => "Add_Find' "(*^cterm'*)
139.652 - | Del_Find' cterm' => "Del_Find' "(*^cterm'*)
139.653 - | Add_Relation' cterm' => "Add_Relation' "(*^cterm'*)
139.654 - | Del_Relation' cterm' => "Del_Relation' "(*^cterm'*)
139.655 -
139.656 - | Specify_Theory' domID => "Specify_Theory' "^(quote domID )
139.657 - | Specify_Problem' (pI, (ok, (itms, pre))) =>
139.658 - "Specify_Problem' "^(spair2str (strs2str pI,
139.659 - spair2str (bool2str ok,
139.660 - spair2str ("itms2str_ itms",
139.661 - "items2str pre"))))
139.662 - | Specify_Method' (pI,oris,itms) =>
139.663 - "Specify_Method' ("^metID2str pI^", "^oris2str oris^", )"
139.664 -
139.665 - | Apply_Method' (metID,_,_) => "Apply_Method' "^(strs2str metID)
139.666 - | Check_Postcond' (pblID,(scval,asm)) =>
139.667 - "Check_Postcond' "^(spair2str(strs2str pblID,
139.668 - spair2str (term2str scval, strs2str asm)))
139.669 -
139.670 - | Free_Solve' => "Free_Solve'"
139.671 -
139.672 - | Rewrite_Inst' (*subs,thm'*) _ =>
139.673 - "Rewrite_Inst' "(*^(pair2str (subs2str subs, spair2str thm'))*)
139.674 - | Rewrite' thm' => "Rewrite' "(*^(spair2str thm')*)
139.675 - | Rewrite_Asm' thm' => "Rewrite_Asm' "(*^(spair2str thm')*)
139.676 - | Rewrite_Set_Inst' (*subs,thm'*) _ =>
139.677 - "Rewrite_Set_Inst' "(*^(pair2str (subs2str subs, quote rls))*)
139.678 - | Rewrite_Set'(thy',pasm,rls',f,(f',asm))
139.679 - => "Rewrite_Set' ("^thy'^","^(bool2str pasm)^","^(id_rls rls')^","
139.680 - ^(Syntax.string_of_term (thy2ctxt' "Isac") f)^",("^(Syntax.string_of_term (thy2ctxt' "Isac") f')
139.681 - ^","^((strs2str o (map (Syntax.string_of_term (thy2ctxt' "Isac")))) asm)^"))"
139.682 -
139.683 - | End_Detail' _ => "End_Detail' xxx"
139.684 - | Detail_Set' _ => "Detail_Set' xxx"
139.685 - | Detail_Set_Inst' _ => "Detail_Set_Inst' xxx"
139.686 -
139.687 - | Derive' rls => "Derive' "^id_rls rls
139.688 - | Calculate' _ => "Calculate' "
139.689 - | Substitute' subs => "Substitute' "(*^(subs2str subs)*)
139.690 - | Apply_Assumption' ct's => "Apply_Assumption' "(*^(strs2str ct's)*)
139.691 -
139.692 - | Take' cterm' => "Take' "(*^(quote cterm' )*)
139.693 - | Take_Inst' cterm' => "Take_Inst' "(*^(quote cterm' )*)
139.694 - | Group' (con, ints, _) =>
139.695 - "Group' "^(pair2str (con2str con, ints2str ints))
139.696 - | Subproblem' (spec, oris, _,_,pbl_form) =>
139.697 - "Subproblem' "(*^(pair2str (domID, strs2str ,...))*)
139.698 - | End_Subproblem' _ => "End_Subproblem'"
139.699 - | CAScmd' cterm' => "CAScmd' "(*^(quote cterm')*)
139.700 -
139.701 - | Empty_Tac_ => "Empty_Tac_"
139.702 - | User' => "User'"
139.703 - | Tac_ (_,form,id,result) => "Tac_ (thy,"^form^","^id^","^result^")"
139.704 - | _ => "tac_2str not impl. for arg";
139.705 -
139.706 -(*'executed tactics' (tac_s) with local environment etc.;
139.707 - used for continuing eval script + for generate*)
139.708 -type ets =
139.709 - (loc_ * (* of tactic in scr, tactic (weakly) associated with tac_*)
139.710 - (tac_ * (* (for generate) *)
139.711 - env * (* with 'tactic=result' as a rule, tactic ev. _not_ ready:
139.712 - for handling 'parallel let'*)
139.713 - env * (* with results of (ready) tacs *)
139.714 - term * (* itr_arg of tactic, for upd. env at Repeat, Try*)
139.715 - term * (* result value of the tac *)
139.716 - safe))
139.717 - list;
139.718 -val Ets = []:ets;
139.719 -
139.720 -
139.721 -fun ets2s (l,(m,eno,env,iar,res,s)) =
139.722 - "\n("^(loc_2str l)^",("^(tac_2str m)^
139.723 - ",\n ens= "^(subst2str eno)^
139.724 - ",\n env= "^(subst2str env)^
139.725 - ",\n iar= "^(Syntax.string_of_term (thy2ctxt' "Isac") iar)^
139.726 - ",\n res= "^(Syntax.string_of_term (thy2ctxt' "Isac") res)^
139.727 - ",\n "^(safe2str s)^"))";
139.728 -fun ets2str (ets:ets) = (strs2str o (map ets2s)) ets;
139.729 -
139.730 -
139.731 -type envp =(*9.5.03: unused, delete with field in ptree.PblObj FIXXXME*)
139.732 - (int * term list) list * (*assoc-list: args of met*)
139.733 - (int * rls) list * (*assoc-list: tacs already done ///15.9.00*)
139.734 - (int * ets) list * (*assoc-list: tacs etc. already done*)
139.735 - (string * pos) list; (*asms * from where*)
139.736 -val empty_envp = ([],[],[],[]):envp;
139.737 -
139.738 -datatype ppobj =
139.739 - PrfObj of {cell : lrd option, (*where in form tac has been applied*)
139.740 - (*^^^FIXME.WN0607 rename this field*)
139.741 - form : term,
139.742 - tac : tac, (* also in istate*)
139.743 - loc : istate option * istate option, (*for form, result
139.744 -13.8.02: (NONE,NONE) <==> e_istate ! see update_loc, get_loc*)
139.745 - branch: branch,
139.746 - result: term * term list,
139.747 - ostate: ostate} (*Complete <=> result is OK*)
139.748 - | PblObj of {cell : lrd option,(*unused: meaningful only for some _Prf_Obj*)
139.749 - fmz : fmz, (*from init:FIXME never use this spec;-drop*)
139.750 - origin: (ori list) * (*representation from fmz+pbt
139.751 - for efficiently adding items in probl, meth*)
139.752 - spec * (*updated by Refine_Tacitly*)
139.753 - term, (*headline of calc-head, as calculated
139.754 - initially(!)*)
139.755 - (*# the origin of a root-pbl is created from fmz
139.756 - (thus providing help for input to the user),
139.757 - # the origin of a sub-pbl is created from the argument
139.758 - -list of a script-tac 'SubProblem (spec) [arg-list]'
139.759 - by 'match_ags'*)
139.760 - spec : spec, (*explicitly input*)
139.761 - probl : itm list, (*itms explicitly input*)
139.762 - meth : itm list, (*itms automatically added to copy of probl
139.763 - TODO: input like to 'probl'*)
139.764 - env : istate option,(*for problem with initac in script*)
139.765 - loc : istate option * istate option, (*for pbl+met * result*)
139.766 - branch: branch,
139.767 - result: term * term list,
139.768 - ostate: ostate}; (*Complete <=> result is _proven_ OK*)
139.769 -
139.770 -(*.this tree contains isac's calculations; TODO.WN03 rename to ctree;
139.771 - the structure has been copied from an early version of Theorema(c);
139.772 - it has the disadvantage, that there is no space
139.773 - for the first tactic in a script generating the first formula at (p,Frm);
139.774 - this trouble has been covered by 'init_form' and 'Take' so far,
139.775 - but it is crucial if the first tactic in a script is eg. 'Subproblem';
139.776 - see 'type tac ', Apply_Method.
139.777 -.*)
139.778 -datatype ptree =
139.779 - EmptyPtree
139.780 - | Nd of ppobj * (ptree list);
139.781 -val e_ptree = EmptyPtree;
139.782 -
139.783 -fun rep_prfobj (PrfObj {cell,form,tac,loc,branch,result,ostate}) =
139.784 - {cell=cell,form=form,tac=tac,loc=loc,branch=branch,result=result,ostate=ostate};
139.785 -fun rep_pblobj (PblObj {cell,origin,fmz,spec,probl,meth,env,
139.786 - loc,branch,result,ostate}) =
139.787 - {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,meth=meth,
139.788 - env=env,loc=loc,branch=branch,result=result,ostate=ostate};
139.789 -fun is_prfobj (PrfObj _) = true
139.790 - | is_prfobj _ =false;
139.791 -(*val is_prfobj' = get_obj is_prfobj; *)
139.792 -fun is_pblobj (PblObj _) = true
139.793 - | is_pblobj _ = false;
139.794 -(*val is_pblobj' = get_obj is_pblobj; 'Error: unbound constructor get_obj'*)
139.795 -
139.796 -
139.797 -exception PTREE of string;
139.798 -fun nth _ [] = raise PTREE "nth _ []"
139.799 - | nth 1 (x::xs) = x
139.800 - | nth n (x::xs) = nth (n-1) xs;
139.801 -(*> nth 2 [11,22,33]; -->> val it = 22 : int*)
139.802 -
139.803 -fun lev_up ([]:pos) = raise PTREE "lev_up []"
139.804 - | lev_up p = (drop_last p):pos;
139.805 -fun lev_on ([]:pos) = raise PTREE "lev_on []"
139.806 - | lev_on pos =
139.807 - let val len = length pos
139.808 - in (drop_last pos) @ [(nth len pos)+1] end;
139.809 -fun lev_onFrm ((p,_):pos') = (lev_on p,Frm):pos'
139.810 - | lev_onFrm p = raise PTREE ("*** lev_onFrm: pos'="^(pos'2str p));
139.811 -(*040216: for inform --> embed_deriv: remains on same level*)
139.812 -fun lev_back (([],_):pos') = raise PTREE "lev_on_back: called by ([],_)"
139.813 - | lev_back (p,_) =
139.814 - if last_elem p <= 1 then (p, Frm):pos'
139.815 - else ((drop_last p) @ [(nth (length p) p) - 1], Res);
139.816 -(*.increase pos by n within a level.*)
139.817 -fun pos_plus 0 pos = pos
139.818 - | pos_plus n ((p,Frm):pos') = pos_plus (n-1) (p, Res)
139.819 - | pos_plus n ((p, _):pos') = pos_plus (n-1) (lev_on p, Res);
139.820 -
139.821 -
139.822 -
139.823 -fun lev_pred ([]:pos) = raise PTREE "lev_pred []"
139.824 - | lev_pred (pos:pos) =
139.825 - let val len = length pos
139.826 - in ((drop_last pos) @ [(nth len pos)-1]):pos end;
139.827 -(*lev_pred [1,2,3];
139.828 -val it = [1,2,2] : pos
139.829 -> lev_pred [1];
139.830 -val it = [0] : pos *)
139.831 -
139.832 -fun lev_dn p = p @ [0];
139.833 -(*> (lev_dn o lev_on) [1,2,3];
139.834 -val it = [1,2,4,0] : pos *)
139.835 -(*fun lev_dn' ((p,p_):pos') = (lev_dn p, Frm):pos'; WN.3.12.03: never used*)
139.836 -fun lev_dnRes ((p,_):pos') = (lev_dn p, Res):pos';
139.837 -
139.838 -(*4.4.00*)
139.839 -fun lev_up_ ((p,Res):pos') = (lev_up p,Res):pos'
139.840 - | lev_up_ p' = raise error ("lev_up_: called for "^(pos'2str p'));
139.841 -fun lev_dn_ ((p,_):pos') = (lev_dn p,Res):pos'
139.842 -fun ind ((p,_):pos') = length p; (*WN050108 deprecated in favour of lev_of*)
139.843 -fun lev_of ((p,_):pos') = length p;
139.844 -
139.845 -
139.846 -(** convert ptree to a string **)
139.847 -
139.848 -(* convert a pos from list to string *)
139.849 -fun pr_pos ps = (space_implode "." (map string_of_int ps))^". ";
139.850 -(* show hd origin or form only *)
139.851 -fun pr_short (p:pos) (PblObj {origin = (ori,_,_),...}) =
139.852 - ((pr_pos p) ^ " ----- pblobj -----\n")
139.853 -(* ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^
139.854 - (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^
139.855 - "\n") *)
139.856 - | pr_short p (PrfObj {form = form,...}) =
139.857 - ((pr_pos p) ^ (term2str form) ^ "\n");
139.858 -(*
139.859 -fun pr_cell (p:pos) (PblObj {cell = c, origin = (ori,_,_),...}) =
139.860 - ((ints2str c) ^" "^
139.861 - ((((Syntax.string_of_term (thy2ctxt' "Isac")) o #4 o hd) ori)^" "^
139.862 - (((Syntax.string_of_term (thy2ctxt' "Isac")) o hd(*!?!*) o #5 o hd) ori))^
139.863 - "\n")
139.864 - | pr_cell p (PrfObj {cell = c, form = form,...}) =
139.865 - ((ints2str c) ^" "^ (term2str form) ^ "\n");
139.866 -*)
139.867 -
139.868 -(* convert ptree *)
139.869 -fun pr_ptree f pt =
139.870 - let
139.871 - fun pr_pt pfn _ EmptyPtree = ""
139.872 - | pr_pt pfn ps (Nd (b, [])) = pfn ps b
139.873 - | pr_pt pfn ps (Nd (b, ts)) = (pfn ps b)^
139.874 - (prts pfn (ps:pos) 1 ts)
139.875 - and prts pfn ps p [] = ""
139.876 - | prts pfn ps p (t::ts) = (pr_pt pfn (ps @ [p]) t)^
139.877 - (prts pfn ps (p+1) ts)
139.878 - in pr_pt f [] pt end;
139.879 -(*
139.880 -> fun prfn ps b = (pr_pos ps)^" "^b(*TODO*)^"\n";
139.881 -> val pt = ref EmptyPtree;
139.882 -> pt:=Nd("root",
139.883 - [Nd("xx1",[]),
139.884 - Nd("xx2",
139.885 - [Nd("xx2.1.",[]),
139.886 - Nd("xx2.2.",[])]),
139.887 - Nd("xx3",[])]);
139.888 -> writeln (pr_ptree prfn (!pt));
139.889 -*)
139.890 -
139.891 -
139.892 -(** access the branches of ptree **)
139.893 -
139.894 -fun ins_nth 1 e l = e::l
139.895 - | ins_nth n e [] = raise PTREE "ins_nth n e []"
139.896 - | ins_nth n e (l::ls) = l::(ins_nth (n-1) e ls);
139.897 -fun repl [] _ _ = raise PTREE "repl [] _ _"
139.898 - | repl (l::ls) 1 e = e::ls
139.899 - | repl (l::ls) n e = l::(repl ls (n-1) e);
139.900 -fun repl_app ls n e =
139.901 - let val lim = 1 + length ls
139.902 - in if n > lim then raise PTREE "repl_app: n > lim"
139.903 - else if n = lim then ls @ [e]
139.904 - else repl ls n e end;
139.905 -(*
139.906 -> repl [1,2,3] 2 22222;
139.907 -val it = [1,22222,3] : int list
139.908 -> repl_app [1,2,3,4] 5 5555;
139.909 -val it = [1,2,3,4,5555] : int list
139.910 -> repl_app [1,2,3] 2 22222;
139.911 -val it = [1,22222,3] : int list
139.912 -> repl_app [1] 2 22222 ;
139.913 -val it = [1,22222] : int list
139.914 -*)
139.915 -
139.916 -
139.917 -(*.get from obj at pos by f : ppobj -> 'a.*)
139.918 -fun get_obj f EmptyPtree (_:pos) = raise PTREE "get_obj f EmptyPtree"
139.919 - | get_obj f (Nd (b, _)) [] = f b
139.920 - | get_obj f (Nd (b, bs)) (p::ps) =
139.921 -(* val (f, Nd (b, bs), (p::ps)) = (I, pt, p);
139.922 - *)
139.923 - let val _ = (nth p bs) handle _ => raise PTREE ("get_obj: pos = "^
139.924 - (ints2str' (p::ps))^" does not exist");
139.925 - in (get_obj f (nth p bs) (ps:pos))
139.926 - (*before WN050419: 'wrong type..' raised also if pos doesn't exist*)
139.927 - handle _ => raise PTREE (*"get_obj: at pos = "^
139.928 - (ints2str' (p::ps))^" wrong type of ppobj"*)
139.929 - ("get_obj: pos = "^
139.930 - (ints2str' (p::ps))^" does not exist")
139.931 - end;
139.932 -fun get_nd EmptyPtree _ = raise PTREE "get_nd EmptyPtree"
139.933 - | get_nd n [] = n
139.934 - | get_nd (Nd (_,nds)) (pos as p::(ps:pos)) = (get_nd (nth p nds) ps)
139.935 - handle _ => raise PTREE ("get_nd: not existent pos = "^(ints2str' pos));
139.936 -
139.937 -
139.938 -(* for use by get_obj *)
139.939 -fun g_cell (PblObj {cell = c,...}) = NONE
139.940 - | g_cell (PrfObj {cell = c,...}) = c;(*WN0607 hack for quick introduction of lrd + rewrite-at (thms, calcs)*)
139.941 -fun g_form (PrfObj {form = f,...}) = f
139.942 - | g_form (PblObj {origin=(_,_,f),...}) = f;
139.943 -fun g_form' (Nd (PrfObj {form = f,...}, _)) = f
139.944 - | g_form' (Nd (PblObj {origin=(_,_,f),...}, _)) = f;
139.945 -(* | g_form _ = raise PTREE "g_form not for PblObj";*)
139.946 -fun g_origin (PblObj {origin = ori,...}) = ori
139.947 - | g_origin _ = raise PTREE "g_origin not for PrfObj";
139.948 -fun g_fmz (PblObj {fmz = f,...}) = f
139.949 - | g_fmz _ = raise PTREE "g_fmz not for PrfObj";
139.950 -fun g_spec (PblObj {spec = s,...}) = s
139.951 - | g_spec _ = raise PTREE "g_spec not for PrfObj";
139.952 -fun g_pbl (PblObj {probl = p,...}) = p
139.953 - | g_pbl _ = raise PTREE "g_pbl not for PrfObj";
139.954 -fun g_met (PblObj {meth = p,...}) = p
139.955 - | g_met _ = raise PTREE "g_met not for PrfObj";
139.956 -fun g_domID (PblObj {spec = (d,_,_),...}) = d
139.957 - | g_domID _ = raise PTREE "g_metID not for PrfObj";
139.958 -fun g_metID (PblObj {spec = (_,_,m),...}) = m
139.959 - | g_metID _ = raise PTREE "g_metID not for PrfObj";
139.960 -fun g_env (PblObj {env,...}) = env
139.961 - | g_env _ = raise PTREE "g_env not for PrfObj";
139.962 -fun g_loc (PblObj {loc = l,...}) = l
139.963 - | g_loc (PrfObj {loc = l,...}) = l;
139.964 -fun g_branch (PblObj {branch = b,...}) = b
139.965 - | g_branch (PrfObj {branch = b,...}) = b;
139.966 -fun g_tac (PblObj {spec = (d,p,m),...}) = Apply_Method m
139.967 - | g_tac (PrfObj {tac = m,...}) = m;
139.968 -fun g_result (PblObj {result = r,...}) = r
139.969 - | g_result (PrfObj {result = r,...}) = r;
139.970 -fun g_res (PblObj {result = (r,_),...}) = r
139.971 - | g_res (PrfObj {result = (r,_),...}) = r;
139.972 -fun g_res' (Nd (PblObj {result = (r,_),...}, _)) = r
139.973 - | g_res' (Nd (PrfObj {result = (r,_),...}, _)) = r;
139.974 -fun g_ostate (PblObj {ostate = r,...}) = r
139.975 - | g_ostate (PrfObj {ostate = r,...}) = r;
139.976 -fun g_ostate' (Nd (PblObj {ostate = r,...}, _)) = r
139.977 - | g_ostate' (Nd (PrfObj {ostate = r,...}, _)) = r;
139.978 -
139.979 -fun gpt_cell (Nd (PblObj {cell = c,...},_)) = NONE
139.980 - | gpt_cell (Nd (PrfObj {cell = c,...},_)) = c;
139.981 -
139.982 -(*in CalcTree/Subproblem an 'just_created_' model is created;
139.983 - this is filled to 'untouched' by Model/Refine_Problem*)
139.984 -fun just_created_ (PblObj {meth, probl, spec, ...}) =
139.985 - null meth andalso null probl andalso spec = e_spec;
139.986 -val e_origin = ([],e_spec,e_term): (ori list) * spec * term;
139.987 -
139.988 -fun just_created (pt,(p,_):pos') =
139.989 - let val ppobj = get_obj I pt p
139.990 - in is_pblobj ppobj andalso just_created_ ppobj end;
139.991 -
139.992 -(*.does the pos in the ctree exist ?.*)
139.993 -fun existpt pos pt = can (get_obj I pt) pos;
139.994 -(*.does the pos' in the ctree exist, ie. extra check for result in the node.*)
139.995 -fun existpt' ((p,p_):pos') pt =
139.996 - if can (get_obj I pt) p
139.997 - then case p_ of
139.998 - Res => get_obj g_ostate pt p = Complete
139.999 - | _ => true
139.1000 - else false;
139.1001 -
139.1002 -(*.is this position appropriate for calculating intermediate steps?.*)
139.1003 -fun is_interpos ((_, Res):pos') = true
139.1004 - | is_interpos _ = false;
139.1005 -
139.1006 -fun last_onlev pt pos = not (existpt (lev_on pos) pt);
139.1007 -
139.1008 -
139.1009 -(*.find the position of the next parent which is a PblObj in ptree.*)
139.1010 -fun par_pblobj pt ([]:pos) = ([]:pos)
139.1011 - | par_pblobj pt p =
139.1012 - let fun par pt [] = []
139.1013 - | par pt p = if is_pblobj (get_obj I pt p) then p
139.1014 - else par pt (lev_up p)
139.1015 - in par pt (lev_up p) end;
139.1016 -(* lev_up for hard_gen operating with pos = [...,0] *)
139.1017 -
139.1018 -(*.find the position and the children of the next parent which is a PblObj.*)
139.1019 -fun par_children (Nd (PblObj _, children)) ([]:pos) = (children, []:pos)
139.1020 - | par_children (pt as Nd (PblObj _, children)) p =
139.1021 - let fun par [] = (children, [])
139.1022 - | par p = let val Nd (obj, children) = get_nd pt p
139.1023 - in if is_pblobj obj then (children, p) else par (lev_up p)
139.1024 - end;
139.1025 - in par (lev_up p) end;
139.1026 -
139.1027 -(*.get the children of a node in ptree.*)
139.1028 -fun children (Nd (PblObj _, cn)) = cn
139.1029 - | children (Nd (PrfObj _, cn)) = cn;
139.1030 -
139.1031 -
139.1032 -(*.find the next parent, which is either a PblObj (return true)
139.1033 - or a PrfObj with tac = Detail_Set (return false).*)
139.1034 -(*FIXME.3.4.03:re-organize par_pbl_det after rls' --> rls*)
139.1035 -fun par_pbl_det pt ([]:pos) = (true, []:pos, Erls)
139.1036 - | par_pbl_det pt p =
139.1037 - let fun par pt [] = (true, [], Erls)
139.1038 - | par pt p = if is_pblobj (get_obj I pt p) then (true, p, Erls)
139.1039 - else case get_obj g_tac pt p of
139.1040 - (*Detail_Set rls' => (false, p, assoc_rls rls')
139.1041 - (*^^^--- before 040206 after ---vvv*)
139.1042 - |*)Rewrite_Set rls' => (false, p, assoc_rls rls')
139.1043 - | Rewrite_Set_Inst (_, rls') =>
139.1044 - (false, p, assoc_rls rls')
139.1045 - | _ => par pt (lev_up p)
139.1046 - in par pt (lev_up p) end;
139.1047 -
139.1048 -
139.1049 -
139.1050 -
139.1051 -(*.get from the whole ptree by f : ppobj -> 'a.*)
139.1052 -fun get_all f EmptyPtree = []
139.1053 - | get_all f (Nd (b, [])) = [f b]
139.1054 - | get_all f (Nd (b, bs)) = [f b] @ (get_alls f bs)
139.1055 -and get_alls f [] = []
139.1056 - | get_alls f pts = flat (map (get_all f) pts);
139.1057 -
139.1058 -
139.1059 -(*.insert obj b into ptree at pos, ev.overwriting this pos.*)
139.1060 -fun insert b EmptyPtree ([]:pos) = Nd (b, [])
139.1061 - | insert b EmptyPtree _ = raise PTREE "insert b Empty _"
139.1062 - | insert b (Nd ( _, _)) [] = raise PTREE "insert b _ []"
139.1063 - | insert b (Nd (b', bs)) (p::[]) =
139.1064 - Nd (b', repl_app bs p (Nd (b,[])))
139.1065 - | insert b (Nd (b', bs)) (p::ps) =
139.1066 - Nd (b', repl_app bs p (insert b (nth p bs) ps));
139.1067 -(*
139.1068 -> type ppobj = string;
139.1069 -> writeln (pr_ptree prfn (!pt));
139.1070 - val pt = ref Empty;
139.1071 - pt:= insert ("root":ppobj) EmptyPtree [];
139.1072 - pt:= insert ("xx1":ppobj) (!pt) [1];
139.1073 - pt:= insert ("xx2":ppobj) (!pt) [2];
139.1074 - pt:= insert ("xx3":ppobj) (!pt) [3];
139.1075 - pt:= insert ("xx2.1":ppobj) (!pt) [2,1];
139.1076 - pt:= insert ("xx2.2":ppobj) (!pt) [2,2];
139.1077 - pt:= insert ("xx2.1.1":ppobj) (!pt) [2,1,1];
139.1078 - pt:= insert ("xx2.1.2":ppobj) (!pt) [2,1,2];
139.1079 - pt:= insert ("xx2.1.3":ppobj) (!pt) [2,1,3];
139.1080 -*)
139.1081 -
139.1082 -(*.insert children to a node without children.*)
139.1083 -(*compare: fun insert*)
139.1084 -fun ins_chn _ EmptyPtree (_:pos) = raise PTREE "ins_chn: EmptyPtree"
139.1085 - | ins_chn ns (Nd _) [] = raise PTREE "ins_chn: pos = []"
139.1086 - | ins_chn ns (Nd (b, bs)) (p::[]) =
139.1087 - if p > length bs then raise PTREE "ins_chn: pos not existent"
139.1088 - else let val Nd (b', bs') = nth p bs
139.1089 - in if null bs' then Nd (b, repl_app bs p (Nd (b', ns)))
139.1090 - else raise PTREE "ins_chn: pos mustNOT be overwritten" end
139.1091 - | ins_chn ns (Nd (b, bs)) (p::ps) =
139.1092 - Nd (b, repl_app bs p (ins_chn ns (nth p bs) ps));
139.1093 -
139.1094 -(* print_depth 11;ins_chn;print_depth 3; ###insert#########################*);
139.1095 -
139.1096 -
139.1097 -(** apply f to obj at pos, f: ppobj -> ppobj **)
139.1098 -
139.1099 -fun appl_to_node f (Nd (b,bs)) = Nd (f b, bs);
139.1100 -fun appl_obj f EmptyPtree [] = EmptyPtree
139.1101 - | appl_obj f EmptyPtree _ = raise PTREE "appl_obj f Empty _"
139.1102 - | appl_obj f (Nd (b, bs)) [] = Nd (f b, bs)
139.1103 - | appl_obj f (Nd (b, bs)) (p::[]) =
139.1104 - Nd (b, repl_app bs p (((appl_to_node f) o (nth p)) bs))
139.1105 - | appl_obj f (Nd (b, bs)) (p::ps) =
139.1106 - Nd (b, repl_app bs p (appl_obj f (nth p bs) (ps:pos)));
139.1107 -
139.1108 -(* for use by appl_obj *)
139.1109 -fun repl_form f (PrfObj {cell=c,form= _,tac=tac,loc=loc,
139.1110 - branch=branch,result=result,ostate=ostate}) =
139.1111 - PrfObj {cell=c,form= f,tac=tac,loc=loc,
139.1112 - branch=branch,result=result,ostate=ostate}
139.1113 - | repl_form _ _ = raise PTREE "repl_form takes no PblObj";
139.1114 -fun repl_pbl x (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1115 - spec=spec,probl=_,meth=meth,env=env,loc=loc,
139.1116 - branch=branch,result=result,ostate=ostate}) =
139.1117 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl= x,
139.1118 - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
139.1119 - | repl_pbl _ _ = raise PTREE "repl_pbl takes no PrfObj";
139.1120 -fun repl_met x (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1121 - spec=spec,probl=probl,meth=_,env=env,loc=loc,
139.1122 - branch=branch,result=result,ostate=ostate}) =
139.1123 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
139.1124 - meth= x,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
139.1125 - | repl_met _ _ = raise PTREE "repl_pbl takes no PrfObj";
139.1126 -
139.1127 -fun repl_spec x (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1128 - spec= _,probl=probl,meth=meth,env=env,loc=loc,
139.1129 - branch=branch,result=result,ostate=ostate}) =
139.1130 - PblObj {cell=cell,origin=origin,fmz=fmz,spec= x,probl=probl,
139.1131 - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
139.1132 - | repl_spec _ _ = raise PTREE "repl_domID takes no PrfObj";
139.1133 -fun repl_domID x (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1134 - spec=(_,p,m),probl=probl,meth=meth,env=env,loc=loc,
139.1135 - branch=branch,result=result,ostate=ostate}) =
139.1136 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=(x,p,m),probl=probl,
139.1137 - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
139.1138 - | repl_domID _ _ = raise PTREE "repl_domID takes no PrfObj";
139.1139 -fun repl_pblID x (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1140 - spec=(d,_,m),probl=probl,meth=meth,env=env,loc=loc,
139.1141 - branch=branch,result=result,ostate=ostate}) =
139.1142 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,x,m),probl=probl,
139.1143 - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
139.1144 - | repl_pblID _ _ = raise PTREE "repl_pblID takes no PrfObj";
139.1145 -fun repl_metID x (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1146 - spec=(d,p,_),probl=probl,meth=meth,env=env,loc=loc,
139.1147 - branch=branch,result=result,ostate=ostate}) =
139.1148 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=(d,p,x),probl=probl,
139.1149 - meth=meth,env=env,loc=loc,branch=branch,result=result,ostate=ostate}
139.1150 - | repl_metID _ _ = raise PTREE "repl_metID takes no PrfObj";
139.1151 -
139.1152 -fun repl_result l f' s (PrfObj {cell=cell,form=form,tac=tac,loc=_,
139.1153 - branch=branch,result = _ ,ostate = _}) =
139.1154 - PrfObj {cell=cell,form=form,tac=tac,loc= l,
139.1155 - branch=branch,result = f',ostate = s}
139.1156 - | repl_result l f' s (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1157 - spec=spec,probl=probl,meth=meth,env=env,loc=_,
139.1158 - branch=branch,result= _ ,ostate= _}) =
139.1159 - PblObj {cell=cell,origin=origin,fmz=fmz,
139.1160 - spec=spec,probl=probl,meth=meth,env=env,loc= l,
139.1161 - branch=branch,result= f',ostate= s};
139.1162 -
139.1163 -fun repl_tac x (PrfObj {cell=cell,form=form,tac= _,loc=loc,
139.1164 - branch=branch,result=result,ostate=ostate}) =
139.1165 - PrfObj {cell=cell,form=form,tac= x,loc=loc,
139.1166 - branch=branch,result=result,ostate=ostate}
139.1167 - | repl_tac _ _ = raise PTREE "repl_tac takes no PblObj";
139.1168 -
139.1169 -fun repl_branch b (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1170 - spec=spec,probl=probl,meth=meth,env=env,loc=loc,
139.1171 - branch= _,result=result,ostate=ostate}) =
139.1172 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
139.1173 - meth=meth,env=env,loc=loc,branch= b,result=result,ostate=ostate}
139.1174 - | repl_branch b (PrfObj {cell=cell,form=form,tac=tac,loc=loc,
139.1175 - branch= _,result=result,ostate=ostate}) =
139.1176 - PrfObj {cell=cell,form=form,tac=tac,loc=loc,
139.1177 - branch= b,result=result,ostate=ostate};
139.1178 -
139.1179 -fun repl_env e
139.1180 - (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1181 - spec=spec,probl=probl,meth=meth,env=_,loc=loc,
139.1182 - branch=branch,result=result,ostate=ostate}) =
139.1183 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
139.1184 - meth=meth,env=e,loc=loc,branch=branch,
139.1185 - result=result,ostate=ostate}
139.1186 - | repl_env _ _ = raise PTREE "repl_ets takes no PrfObj";
139.1187 -
139.1188 -fun repl_oris oris
139.1189 - (PblObj {cell=cell,origin=(_,spe,hdf),fmz=fmz,
139.1190 - spec=spec,probl=probl,meth=meth,env=env,loc=loc,
139.1191 - branch=branch,result=result,ostate=ostate}) =
139.1192 - PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl,
139.1193 - meth=meth,env=env,loc=loc,branch=branch,
139.1194 - result=result,ostate=ostate}
139.1195 - | repl_oris _ _ = raise PTREE "repl_oris takes no PrfObj";
139.1196 -fun repl_orispec spe
139.1197 - (PblObj {cell=cell,origin=(oris,_,hdf),fmz=fmz,
139.1198 - spec=spec,probl=probl,meth=meth,env=env,loc=loc,
139.1199 - branch=branch,result=result,ostate=ostate}) =
139.1200 - PblObj{cell=cell,origin=(oris,spe,hdf),fmz=fmz,spec=spec,probl=probl,
139.1201 - meth=meth,env=env,loc=loc,branch=branch,
139.1202 - result=result,ostate=ostate}
139.1203 - | repl_orispec _ _ = raise PTREE "repl_orispec takes no PrfObj";
139.1204 -
139.1205 -fun repl_loc l (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1206 - spec=spec,probl=probl,meth=meth,env=env,loc=_,
139.1207 - branch=branch,result=result,ostate=ostate}) =
139.1208 - PblObj {cell=cell,origin=origin,fmz=fmz,spec=spec,probl=probl,
139.1209 - meth=meth,env=env,loc=l,branch=branch,result=result,ostate=ostate}
139.1210 - | repl_loc l (PrfObj {cell=cell,form=form,tac=tac,loc=_,
139.1211 - branch=branch,result=result,ostate=ostate}) =
139.1212 - PrfObj {cell=cell,form=form,tac=tac,loc= l,
139.1213 - branch=branch,result=result,ostate=ostate};
139.1214 -(*
139.1215 -fun uni__cid cell'
139.1216 - (PblObj {cell=cell,origin=origin,fmz=fmz,
139.1217 - spec=spec,probl=probl,meth=meth,env=env,loc=loc,
139.1218 - branch=branch,result=result,ostate=ostate}) =
139.1219 - PblObj {cell=cell union cell',origin=origin,fmz=fmz,spec=spec,probl=probl,
139.1220 - meth=meth,env=env,loc=loc,branch=branch,
139.1221 - result=result,ostate=ostate}
139.1222 - | uni__cid cell'
139.1223 - (PrfObj {cell=cell,form=form,tac=tac,loc=loc,
139.1224 - branch=branch,result=result,ostate=ostate}) =
139.1225 - PrfObj {cell=cell union cell',form=form,tac=tac,loc=loc,
139.1226 - branch=branch,result=result,ostate=ostate};
139.1227 -*)
139.1228 -
139.1229 -(*WN050219 put here for interpreting code for cut_tree below...*)
139.1230 -type ocalhd =
139.1231 - bool * (*ALL itms+preconds true*)
139.1232 - pos_ * (*model belongs to Problem | Method*)
139.1233 - term * (*header: Problem... or Cas
139.1234 - FIXXXME.12.03: item! for marking syntaxerrors*)
139.1235 - itm list * (*model: given, find, relate*)
139.1236 - ((bool * term) list) *(*model: preconds*)
139.1237 - spec; (*specification*)
139.1238 -val e_ocalhd = (false, Und, e_term, [e_itm], [(false, e_term)], e_spec);
139.1239 -
139.1240 -datatype ptform =
139.1241 - Form of term
139.1242 - | ModSpec of ocalhd;
139.1243 -val e_ptform = Form e_term;
139.1244 -val e_ptform' = ModSpec e_ocalhd;
139.1245 -
139.1246 -
139.1247 -
139.1248 -(*.applies (snd f) to the branches at a pos if ((fst f) b),
139.1249 - f : (ppobj -> bool) * (int -> ptree list -> ptree list).*)
139.1250 -
139.1251 -fun appl_branch f EmptyPtree [] = (EmptyPtree, false)
139.1252 - | appl_branch f EmptyPtree _ = raise PTREE "appl_branch f Empty _"
139.1253 - | appl_branch f (Nd ( _, _)) [] = raise PTREE "appl_branch f _ []"
139.1254 - | appl_branch f (Nd (b, bs)) (p::[]) =
139.1255 - if (fst f) b then (Nd (b, (snd f) (p:posel) bs), true)
139.1256 - else (Nd (b, bs), false)
139.1257 - | appl_branch f (Nd (b, bs)) (p::ps) =
139.1258 - let val (b',bool) = appl_branch f (nth p bs) ps
139.1259 - in (Nd (b, repl_app bs p b'), bool) end;
139.1260 -
139.1261 -(* for cut_level; appl_branch(deprecated) *)
139.1262 -fun test_trans (PrfObj{branch = Transitive,...}) = true
139.1263 - | test_trans (PblObj{branch = Transitive,...}) = true
139.1264 - | test_trans _ = false;
139.1265 -
139.1266 -fun is_pblobj' pt (p:pos) =
139.1267 - let val ppobj = get_obj I pt p
139.1268 - in is_pblobj ppobj end;
139.1269 -
139.1270 -
139.1271 -fun delete_result pt (p:pos) =
139.1272 - (appl_obj (repl_result (fst (get_obj g_loc pt p), NONE)
139.1273 - (e_term,[]) Incomplete) pt p);
139.1274 -
139.1275 -fun del_res (PblObj {cell, fmz, origin, spec, probl, meth,
139.1276 - env, loc=(l1,_), branch, result, ostate}) =
139.1277 - PblObj {cell=cell,fmz=fmz,origin=origin,spec=spec,probl=probl,meth=meth,
139.1278 - env=env, loc=(l1,NONE), branch=branch, result=(e_term,[]),
139.1279 - ostate=Incomplete}
139.1280 -
139.1281 - | del_res (PrfObj {cell, form, tac, loc=(l1,_), branch, result, ostate}) =
139.1282 - PrfObj {cell=cell,form=form,tac=tac, loc=(l1,NONE), branch=branch,
139.1283 - result=(e_term,[]), ostate=Incomplete};
139.1284 -
139.1285 -
139.1286 -(*
139.1287 -fun update_fmz pt pos x = appl_obj (repl_fmz x) pt pos;
139.1288 - 1.00 not used anymore*)
139.1289 -
139.1290 -(*FIXME.WN.12.03: update_X X pos pt -> pt could be chained by o (efficiency?)*)
139.1291 -fun update_env pt pos x = appl_obj (repl_env x) pt pos;
139.1292 -fun update_domID pt pos x = appl_obj (repl_domID x) pt pos;
139.1293 -fun update_pblID pt pos x = appl_obj (repl_pblID x) pt pos;
139.1294 -fun update_metID pt pos x = appl_obj (repl_metID x) pt pos;
139.1295 -fun update_spec pt pos x = appl_obj (repl_spec x) pt pos;
139.1296 -
139.1297 -fun update_pbl pt pos x = appl_obj (repl_pbl x) pt pos;
139.1298 -fun update_pblppc pt pos x = appl_obj (repl_pbl x) pt pos;
139.1299 -
139.1300 -fun update_met pt pos x = appl_obj (repl_met x) pt pos;
139.1301 -(*1.09.01 ----
139.1302 -fun update_metppc pt pos x =
139.1303 - let val {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,...} =
139.1304 - get_obj g_met pt pos
139.1305 - in appl_obj (repl_met
139.1306 - {rew_ord'=od,rls'=rs,asm_thm=at,asm_rls=ar,ppc=x})
139.1307 - pt pos end;*)
139.1308 -fun update_metppc pt pos x = appl_obj (repl_met x) pt pos;
139.1309 -
139.1310 -(*fun union_cid pt pos x = appl_obj (uni__cid x) pt pos;*)
139.1311 -
139.1312 -fun update_branch pt pos x = appl_obj (repl_branch x) pt pos;
139.1313 -fun update_tac pt pos x = appl_obj (repl_tac x) pt pos;
139.1314 -
139.1315 -fun update_oris pt pos x = appl_obj (repl_oris x) pt pos;
139.1316 -fun update_orispec pt pos x = appl_obj (repl_orispec x) pt pos;
139.1317 -
139.1318 - (*done by append_* !! 3.5.02; ununsed WN050305 thus outcommented
139.1319 -fun update_loc pt (p,_) (ScrState ([],[],NONE,
139.1320 - Const ("empty",_),Sundef,false)) =
139.1321 - appl_obj (repl_loc (NONE,NONE)) pt p
139.1322 - | update_loc pt (p,Res) x =
139.1323 - let val (lform,_) = get_obj g_loc pt p
139.1324 - in appl_obj (repl_loc (lform,SOME x)) pt p end
139.1325 -
139.1326 - | update_loc pt (p,_) x =
139.1327 - let val (_,lres) = get_obj g_loc pt p
139.1328 - in appl_obj (repl_loc (SOME x,lres)) pt p end;-------------*)
139.1329 -
139.1330 -(*WN050305 for handling cut_tree in cappend_atomic -- TODO redesign !*)
139.1331 -fun update_loc' pt p iss = appl_obj (repl_loc iss) pt p;
139.1332 -
139.1333 -(*13.8.02---------------------------
139.1334 -fun get_loc EmptyPtree _ = NONE
139.1335 - | get_loc pt (p,Res) =
139.1336 - let val (lfrm,lres) = get_obj g_loc pt p
139.1337 - in if lres = e_istate then lfrm else lres end
139.1338 - | get_loc pt (p,_) =
139.1339 - let val (lfrm,lres) = get_obj g_loc pt p
139.1340 - in if lfrm = e_istate then lres else lfrm end; 5.10.00: too liberal ?*)
139.1341 -(*13.8.02: options, because istate is no equalitype any more*)
139.1342 -fun get_loc EmptyPtree _ = e_istate
139.1343 - | get_loc pt (p,Res) =
139.1344 - (case get_obj g_loc pt p of
139.1345 - (SOME i, NONE) => i
139.1346 - | (NONE , NONE) => e_istate
139.1347 - | (_ , SOME i) => i)
139.1348 - | get_loc pt (p,_) =
139.1349 - (case get_obj g_loc pt p of
139.1350 - (NONE , SOME i) => i (*13.8.02 just copied from ^^^: too liberal ?*)
139.1351 - | (NONE , NONE) => e_istate
139.1352 - | (SOME i, _) => i);
139.1353 -val get_istate = get_loc; (*3.5.02*)
139.1354 -
139.1355 -(*.collect the assumptions within a problem up to a certain position.*)
139.1356 -type asms = (term * pos) list;(*WN0502 should be (pos' * term) list
139.1357 - ...........===^===*)
139.1358 -
139.1359 -fun get_asm (b:pos, p:pos) (Nd (PblObj {result=(_,asm),...},_)) =
139.1360 - ((*writeln ("### get_asm PblObj:(b,p)= "^
139.1361 - (pair2str(ints2str b, ints2str p)));*)
139.1362 - (map (rpair b) asm):asms)
139.1363 - | get_asm (b, p) (Nd (PrfObj {result=(_,asm),...}, [])) =
139.1364 - ((*writeln ("### get_asm PrfObj []:(b,p)= "^
139.1365 - (pair2str(ints2str b, ints2str p)));*)
139.1366 - (map (rpair b) asm))
139.1367 - | get_asm (b, p:pos) (Nd (PrfObj _, nds)) =
139.1368 - let (*val _= writeln ("### get_asm PrfObj nds:(b,p)= "^
139.1369 - (pair2str(ints2str b, ints2str p)));*)
139.1370 - val levdn =
139.1371 - if p <> [] then (b @ [hd p]:pos, tl p:pos)
139.1372 - else (b @ [1], [99999]) (*_deeper_ nesting is always _before_ p*)
139.1373 - in gets_asm levdn 1 nds end
139.1374 -and gets_asm _ _ [] = []
139.1375 - | gets_asm (b, p' as p::ps) i (nd::nds) =
139.1376 - if p < i then []
139.1377 - else ((*writeln ("### gets_asm: (b,p')= "^(pair2str(ints2str b,
139.1378 - ints2str p')));*)
139.1379 - (get_asm (b @ [i], ps) nd) @ (gets_asm (b, p') (i + 1) nds));
139.1380 -
139.1381 -fun get_assumptions_ (Nd (PblObj {result=(r,asm),...}, cn)) (([], _):pos') =
139.1382 - if r = e_term then gets_asm ([], [99999]) 1 cn
139.1383 - else map (rpair []) asm
139.1384 - | get_assumptions_ pt (p,p_) =
139.1385 - let val (cn, base) = par_children pt p
139.1386 - val offset = drop (length base, p)
139.1387 - val base' = replicate (length base) 1
139.1388 - val offset' = case p_ of
139.1389 - Frm => let val (qs,q) = split_last offset
139.1390 - in qs @ [q - 1] end
139.1391 - | _ => offset
139.1392 - (*val _= writeln ("... get_assumptions: (b,o)= "^
139.1393 - (pair2str(ints2str base',ints2str offset)))*)
139.1394 - in gets_asm (base', offset) 1 cn end;
139.1395 -
139.1396 -
139.1397 -(*---------
139.1398 -end
139.1399 -
139.1400 -open Ptree;
139.1401 -----------*)
139.1402 -
139.1403 -(*pos of the formula on FE relative to the current pos,
139.1404 - which is the next writepos*)
139.1405 -fun pre_pos ([]:pos) = []:pos
139.1406 - | pre_pos pp =
139.1407 - let val (ps,p) = split_last pp
139.1408 - in case p of 1 => ps | n => ps @ [n-1] end;
139.1409 -
139.1410 -(*WN.20.5.03 ... but not used*)
139.1411 -fun posless [] (_::_) = true
139.1412 - | posless (_::_) [] = false
139.1413 - | posless (p::ps) (q::qs) = if p = q then posless ps qs else p < q;
139.1414 -(* posless [2,3,4] [3,4,5];
139.1415 -true
139.1416 -> posless [2,3,4] [1,2,3];
139.1417 -false
139.1418 -> posless [2,3] [2,3,4];
139.1419 -true
139.1420 -> posless [2,3,4] [2,3];
139.1421 -false
139.1422 -> posless [6] [6,5,2];
139.1423 -true
139.1424 -+++ see Isabelle/../library.ML*)
139.1425 -
139.1426 -
139.1427 -(**.development for extracting an 'interval' from ptree.**)
139.1428 -
139.1429 -(*version 1 stopped 8.03 in favour of get_interval with !!!move_dn
139.1430 - actually used (inefficient) version with move_dn: see modspec.sml*)
139.1431 -local
139.1432 -
139.1433 -fun hdp [] = 1 | hdp [0] = 1 | hdp x = hd x;(*start with first*)
139.1434 -fun hdq [] = 99999 | hdq [0] = 99999 | hdq x = hd x;(*take until last*)
139.1435 -fun tlp [] = [0] | tlp [_] = [0] | tlp x = tl x;
139.1436 -fun tlq [] = [99999] | tlq [_] = [99999] | tlq x = tl x;
139.1437 -
139.1438 -fun getnd i (b,p) q (Nd (po, nds)) =
139.1439 - (if i <= 0 then [[b]] else []) @
139.1440 - (getnds (i-1) true (b@[hdp p], tlp p) (tlq q)
139.1441 - (take_fromto (hdp p) (hdq q) nds))
139.1442 -
139.1443 -and getnds _ _ _ _ [] = [] (*no children*)
139.1444 - | getnds i _ (b,p) q [nd] = (getnd i (b,p) q nd) (*l+r-margin*)
139.1445 -
139.1446 - | getnds i true (b,p) q [n1, n2] = (*l-margin, r-margin*)
139.1447 - (getnd i ( b, p ) [99999] n1) @
139.1448 - (getnd ~99999 (lev_on b,[0]) q n2)
139.1449 -
139.1450 - | getnds i _ (b,p) q [n1, n2] = (*intern, r-margin*)
139.1451 - (getnd i ( b,[0]) [99999] n1) @
139.1452 - (getnd ~99999 (lev_on b,[0]) q n2)
139.1453 -
139.1454 - | getnds i true (b,p) q (nd::(nds as _::_)) = (*l-margin, intern*)
139.1455 - (getnd i ( b, p ) [99999] nd) @
139.1456 - (getnds ~99999 false (lev_on b,[0]) q nds)
139.1457 -
139.1458 - | getnds i _ (b,p) q (nd::(nds as _::_)) = (*intern, ...*)
139.1459 - (getnd i ( b,[0]) [99999] nd) @
139.1460 - (getnds ~99999 false (lev_on b,[0]) q nds);
139.1461 -in
139.1462 -(*get an 'interval from to' from a ptree as 'intervals f t' of respective nodes
139.1463 - where 'from' are pos, i.e. a key as int list, 'f' an int (to,t analoguous)
139.1464 -(1) the 'f' are given
139.1465 -(1a) by 'from' if 'f' = the respective element of 'from' (left margin)
139.1466 -(1b) -inifinity, if 'f' > the respective element of 'from' (internal node)
139.1467 -(2) the 't' ar given
139.1468 -(2a) by 'to' if 't' = the respective element of 'to' (right margin)
139.1469 -(2b) inifinity, if 't' < the respective element of 'to (internal node)'
139.1470 -the 'f' and 't' are set by hdp,... *)
139.1471 -fun get_trace pt p q =
139.1472 - (flat o (getnds ((length p) -1) true ([hdp p], tlp p) (tlq q)))
139.1473 - (take_fromto (hdp p) (hdq q) (children pt));
139.1474 -end;
139.1475 -(*WN0510 stoppde this development;
139.1476 - actually used (inefficient) version with move_dn: getFormulaeFromTo*)
139.1477 -
139.1478 -
139.1479 -
139.1480 -
139.1481 -fun get_somespec ((dI,pI,mI):spec) ((dI',pI',mI'):spec) =
139.1482 - let val domID = if dI = e_domID
139.1483 - then if dI' = e_domID
139.1484 - then raise error"pt_extract: no domID in probl,origin"
139.1485 - else dI'
139.1486 - else dI
139.1487 - val pblID = if pI = e_pblID
139.1488 - then if pI' = e_pblID
139.1489 - then raise error"pt_extract: no pblID in probl,origin"
139.1490 - else pI'
139.1491 - else pI
139.1492 - val metID = if mI = e_metID
139.1493 - then if pI' = e_metID
139.1494 - then raise error"pt_extract: no metID in probl,origin"
139.1495 - else mI'
139.1496 - else mI
139.1497 - in (domID, pblID, metID):spec end;
139.1498 -fun get_somespec' ((dI,pI,mI):spec) ((dI',pI',mI'):spec) =
139.1499 - let val domID = if dI = e_domID then dI' else dI
139.1500 - val pblID = if pI = e_pblID then pI' else pI
139.1501 - val metID = if mI = e_metID then mI' else mI
139.1502 - in (domID, pblID, metID):spec end;
139.1503 -
139.1504 -(*extract a formula or model from ptree for itms2itemppc or model2xml*)
139.1505 -fun preconds2str bts =
139.1506 - (strs2str o (map (linefeed o pair2str o
139.1507 - (apsnd term2str) o
139.1508 - (apfst bool2str)))) bts;
139.1509 -fun ocalhd2str ((b, p, hdf, itms, prec, spec):ocalhd) =
139.1510 - "("^bool2str b^", "^pos_2str p^", "^term2str hdf^
139.1511 - ", "^itms2str_ (thy2ctxt' "Isac") itms^
139.1512 - ", "^preconds2str prec^", \n"^spec2str spec^" )";
139.1513 -
139.1514 -
139.1515 -
139.1516 -fun is_pblnd (Nd (ppobj, _)) = is_pblobj ppobj;
139.1517 -
139.1518 -
139.1519 -(**.functions for the 'ptree iterator' as seen from the FE-Kernel interface.**)
139.1520 -
139.1521 -(*move one step down into existing nodes of ptree; regard TransitiveB
139.1522 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~##################
139.1523 -fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*)
139.1524 -(* val (Nd (c, ns), ([],p_)) = (pt, get_pos cI uI);
139.1525 - *)
139.1526 - if is_pblobj c
139.1527 - then case p_ of (*Frm => ([], Pbl) 1.12.03
139.1528 - |*) Res => raise PTREE "move_dn: end of calculation"
139.1529 - | _ => if null ns (*go down from Pbl + Met*)
139.1530 - then raise PTREE "move_dn: solve problem not started"
139.1531 - else ([1], Frm)
139.1532 - else (case p_ of Res => raise PTREE "move_dn: end of (sub-)tree"
139.1533 - | _ => if null ns
139.1534 - then raise PTREE "move_dn: pos not existent 1"
139.1535 - else ([1], Frm))
139.1536 -
139.1537 - (*iterate towards end of pos*)
139.1538 -(* val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ([]:pos, pt, get_pos cI uI);
139.1539 - val (P,(Nd (_, ns)),(p::(ps as (_::_)),p_)) = ((P@[p]),(nth p ns),(ps, p_));
139.1540 - *)
139.1541 - | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
139.1542 - if p > length ns then raise PTREE "move_dn: pos not existent 2"
139.1543 - else move_dn ((P@[p]): pos) (nth p ns) (ps, p_)
139.1544 -(* val (P, (Nd (c, ns)), ([p], p_)) = ((P@[p]), (nth p ns), (ps, p_));
139.1545 - val (P, (Nd (c, ns)), ([p], p_)) = ([],pt,get_pos cI uI);
139.1546 - *)
139.1547 - | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
139.1548 - if p > length ns then raise PTREE "move_dn: pos not existent 3"
139.1549 - else if is_pblnd (nth p ns) then
139.1550 - ((*writeln("### move_dn: is_pblnd (nth p ns), P= "^ints2str' P^", \n"^
139.1551 - "length ns= "^((string_of_int o length) ns)^
139.1552 - ", p= "^string_of_int p^", p_= "^pos_2str p_);*)
139.1553 - case p_ of Res => if p = length ns
139.1554 - then if g_ostate c = Complete then (P, Res)
139.1555 - else raise PTREE (ints2str' P^" not complete")
139.1556 - (*FIXME here handle not-sequent-branches*)
139.1557 - else if g_branch c = TransitiveB
139.1558 - andalso (not o is_pblnd o (nth (p+1))) ns
139.1559 - then (P@[p+1], Res)
139.1560 - else (P@[p+1], if is_pblnd (nth (p+1) ns)
139.1561 - then Pbl else Frm)
139.1562 - | _ => if (null o children o (nth p)) ns (*go down from Pbl*)
139.1563 - then raise PTREE "move_dn: solve subproblem not started"
139.1564 - else (P @ [p, 1],
139.1565 - if (is_pblnd o hd o children o (nth p)) ns
139.1566 - then Pbl else Frm)
139.1567 - )
139.1568 - (* val (P, Nd (c, ns), ([p], p_)) = ([], pt, ([1], Frm));
139.1569 - *)
139.1570 - else case p_ of Frm => if (null o children o (nth p)) ns
139.1571 - (*then if g_ostate c = Complete then (P@[p],Res)*)
139.1572 - then if g_ostate' (nth p ns) = Complete
139.1573 - then (P@[p],Res)
139.1574 - else raise PTREE "move_dn: pos not existent 4"
139.1575 - else (P @ [p, 1], (*go down*)
139.1576 - if (is_pblnd o hd o children o (nth p)) ns
139.1577 - then Pbl else Frm)
139.1578 - | Res => if p = length ns
139.1579 - then
139.1580 - if g_ostate c = Complete then (P, Res)
139.1581 - else raise PTREE (ints2str' P^" not complete")
139.1582 - else
139.1583 - if g_branch c = TransitiveB
139.1584 - andalso (not o is_pblnd o (nth (p+1))) ns
139.1585 - then if (null o children o (nth (p+1))) ns
139.1586 - then (P@[p+1], Res)
139.1587 - else (P@[p+1,1], Frm)(*040221*)
139.1588 - else (P@[p+1], if is_pblnd (nth (p+1) ns)
139.1589 - then Pbl else Frm);
139.1590 -*)
139.1591 -(*.move one step down into existing nodes of ptree; skip Res = Frm.nxt;
139.1592 - move_dn at the end of the calc-tree raises PTREE.*)
139.1593 -fun move_dn _ (Nd (c, ns)) ([],p_) = (*root problem*)
139.1594 - (case p_ of
139.1595 - Res => raise PTREE "move_dn: end of calculation"
139.1596 - | _ => if null ns (*go down from Pbl + Met*)
139.1597 - then raise PTREE "move_dn: solve problem not started"
139.1598 - else ([1], Frm))
139.1599 - | move_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =(*iterate to end of pos*)
139.1600 - if p > length ns then raise PTREE "move_dn: pos not existent 2"
139.1601 - else move_dn ((P@[p]): pos) (nth p ns) (ps, p_)
139.1602 -
139.1603 - | move_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
139.1604 - if p > length ns then raise PTREE "move_dn: pos not existent 3"
139.1605 - else case p_ of
139.1606 - Res =>
139.1607 - if p = length ns (*last Res on this level: go a level up*)
139.1608 - then if g_ostate c = Complete then (P, Res)
139.1609 - else raise PTREE (ints2str' P^" not complete 1")
139.1610 - else (*go to the next Nd on this level, or down into the next Nd*)
139.1611 - if is_pblnd (nth (p+1) ns) then (P@[p+1], Pbl)
139.1612 - else
139.1613 - if g_res' (nth p ns) = g_form' (nth (p+1) ns)
139.1614 - then if (null o children o (nth (p+1))) ns
139.1615 - then (*take the Res if Complete*)
139.1616 - if g_ostate' (nth (p+1) ns) = Complete
139.1617 - then (P@[p+1], Res)
139.1618 - else raise PTREE (ints2str' (P@[p+1])^
139.1619 - " not complete 2")
139.1620 - else (P@[p+1,1], Frm)(*go down into the next PrfObj*)
139.1621 - else (P@[p+1], Frm)(*take Frm: exists if the Nd exists*)
139.1622 - | Frm => (*go down or to the Res of this Nd*)
139.1623 - if (null o children o (nth p)) ns
139.1624 - then if g_ostate' (nth p ns) = Complete then (P @ [p], Res)
139.1625 - else raise PTREE (ints2str' (P @ [p])^" not complete 3")
139.1626 - else (P @ [p, 1], Frm)
139.1627 - | _ => (*is Pbl or Met*)
139.1628 - if (null o children o (nth p)) ns
139.1629 - then raise PTREE "move_dn:solve subproblem not startd"
139.1630 - else (P @ [p, 1],
139.1631 - if (is_pblnd o hd o children o (nth p)) ns
139.1632 - then Pbl else Frm);
139.1633 -
139.1634 -
139.1635 -(*.go one level down into ptree.*)
139.1636 -fun movelevel_dn [] (Nd (c, ns)) ([],p_) = (*root problem*)
139.1637 - if is_pblobj c
139.1638 - then if null ns
139.1639 - then raise PTREE "solve problem not started"
139.1640 - else ([1], if (is_pblnd o hd) ns then Pbl else Frm)
139.1641 - else raise PTREE "pos not existent 1"
139.1642 -
139.1643 - (*iterate towards end of pos*)
139.1644 - | movelevel_dn P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
139.1645 - if p > length ns then raise PTREE "pos not existent 2"
139.1646 - else movelevel_dn (P@[p]) (nth p ns) (ps, p_)
139.1647 -
139.1648 - | movelevel_dn P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
139.1649 - if p > length ns then raise PTREE "pos not existent 3" else
139.1650 - case p_ of Res =>
139.1651 - if p = length ns
139.1652 - then raise PTREE "no children"
139.1653 - else
139.1654 - if g_branch c = TransitiveB
139.1655 - then if (null o children o (nth (p+1))) ns
139.1656 - then raise PTREE "no children"
139.1657 - else (P @ [p+1, 1],
139.1658 - if (is_pblnd o hd o children o (nth (p+1))) ns
139.1659 - then Pbl else Frm)
139.1660 - else if (null o children o (nth p)) ns
139.1661 - then raise PTREE "no children"
139.1662 - else (P @ [p, 1], if (is_pblnd o hd o children o (nth p)) ns
139.1663 - then Pbl else Frm)
139.1664 - | _ => if (null o children o (nth p)) ns
139.1665 - then raise PTREE "no children"
139.1666 - else (P @ [p, 1], (*go down*)
139.1667 - if (is_pblnd o hd o children o (nth p)) ns
139.1668 - then Pbl else Frm);
139.1669 -
139.1670 -
139.1671 -
139.1672 -(*.go to the previous position in ptree; regard TransitiveB.*)
139.1673 -fun move_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*)
139.1674 - if is_pblobj c
139.1675 - then case p_ of Res => if null ns then ([], Pbl) (*Res -> Pbl (not Met)!*)
139.1676 - else ([length ns], Res)
139.1677 - | _ => raise PTREE "begin of calculation"
139.1678 - else raise PTREE "pos not existent"
139.1679 -
139.1680 - | move_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) = (*iterate to end of pos*)
139.1681 - if p > length ns then raise PTREE "pos not existent"
139.1682 - else move_up (P@[p]) (nth p ns) (ps,p_)
139.1683 -
139.1684 - | move_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
139.1685 - if p > length ns then raise PTREE "pos not existent"
139.1686 - else if is_pblnd (nth p ns) then
139.1687 - case p_ of Res =>
139.1688 - let val nc = (length o children o (nth p)) ns
139.1689 - in if nc = 0 then (P@[p], Pbl) (*Res -> Pbl (not Met)!*)
139.1690 - else (P @ [p, nc], Res) end (*go down*)
139.1691 - | _ => if p = 1 then (P, Pbl) else (P@[p-1], Res)
139.1692 - else case p_ of Frm => if p <> 1 then (P, Frm)
139.1693 - else if is_pblobj c then (P, Pbl) else (P, Frm)
139.1694 - | Res =>
139.1695 - let val nc = (length o children o (nth p)) ns
139.1696 - in if nc = 0 (*cannot go down*)
139.1697 - then if g_branch c = TransitiveB andalso p <> 1
139.1698 - then (P@[p-1], Res) else (P@[p], Frm)
139.1699 - else (P @ [p, nc], Res) end; (*go down*)
139.1700 -
139.1701 -
139.1702 -
139.1703 -(*.go one level up in ptree; sets the position on Frm.*)
139.1704 -fun movelevel_up _ (Nd (c, ns)) (([],p_):pos') = (*root problem*)
139.1705 - raise PTREE "pos not existent"
139.1706 -
139.1707 - (*iterate towards end of pos*)
139.1708 - | movelevel_up P (Nd (_, ns)) (p::(ps as (_::_)),p_) =
139.1709 - if p > length ns then raise PTREE "pos not existent"
139.1710 - else movelevel_up (P@[p]) (nth p ns) (ps,p_)
139.1711 -
139.1712 - | movelevel_up P (Nd (c, ns)) ([p], p_) = (*act on last element of pos*)
139.1713 - if p > length ns then raise PTREE "pos not existent"
139.1714 - else if is_pblobj c then (P, Pbl) else (P, Frm);
139.1715 -
139.1716 -
139.1717 -(*.go to the next calc-head up in the calc-tree.*)
139.1718 -fun movecalchd_up pt ((p, Res):pos') =
139.1719 - (par_pblobj pt p, Pbl):pos'
139.1720 - | movecalchd_up pt (p, _) =
139.1721 - if is_pblobj (get_obj I pt p)
139.1722 - then (p, Pbl) else (par_pblobj pt p, Pbl);
139.1723 -
139.1724 -(*.determine the previous pos' on the same level.*)
139.1725 -(*WN0502 made for interSteps; _only_ works for branch TransitiveB*)
139.1726 -fun lev_pred' pt (pos:pos' as ([],Res)) = ([],Pbl):pos'
139.1727 - | lev_pred' pt (pos:pos' as (p, Res)) =
139.1728 - let val (p', last) = split_last p
139.1729 - in if last = 1
139.1730 - then if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
139.1731 - else if get_obj g_res pt (p' @ [last - 1]) = get_obj g_form pt p
139.1732 - then (p' @ [last - 1], Res) (*TransitiveB*)
139.1733 - else if (is_pblobj o (get_obj I pt)) p then (p,Pbl) else (p, Frm)
139.1734 - end;
139.1735 -
139.1736 -(*.determine the next pos' on the same level.*)
139.1737 -fun lev_on' pt (([],Pbl):pos') = ([],Res):pos'
139.1738 - | lev_on' pt (p, Res) =
139.1739 - if get_obj g_res pt p = get_obj g_form pt (lev_on p)(*TransitiveB*)
139.1740 - then if existpt' (lev_on p, Res) pt then (lev_on p, Res)
139.1741 - else raise error ("lev_on': (p, Res) -> (p, Res) not existent, \
139.1742 - \p = "^ints2str' (lev_on p))
139.1743 - else (lev_on p, Frm)
139.1744 - | lev_on' pt (p, _) =
139.1745 - if existpt' (p, Res) pt then (p, Res)
139.1746 - else raise error ("lev_on': (p, Frm) -> (p, Res) not existent, \
139.1747 - \p = "^ints2str' p);
139.1748 -
139.1749 -fun exist_lev_on' pt p = (lev_on' pt p; true) handle _ => false;
139.1750 -
139.1751 -(*.is the pos' at the last element of a calulation _AND_ can be continued.*)
139.1752 -(* val (pt, pos as (p,p_)) = (pt, ([1],Frm));
139.1753 - *)
139.1754 -fun is_curr_endof_calc pt (([],Res) : pos') = false
139.1755 - | is_curr_endof_calc pt (pos as (p,_)) =
139.1756 - not (exist_lev_on' pt pos)
139.1757 - andalso get_obj g_ostate pt (lev_up p) = Incomplete;
139.1758 -
139.1759 -
139.1760 -(**.insert into ctree and cut branches accordingly.**)
139.1761 -
139.1762 -(*.get all positions of certain intervals on the ctree.*)
139.1763 -(*OLD VERSION without move_dn; kept for occasional redesign
139.1764 - get all pos's to be cut in a ptree
139.1765 - below a pos or from a ptree list after i-th element (NO level_up).*)
139.1766 -fun get_allpos' (_:pos, _:posel) EmptyPtree = ([]:pos' list)
139.1767 - | get_allpos' (p, 1) (Nd (b, bs)) = (*p is pos of Nd*)
139.1768 - if g_ostate b = Incomplete
139.1769 - then ((*writeln("get_allpos' (p, 1) Incomplete: p="^ints2str' p);*)
139.1770 - [(p,Frm)] @ (get_allpos's (p, 1) bs)
139.1771 - )
139.1772 - else ((*writeln("get_allpos' (p, 1) else: p="^ints2str' p);*)
139.1773 - [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)]
139.1774 - )
139.1775 - (*WN041020 here we assume what is presented on the worksheet ?!*)
139.1776 - | get_allpos' (p, i) (Nd (b, bs)) = (*p is pos of Nd*)
139.1777 - if length bs > 0 orelse is_pblobj b
139.1778 - then if g_ostate b = Incomplete
139.1779 - then [(p,Frm)] @ (get_allpos's (p, 1) bs)
139.1780 - else [(p,Frm)] @ (get_allpos's (p, 1) bs) @ [(p,Res)]
139.1781 - else
139.1782 - if g_ostate b = Incomplete
139.1783 - then []
139.1784 - else [(p,Res)]
139.1785 -(*WN041020 here we assume what is presented on the worksheet ?!*)
139.1786 -and get_allpos's _ [] = []
139.1787 - | get_allpos's (p, i) (pt::pts) = (*p is pos of parent-Nd*)
139.1788 - (get_allpos' (p@[i], i) pt) @ (get_allpos's (p, i+1) pts);
139.1789 -
139.1790 -(*.get all positions of certain intervals on the ctree.*)
139.1791 -(*NEW version WN050225*)
139.1792 -
139.1793 -
139.1794 -(*.cut branches.*)
139.1795 -(*before WN041019......
139.1796 -val cut_branch = (test_trans, curry take):
139.1797 - (ppobj -> bool) * (int -> ptree list -> ptree list);
139.1798 -.. formlery used for ...
139.1799 -fun cut_tree''' _ [] = EmptyPtree
139.1800 - | cut_tree''' pt pos =
139.1801 - let val (pt',cut) = appl_branch cut_branch pt pos
139.1802 - in if cut andalso length pos > 1 then cut_tree''' pt' (lev_up pos)
139.1803 - else pt' end;
139.1804 -*)
139.1805 -(*OLD version before WN050225*)
139.1806 -(*WN050106 like cut_level, but deletes exactly 1 node --- for tests ONLY*)
139.1807 -fun cut_level_'_ (_:pos' list) (_:pos) EmptyPtree (_:pos') =
139.1808 - raise PTREE "cut_level_'_ Empty _"
139.1809 - | cut_level_'_ _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level_'_ _ []"
139.1810 - | cut_level_'_ cuts P (Nd (b, bs)) (p::[],p_) =
139.1811 - if test_trans b
139.1812 - then (Nd (b, drop_nth [] (p:posel, bs)),
139.1813 - (* ~~~~~~~~~~~*)
139.1814 - cuts @
139.1815 - (if p_ = Frm then [(P@[p],Res)] else ([]:pos' list)) @
139.1816 - (*WN041020 here we assume what is presented on the worksheet ?!*)
139.1817 - (get_allpos's (P, p+1) (drop_nth [] (p, bs))))
139.1818 - (* ~~~~~~~~~~~*)
139.1819 - else (Nd (b, bs), cuts)
139.1820 - | cut_level_'_ cuts P (Nd (b, bs)) ((p::ps),p_) =
139.1821 - let val (bs',cuts') = cut_level_'_ cuts P (nth p bs) (ps, p_)
139.1822 - in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
139.1823 -
139.1824 -(*before WN050219*)
139.1825 -fun cut_level (_:pos' list) (_:pos) EmptyPtree (_:pos') =
139.1826 - raise PTREE "cut_level EmptyPtree _"
139.1827 - | cut_level _ _ (Nd ( _, _)) ([],_) = raise PTREE "cut_level _ []"
139.1828 -
139.1829 - | cut_level cuts P (Nd (b, bs)) (p::[],p_) =
139.1830 - if test_trans b
139.1831 - then (Nd (b, take (p:posel, bs)),
139.1832 - cuts @
139.1833 - (if p_ = Frm andalso (*#*) g_ostate b = Complete
139.1834 - then [(P@[p],Res)] else ([]:pos' list)) @
139.1835 - (*WN041020 here we assume what is presented on the worksheet ?!*)
139.1836 - (get_allpos's (P, p+1) (takerest (p, bs))))
139.1837 - else (Nd (b, bs), cuts)
139.1838 -
139.1839 - | cut_level cuts P (Nd (b, bs)) ((p::ps),p_) =
139.1840 - let val (bs',cuts') = cut_level cuts P (nth p bs) (ps, p_)
139.1841 - in (Nd (b, repl_app bs p bs'), cuts @ cuts') end;
139.1842 -
139.1843 -(*OLD version before WN050219, overwritten below*)
139.1844 -fun cut_tree _ (([],_):pos') = raise PTREE "cut_tree _ ([],_)"
139.1845 - | cut_tree pt (pos as ([p],_)) =
139.1846 - let val (pt', cuts) = cut_level ([]:pos' list) [] pt pos
139.1847 - in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete
139.1848 - then [] else [([],Res)])) end
139.1849 - | cut_tree pt (p,p_) =
139.1850 - let
139.1851 - fun cutfn pt cuts (p,p_) =
139.1852 - let val (pt', cuts') = cut_level [] (lev_up p) pt (p,p_)
139.1853 - val cuts'' = if get_obj g_ostate pt (lev_up p) = Incomplete
139.1854 - then [] else [(lev_up p, Res)]
139.1855 - in if length cuts' > 0 andalso length p > 1
139.1856 - then cutfn pt' (cuts @ cuts') (lev_up p, Frm(*-->(p,Res)*))
139.1857 - else (pt',cuts @ cuts') end
139.1858 - val (pt', cuts) = cutfn pt [] (p,p_)
139.1859 - in (pt', cuts @ (if get_obj g_ostate pt [] = Incomplete
139.1860 - then [] else [([], Res)])) end;
139.1861 -
139.1862 -
139.1863 -(*########/ inserted from ctreeNEW.sml \#################################**)
139.1864 -
139.1865 -(*.get all positions in a ptree until ([],Res) or ostate=Incomplete
139.1866 -val get_allp = fn :
139.1867 - pos' list -> : accumulated, start with []
139.1868 - pos -> : the offset for subtrees wrt the root
139.1869 - ptree -> : (sub)tree
139.1870 - pos' : initialization (the last pos' before ...)
139.1871 - -> pos' list : of positions in this (sub) tree (relative to the root)
139.1872 -.*)
139.1873 -(* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([], Frm):pos');
139.1874 - val (cuts, P, pt, pos) = ([], [2], get_nd pt [2], ([], Frm):pos');
139.1875 - length (children pt);
139.1876 - *)
139.1877 -fun get_allp (cuts:pos' list) (P:pos, pos:pos') pt =
139.1878 - (let val nxt = move_dn [] pt pos (*exn if Incomplete reached*)
139.1879 - in if nxt <> ([],Res)
139.1880 - then get_allp (cuts @ [nxt]) (P, nxt) pt
139.1881 - else (map (apfst (curry op@ P)) (cuts @ [nxt])): pos' list
139.1882 - end) handle PTREE _ => (map (apfst (curry op@ P)) cuts);
139.1883 -
139.1884 -
139.1885 -(*the pts are assumed to be on the same level*)
139.1886 -fun get_allps (cuts: pos' list) (P:pos) [] = cuts
139.1887 - | get_allps cuts P (pt::pts) =
139.1888 - let val below = get_allp [] (P, ([], Frm)) pt
139.1889 - val levfrm =
139.1890 - if is_pblnd pt
139.1891 - then (P, Pbl)::below
139.1892 - else if last_elem P = 1
139.1893 - then (P, Frm)::below
139.1894 - else (*Trans*) below
139.1895 - val levres = levfrm @ (if null below then [(P, Res)] else [])
139.1896 - in get_allps (cuts @ levres) (lev_on P) pts end;
139.1897 -
139.1898 -
139.1899 -(**.these 2 funs decide on how far cut_tree goes.**)
139.1900 -(*.shall the nodes _after_ the pos to be inserted at be deleted?.*)
139.1901 -fun test_trans (PrfObj{branch = Transitive,...}) = true
139.1902 - | test_trans (PrfObj{branch = NoBranch,...}) = true
139.1903 - | test_trans (PblObj{branch = Transitive,...}) = true
139.1904 - | test_trans (PblObj{branch = NoBranch,...}) = true
139.1905 - | test_trans _ = false;
139.1906 -(*.shall cutting be continued on the higher level(s)?
139.1907 - the Nd regarded will NOT be changed.*)
139.1908 -fun cutlevup (PblObj _) = false (*for tests of LK0502*)
139.1909 - | cutlevup _ = true;
139.1910 -val cutlevup = test_trans;(*WN060727 after summerterm tests.LK0502 withdrawn*)
139.1911 -
139.1912 -(*cut_bottom new sml603..608
139.1913 -cut the level at the bottom of the pos (used by cappend_...)
139.1914 -and handle the parent in order to avoid extra case for root
139.1915 -fn: ptree -> : the _whole_ ptree for cut_levup
139.1916 - pos * posel -> : the pos after split_last
139.1917 - ptree -> : the parent of the Nd to be cut
139.1918 -return
139.1919 - (ptree * : the updated ptree
139.1920 - pos' list) * : the pos's cut
139.1921 - bool : cutting shall be continued on the higher level(s)
139.1922 -*)
139.1923 -fun cut_bottom _ (pt' as Nd (b, [])) = ((pt', []), cutlevup b)
139.1924 - | cut_bottom (P:pos, p:posel) (Nd (b, bs)) =
139.1925 - let (*divide level into 3 parts...*)
139.1926 - val keep = take (p - 1, bs)
139.1927 - val pt' as Nd (_,bs') = nth p bs
139.1928 - (*^^^^^_here_ will be 'insert'ed by 'append_..'*)
139.1929 - val (tail, tp) = (takerest (p, bs),
139.1930 - if null (takerest (p, bs)) then 0 else p + 1)
139.1931 - val (children, cuts) =
139.1932 - if test_trans b
139.1933 - then (keep,
139.1934 - (if is_pblnd pt' then [(P @ [p], Pbl)] else [])
139.1935 - @ (get_allp [] (P @ [p], (P, Frm)) pt')
139.1936 - @ (get_allps [] (P @ [p+1]) tail))
139.1937 - else (keep @ [(*'insert'ed by 'append_..'*)] @ tail,
139.1938 - get_allp [] (P @ [p], (P, Frm)) pt')
139.1939 - val (pt'', cuts) =
139.1940 - if cutlevup b
139.1941 - then (Nd (del_res b, children),
139.1942 - cuts @ (if g_ostate b = Incomplete then [] else [(P,Res)]))
139.1943 - else (Nd (b, children), cuts)
139.1944 - (*val _= writeln("####cut_bottom (P, p)="^pos2str (P @ [p])^
139.1945 - ", Nd=.............................................")
139.1946 - val _= show_pt pt''
139.1947 - val _= writeln("####cut_bottom form='"^
139.1948 - term2str (get_obj g_form pt'' []))
139.1949 - val _= writeln("####cut_bottom cuts#="^string_of_int (length cuts)^
139.1950 - ", cuts="^pos's2str cuts)*)
139.1951 - in ((pt'', cuts:pos' list), cutlevup b) end;
139.1952 -
139.1953 -
139.1954 -(*.go all levels from the bottom of 'pos' up to the root,
139.1955 - on each level compose the children of a node and accumulate the cut Nds
139.1956 -args
139.1957 - pos' list -> : for accumulation
139.1958 - bool -> : cutting shall be continued on the higher level(s)
139.1959 - ptree -> : the whole ptree for 'get_nd pt P' on each level
139.1960 - ptree -> : the Nd from the lower level for insertion at path
139.1961 - pos * posel -> : pos=path split for convenience
139.1962 - ptree -> : Nd the children of are under consideration on this call
139.1963 -returns :
139.1964 - ptree * pos' list : the updated parent-Nd and the pos's of the Nds cut
139.1965 -.*)
139.1966 -fun cut_levup (cuts:pos' list) clevup pt pt' (P:pos, p:posel) (Nd (b, bs)) =
139.1967 - let (*divide level into 3 parts...*)
139.1968 - val keep = take (p - 1, bs)
139.1969 - (*val pt' comes as argument from below*)
139.1970 - val (tail, tp) = (takerest (p, bs),
139.1971 - if null (takerest (p, bs)) then 0 else p + 1)
139.1972 - val (children, cuts') =
139.1973 - if clevup
139.1974 - then (keep @ [pt'], get_allps [] (P @ [p+1]) tail)
139.1975 - else (keep @ [pt'] @ tail, [])
139.1976 - val clevup' = if clevup then cutlevup b else false
139.1977 - (*the first Nd with false stops cutting on all levels above*)
139.1978 - val (pt'', cuts') =
139.1979 - if clevup'
139.1980 - then (Nd (del_res b, children),
139.1981 - cuts' @ (if g_ostate b = Incomplete then [] else [(P,Res)]))
139.1982 - else (Nd (b, children), cuts')
139.1983 - (*val _= writeln("#####cut_levup clevup= "^bool2str clevup)
139.1984 - val _= writeln("#####cut_levup cutlevup b= "^bool2str (cutlevup b))
139.1985 - val _= writeln("#####cut_levup (P, p)="^pos2str (P @ [p])^
139.1986 - ", Nd=.............................................")
139.1987 - val _= show_pt pt''
139.1988 - val _= writeln("#####cut_levup form='"^
139.1989 - term2str (get_obj g_form pt'' []))
139.1990 - val _= writeln("#####cut_levup cuts#="^string_of_int (length cuts)^
139.1991 - ", cuts="^pos's2str cuts)*)
139.1992 - in if null P then (pt'', (cuts @ cuts'):pos' list)
139.1993 - else let val (P, p) = split_last P
139.1994 - in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P)
139.1995 - end
139.1996 - end;
139.1997 -
139.1998 -(*.cut nodes after and below an inserted node in the ctree;
139.1999 - the cuts range is limited by the predicate 'fun cutlevup'.*)
139.2000 -fun cut_tree pt (pos,_) =
139.2001 - if not (existpt pos pt)
139.2002 - then (pt,[]) (*appending a formula never cuts anything*)
139.2003 - else let val (P, p) = split_last pos
139.2004 - val ((pt', cuts), clevup) = cut_bottom (P, p) (get_nd pt P)
139.2005 - (* pt' is the updated parent of the Nd to cappend_..*)
139.2006 - in if null P then (pt', cuts)
139.2007 - else let val (P, p) = split_last P
139.2008 - in cut_levup cuts clevup pt pt' (P, p) (get_nd pt P)
139.2009 - end
139.2010 - end;
139.2011 -
139.2012 -fun append_atomic p l f r f' s pt =
139.2013 - let (**val _= writeln("#@append_atomic: pos ="^pos2str p)**)
139.2014 - val (iss, f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
139.2015 - then (*after Take*)
139.2016 - ((fst (get_obj g_loc pt p), SOME l),
139.2017 - get_obj g_form pt p)
139.2018 - else ((NONE, SOME l), f)
139.2019 - in insert (PrfObj {cell = NONE,
139.2020 - form = f,
139.2021 - tac = r,
139.2022 - loc = iss,
139.2023 - branch= NoBranch,
139.2024 - result= f',
139.2025 - ostate= s}) pt p end;
139.2026 -
139.2027 -
139.2028 -(*20.8.02: cappend_* FIXXXXME cut branches below cannot be decided here:
139.2029 - detail - generate - cappend: inserted, not appended !!!
139.2030 -
139.2031 - cut decided in applicable_in !?!
139.2032 -*)
139.2033 -fun cappend_atomic pt p loc f r f' s =
139.2034 -(* val (pt, p, loc, f, r, f', s) =
139.2035 - (pt,p,l,f,Rewrite_Set_Inst (subst2subs subs',id_rls rls'),
139.2036 - (f',asm),Complete);
139.2037 - *)
139.2038 -((*writeln("##@cappend_atomic: pos ="^pos2str p);*)
139.2039 - apfst (append_atomic p loc f r f' s) (cut_tree pt (p,Frm))
139.2040 -);
139.2041 -(*TODO.WN050305 redesign the handling of istates*)
139.2042 -fun cappend_atomic pt p ist_res f r f' s =
139.2043 - if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
139.2044 - then (*after Take: transfer Frm and respective istate*)
139.2045 - let val (ist_form, f) = (get_loc pt (p,Frm),
139.2046 - get_obj g_form pt p)
139.2047 - val (pt, cs) = cut_tree pt (p,Frm)
139.2048 - val pt = append_atomic p e_istate f r f' s pt
139.2049 - val pt = update_loc' pt p (SOME ist_form, SOME ist_res)
139.2050 - in (pt, cs) end
139.2051 - else apfst (append_atomic p ist_res f r f' s) (cut_tree pt (p,Frm));
139.2052 -
139.2053 -
139.2054 -(* called by Take *)
139.2055 -fun append_form p l f pt =
139.2056 -((*writeln("##@append_form: pos ="^pos2str p);*)
139.2057 - insert (PrfObj {cell = NONE,
139.2058 - form = (*if existpt p pt
139.2059 - andalso get_obj g_tac pt p = Empty_Tac
139.2060 - (*distinction from 'old' (+complete!) pobjs*)
139.2061 - then get_obj g_form pt p else*) f,
139.2062 - tac = Empty_Tac,
139.2063 - loc = (SOME l, NONE),
139.2064 - branch= NoBranch,
139.2065 - result= (e_term,[]),
139.2066 - ostate= Incomplete}) pt p
139.2067 -);
139.2068 -(* val (p,loc,f) = ([1], e_istate, str2term "x + 1 = 2");
139.2069 - val (p,loc,f) = (fst p, e_istate, str2term "-1 + x = 0");
139.2070 - *)
139.2071 -fun cappend_form pt p loc f =
139.2072 -((*writeln("##@cappend_form: pos ="^pos2str p);*)
139.2073 - apfst (append_form p loc f) (cut_tree pt (p,Frm))
139.2074 -);
139.2075 -fun cappend_form pt p loc f =
139.2076 -let (*val _= writeln("##@cappend_form: pos ="^pos2str p)
139.2077 - val _= writeln("##@cappend_form before cut_tree: loc ="^istate2str loc)*)
139.2078 - val (pt', cs) = cut_tree pt (p,Frm)
139.2079 - val pt'' = append_form p loc f pt'
139.2080 - (*val _= writeln("##@cappend_form after append: loc ="^
139.2081 - istates2str (get_obj g_loc pt'' p))*)
139.2082 -in (pt'', cs) end;
139.2083 -
139.2084 -
139.2085 -
139.2086 -fun append_result pt p l f s =
139.2087 -((*writeln("##@append_result: pos ="^pos2str p);*)
139.2088 - (appl_obj (repl_result (fst (get_obj g_loc pt p),
139.2089 - SOME l) f s) pt p, [])
139.2090 -);
139.2091 -
139.2092 -
139.2093 -(*WN041022 deprecated, still for kbtest/diffapp.sml, /systest/root-equ.sml*)
139.2094 -fun append_parent p l f r b pt =
139.2095 - let (*val _= writeln("###append_parent: pos ="^pos2str p);*)
139.2096 - val (ll,f) = if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
139.2097 - then ((fst (get_obj g_loc pt p), SOME l),
139.2098 - get_obj g_form pt p)
139.2099 - else ((SOME l, NONE), f)
139.2100 - in insert (PrfObj
139.2101 - {cell = NONE,
139.2102 - form = f,
139.2103 - tac = r,
139.2104 - loc = ll,
139.2105 - branch= b,
139.2106 - result= (e_term,[]),
139.2107 - ostate= Incomplete}) pt p end;
139.2108 -fun cappend_parent pt p loc f r b =
139.2109 -((*writeln("###cappend_parent: pos ="^pos2str p);*)
139.2110 - apfst (append_parent p loc f r b) (cut_tree pt (p,Und))
139.2111 -);
139.2112 -
139.2113 -
139.2114 -fun append_problem [] l fmz (strs,spec,hdf) _ =
139.2115 -((*writeln("###append_problem: pos = []");*)
139.2116 - (Nd (PblObj
139.2117 - {cell = NONE,
139.2118 - origin= (strs,spec,hdf),
139.2119 - fmz = fmz,
139.2120 - spec = empty_spec,
139.2121 - probl = []:itm list,
139.2122 - meth = []:itm list,
139.2123 - env = NONE,
139.2124 - loc = (SOME l, NONE),
139.2125 - branch= TransitiveB,(*FIXXXXXME.27.8.03: for equations only*)
139.2126 - result= (e_term,[]),
139.2127 - ostate= Incomplete},[]))
139.2128 -)
139.2129 - | append_problem p l fmz (strs,spec,hdf) pt =
139.2130 -((*writeln("###append_problem: pos ="^pos2str p);*)
139.2131 - insert (PblObj
139.2132 - {cell = NONE,
139.2133 - origin= (strs,spec,hdf),
139.2134 - fmz = fmz,
139.2135 - spec = empty_spec,
139.2136 - probl = []:itm list,
139.2137 - meth = []:itm list,
139.2138 - env = NONE,
139.2139 - loc = (SOME l, NONE),
139.2140 - branch= TransitiveB,
139.2141 - result= (e_term,[]),
139.2142 - ostate= Incomplete}) pt p
139.2143 -);
139.2144 -fun cappend_problem _ [] loc fmz ori =
139.2145 -((*writeln("###cappend_problem: pos = []");*)
139.2146 - (append_problem [] loc fmz ori EmptyPtree,[])
139.2147 -)
139.2148 - | cappend_problem pt p loc fmz ori =
139.2149 -((*writeln("###cappend_problem: pos ="^pos2str p);*)
139.2150 - apfst (append_problem p (loc:istate) fmz ori) (cut_tree pt (p,Frm))
139.2151 -);
139.2152 -
139.2153 -(*.get the theory explicitly specified for the rootpbl;
139.2154 - thus use this function _after_ finishing specification.*)
139.2155 -fun rootthy (Nd (PblObj {spec=(thyID, _, _),...}, _)) = assoc_thy thyID
139.2156 - | rootthy _ = raise error "rootthy";
139.2157 -
140.1 --- a/src/Tools/isac/ME/generate.sml Wed Aug 25 15:15:01 2010 +0200
140.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
140.3 @@ -1,586 +0,0 @@
140.4 -(* use"ME/generate.sml";
140.5 - use"generate.sml";
140.6 - *)
140.7 -
140.8 -(*.initialize istate for Detail_Set.*)
140.9 -(*
140.10 -fun init_istate (Rewrite_Set rls) =
140.11 -(* val (Rewrite_Set rls) = (get_obj g_tac pt p);
140.12 - *)
140.13 - (case assoc_rls rls of
140.14 - Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t))
140.15 -(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls;
140.16 - *)
140.17 - | Rls {scr=EmptyScr,...} =>
140.18 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.19 - ^"use prep_rls for storing rule-sets !")
140.20 - | Rls {scr=Script s,...} =>
140.21 -(* val Rls {scr=Script s,...} = assoc_rls rls;
140.22 - *)
140.23 - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))
140.24 - | Seq {scr=EmptyScr,...} =>
140.25 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.26 - ^"use prep_rls for storing rule-sets !")
140.27 - | Seq {srls=srls,scr=Script s,...} =>
140.28 - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)))
140.29 - | init_istate (Rewrite_Set_Inst (subs, rls)) =
140.30 -(* val (Rewrite_Set_Inst (subs, rls)) = (get_obj g_tac pt p);
140.31 - *)
140.32 - let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs
140.33 - in case assoc_rls rls of
140.34 - Rls {scr=EmptyScr,...} =>
140.35 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.36 - ^"use prep_rls for storing rule-sets !")
140.37 - | Rls {scr=Script s,...} =>
140.38 - let val (a1, a2) = two_scr_arg s
140.39 - in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end
140.40 - | Seq {scr=EmptyScr,...} =>
140.41 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.42 - ^"use prep_rls for storing rule-sets !")
140.43 -(* val Seq {scr=Script s,...} = assoc_rls rls;
140.44 - *)
140.45 - | Seq {scr=Script s,...} =>
140.46 - let val (a1, a2) = two_scr_arg s
140.47 - in (ScrState ([(a1, v), (a2, t)],[], NONE, e_term, Sundef,true)) end
140.48 - end;
140.49 -*)
140.50 -(*~~~~~~~~~~~~~~~~~~~~~~copy for dev. until del.~~~~~~~~~~~~~~~~~~~~~~~~~*)
140.51 -fun init_istate (Rewrite_Set rls) t =
140.52 -(* val (Rewrite_Set rls) = (get_obj g_tac pt p);
140.53 - *)
140.54 - (case assoc_rls rls of
140.55 - Rrls {scr=sc as Rfuns {init_state=ii,...},...} => (RrlsState (ii t))
140.56 -(* val Rrls {scr=sc as Rfuns {init_state=ii,...},...} = assoc_rls rls;
140.57 - *)
140.58 - | Rls {scr=EmptyScr,...} =>
140.59 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.60 - ^"use prep_rls for storing rule-sets !")
140.61 - | Rls {scr=Script s,...} =>
140.62 -(* val Rls {scr=Script s,...} = assoc_rls rls;
140.63 - *)
140.64 - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true))
140.65 - | Seq {scr=EmptyScr,...} =>
140.66 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.67 - ^"use prep_rls for storing rule-sets !")
140.68 - | Seq {srls=srls,scr=Script s,...} =>
140.69 - (ScrState ([(one_scr_arg s, t)], [], NONE, e_term, Sundef, true)))
140.70 -(* val ((Rewrite_Set_Inst (subs, rls)), t) = ((get_obj g_tac pt p), t);
140.71 - *)
140.72 - | init_istate (Rewrite_Set_Inst (subs, rls)) t =
140.73 - let val (_, v)::_ = subs2subst (assoc_thy "Isac.thy") subs
140.74 - (*...we suppose the substitution of only _one_ bound variable*)
140.75 - in case assoc_rls rls of
140.76 - Rls {scr=EmptyScr,...} =>
140.77 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.78 - ^"use prep_rls for storing rule-sets !")
140.79 - | Rls {scr=Script s,...} =>
140.80 - let val (form, bdv) = two_scr_arg s
140.81 - in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true))
140.82 - end
140.83 - | Seq {scr=EmptyScr,...} =>
140.84 - raise error ("interSteps>..>init_istate: \""^rls^"\" has EmptyScr."
140.85 - ^"use prep_rls for storing rule-sets !")
140.86 -(* val Seq {scr=Script s,...} = assoc_rls rls;
140.87 - *)
140.88 - | Seq {scr=Script s,...} =>
140.89 - let val (form, bdv) = two_scr_arg s
140.90 - in (ScrState ([(form, t), (bdv, v)],[], NONE, e_term, Sundef,true))
140.91 - end
140.92 - end;
140.93 -
140.94 -
140.95 -(*.a taci holds alle information required to build a node in the calc-tree;
140.96 - a taci is assumed to be used efficiently such that the calc-tree
140.97 - resulting from applying a taci need not be stored separately;
140.98 - see "type calcstate".*)
140.99 -(*TODO.WN0504 redesign ??? or redesign generate ?? see "fun generate"
140.100 - TODO.WN0512 ? redesign this _list_:
140.101 - # only used for [Apply_Method + (Take or Subproblem)], i.e. for initacs
140.102 - # the latter problem may be resolved automatically if "fun autocalc" is
140.103 - not any more used for the specify-phase and for changing the phases*)
140.104 -type taci =
140.105 - (tac * (*for comparison with input tac*)
140.106 - tac_ * (*for ptree generation*)
140.107 - (pos' * (*after applying tac_, for ptree generation*)
140.108 - istate)); (*after applying tac_, for ptree generation*)
140.109 -val e_taci = (Empty_Tac, Empty_Tac_, (e_pos', e_istate)): taci;
140.110 -(* val (tac, tac_, (pos', istate))::_ = tacis';
140.111 - *)
140.112 -fun taci2str ((tac, tac_, (pos', istate)):taci) =
140.113 - "( "^tac2str tac^", "^tac_2str tac_^", ( "^pos'2str pos'
140.114 - ^", "^istate2str istate^" ))";
140.115 -fun tacis2str tacis = (strs2str o (map (linefeed o taci2str))) tacis;
140.116 -
140.117 -datatype pblmet = (*%^%*)
140.118 - Upblmet (*undefined*)
140.119 - | Problem of pblID (*%^%*)
140.120 - | Method of metID; (*%^%*)
140.121 -fun pblmet2str (Problem pblID) = "Problem "^(strs2str pblID)(*%^%*)
140.122 - | pblmet2str (Method metID) = "Method "^(metID2str metID);(*%^%*)
140.123 - (*%^%*) (*26.6. moved to sequent.sml: fun ~~~~~~~~~; was here below*)
140.124 -
140.125 -
140.126 -(* copy from 03.60.usecases.sml 15.11.99 *)
140.127 -datatype user_cmd =
140.128 - Accept | NotAccept | Example
140.129 -| YourTurn | MyTurn (* internal use only 7.6.02 java-sml*)
140.130 -| Rules
140.131 -| DontKnow (*| HowComes | WhatFor 7.6.02 java-sml*)
140.132 -| Undo (*| Back | Forward 7.6.02 java-sml*)
140.133 -| EndProof | EndSession
140.134 -| ActivePlus | ActiveMinus | SpeedPlus | SpeedMinus
140.135 - (*Stepwidth...7.6.02 java-sml*)
140.136 -| Auto | NotAuto | Details;
140.137 -(* for test-print-outs *)
140.138 -fun user_cmd2str Accept ="Accept"
140.139 - | user_cmd2str NotAccept ="NotAccept"
140.140 - | user_cmd2str Example ="Example"
140.141 - | user_cmd2str MyTurn ="MyTurn"
140.142 - | user_cmd2str YourTurn ="YourTurn"
140.143 - | user_cmd2str Rules ="Rules"
140.144 -(*| user_cmd2str HowComes ="HowComes"*)
140.145 - | user_cmd2str DontKnow ="DontKnow"
140.146 -(*| user_cmd2str WhatFor ="WhatFor"
140.147 - | user_cmd2str Back ="Back"*)
140.148 - | user_cmd2str Undo ="Undo"
140.149 -(*| user_cmd2str Forward ="Forward"*)
140.150 - | user_cmd2str EndProof ="EndProof"
140.151 - | user_cmd2str EndSession ="EndSession"
140.152 - | user_cmd2str ActivePlus = "ActivePlus"
140.153 - | user_cmd2str ActiveMinus = "ActiveMinus"
140.154 - | user_cmd2str SpeedPlus = "SpeedPlus"
140.155 - | user_cmd2str SpeedMinus = "SpeedMinus"
140.156 - | user_cmd2str Auto = "Auto"
140.157 - | user_cmd2str NotAuto = "NotAuto"
140.158 - | user_cmd2str Details = "Details";
140.159 -
140.160 -
140.161 -
140.162 -(*3.5.00: TODO: foppFK eliminated in interface FE-KE !!!*)
140.163 -datatype foppFK = (* in DG cases div 2 *)
140.164 - EmptyFoppFK (*DG internal*)
140.165 -| FormFK of cterm'
140.166 -| PpcFK of cterm' ppc;
140.167 -fun foppFK2str (FormFK ct') ="FormFK "^ct'
140.168 - | foppFK2str (PpcFK ppc) ="PpcFK "^(ppc2str ppc)
140.169 - | foppFK2str EmptyFoppFK ="EmptyFoppFK";
140.170 -
140.171 -
140.172 -datatype nest = Open | Closed | Nundef;
140.173 -fun nest2str Open = "Open"
140.174 - | nest2str Closed = "Closed"
140.175 - | nest2str Nundef = "Nundef";
140.176 -
140.177 -type indent = int;
140.178 -datatype edit = EdUndef | Write | Protect;
140.179 - (* bridge --> kernel *)
140.180 - (* bridge <-> kernel *)
140.181 -(* needed in dialog.sml *) (* bridge <-- kernel *)
140.182 -fun edit2str EdUndef = "EdUndef"
140.183 - | edit2str Write = "Write"
140.184 - | edit2str Protect = "Protect";
140.185 -
140.186 -
140.187 -datatype inout =
140.188 - New_User | End_User (*<->*)
140.189 -| New_Proof | End_Proof (*<->*)
140.190 -| Command of user_cmd (*-->*)
140.191 -| Request of string | Message of string (*<--*)
140.192 -| Error_ of string | System of string (*<--*)
140.193 -| FoPpcFK of foppFK (*-->*)
140.194 -| FormKF of cellID * edit * indent * nest * cterm' (*<--*)
140.195 -| PpcKF of cellID * edit * indent * nest * (pblmet * item ppc) (*<--*)
140.196 -| RuleFK of tac (*-->*)
140.197 -| RuleKF of edit * tac (*<--*)
140.198 -| RefinedKF of (pblID * ((itm list) * ((bool * term) list))) (*<--*)
140.199 -| Select of tac list (*<--*)
140.200 -| RefineKF of match list (*<--*)
140.201 -| Speed of int (*<--*)
140.202 -| Active of int (*<--*)
140.203 -| Domain of domID; (*<--*)
140.204 -
140.205 -fun inout2str End_Proof = "End_Proof"
140.206 - | inout2str (Command user_cmd) = "Command "^(user_cmd2str user_cmd)
140.207 - | inout2str (Request s) = "Request "^s
140.208 - | inout2str (Message s) = "Message "^s
140.209 - | inout2str (Error_ s) = "Error_ "^s
140.210 - | inout2str (System s) = "System "^s
140.211 - | inout2str (FoPpcFK foppFK) = "FoPpcFK "^(foppFK2str foppFK)
140.212 - | inout2str (FormKF (cellID, edit, indent, nest, ct')) =
140.213 - "FormKF ("^(string_of_int cellID)^","
140.214 - ^(edit2str edit)^","^(string_of_int indent)^","
140.215 - ^(nest2str nest)^",("
140.216 - ^ct' ^")"
140.217 - | inout2str (PpcKF (cellID, edit, indent, nest, (pm,itemppc))) =
140.218 - "PpcKF ("^(string_of_int cellID)^","
140.219 - ^(edit2str edit)^","^(string_of_int indent)^","
140.220 - ^(nest2str nest)^",("
140.221 - ^(pblmet2str pm)^","^(itemppc2str itemppc)^"))"
140.222 - | inout2str (RuleKF (edit,tac)) = "RuleKF "^
140.223 - pair2str(edit2str edit,tac2str tac)
140.224 - | inout2str (RuleFK tac) = "RuleFK "^(tac2str tac)
140.225 - | inout2str (Select tacs)=
140.226 - "Select "^((strs2str' o (map tac2str)) tacs)
140.227 - | inout2str (RefineKF ms) = "RefineKF "^(matchs2str ms)
140.228 - | inout2str (Speed i) = "Speed "^(string_of_int i)
140.229 - | inout2str (Active i) = "Active "^(string_of_int i)
140.230 - | inout2str (Domain dI) = "Domain "^dI;
140.231 -fun inouts2str ios = (strs2str' o (map inout2str)) ios;
140.232 -
140.233 -datatype mout =
140.234 - Form' of inout (* packing cterm' | cterm' ppc *)
140.235 -| Problems of inout (* passes specify (and solve) *)
140.236 -| Error' of inout
140.237 -| EmptyMout;
140.238 -
140.239 -fun mout2str (Form' inout) ="Form' "^(inout2str inout)
140.240 - | mout2str (Error' inout) ="Error' "^(inout2str inout)
140.241 - | mout2str (EmptyMout ) ="EmptyMout";
140.242 -
140.243 -(*fun Form'2str (Form' )*)
140.244 -
140.245 -
140.246 -
140.247 -
140.248 -
140.249 -(* init pbl with ...,dsc,empty | [] *)
140.250 -fun init_pbl pbt =
140.251 - let
140.252 - fun pbt2itm (f,(d,t)) =
140.253 - ((0,[],false,f,Inc((d,[]),(e_term,[]))):itm);
140.254 - in map pbt2itm pbt end;
140.255 -(*take formal parameters from pbt, for transfer from pbl/met-hierarchy*)
140.256 -fun init_pbl' pbt =
140.257 - let
140.258 - fun pbt2itm (f,(d,t)) =
140.259 - ((0,[],false,f,Inc((d,[t]),(e_term,[]))):itm);
140.260 - in map pbt2itm pbt end;
140.261 -
140.262 -
140.263 -(*generate 1 ppobj in ptree*)
140.264 -(*TODO.WN0501: take calcstate as an argument (see embed_derive etc.)?specify?*)
140.265 -fun generate1 thy (Add_Given' (_, itmlist)) Uistate (pos as (p,p_)) pt =
140.266 - (pos:pos',[],Form' (PpcKF (0,EdUndef,0,Nundef,
140.267 - (Upblmet,itms2itemppc thy [][]))),
140.268 - case p_ of Pbl => update_pbl pt p itmlist
140.269 - | Met => update_met pt p itmlist)
140.270 - | generate1 thy (Add_Find' (_, itmlist)) Uistate (pos as (p,p_)) pt =
140.271 - (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
140.272 - case p_ of Pbl => update_pbl pt p itmlist
140.273 - | Met => update_met pt p itmlist)
140.274 - | generate1 thy (Add_Relation' (_, itmlist)) Uistate (pos as (p,p_)) pt =
140.275 - (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
140.276 - case p_ of Pbl => update_pbl pt p itmlist
140.277 - | Met => update_met pt p itmlist)
140.278 -
140.279 - | generate1 thy (Specify_Theory' domID) Uistate (pos as (p,_)) pt =
140.280 - (pos,[],Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
140.281 - update_domID pt p domID)
140.282 -
140.283 - | generate1 thy (Specify_Problem' (pI, (ok, (itms, pre)))) Uistate
140.284 - (pos as (p,_)) pt =
140.285 - let val pt = update_pbl pt p itms
140.286 - val pt = update_pblID pt p pI
140.287 - in ((p,Pbl),[],
140.288 - Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
140.289 - pt) end
140.290 -
140.291 - | generate1 thy (Specify_Method' (mID, oris, itms)) Uistate
140.292 - (pos as (p,_)) pt =
140.293 - let val pt = update_oris pt p oris
140.294 - val pt = update_met pt p itms
140.295 - val pt = update_metID pt p mID
140.296 - in ((p,Met),[],
140.297 - Form' (PpcKF (0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
140.298 - pt) end
140.299 -
140.300 - | generate1 thy (Model_Problem' (_, itms, met)) Uistate (pos as (p,_)) pt =
140.301 -(* val (itms,pos as (p,_)) = (pbl, pos);
140.302 - *)
140.303 - let val pt = update_pbl pt p itms
140.304 - val pt = update_met pt p met
140.305 - in (pos,[],Form'(PpcKF(0,EdUndef,0,Nundef,
140.306 - (Upblmet,itms2itemppc thy [][]))), pt) end
140.307 -
140.308 - | generate1 thy (Refine_Tacitly' (pI,pIre,domID,metID,pbl))
140.309 - Uistate (pos as (p,_)) pt =
140.310 - let val pt = update_pbl pt p pbl
140.311 - val pt = update_orispec pt p (domID,pIre,metID)
140.312 - in (pos,[],
140.313 - Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),
140.314 - pt) end
140.315 -
140.316 - | generate1 thy (Refine_Problem' (pI,_)) Uistate (pos as (p,_)) pt =
140.317 - let val (dI,_,mI) = get_obj g_spec pt p
140.318 - val pt = update_spec pt p (dI, pI, mI)
140.319 - in (pos,[],
140.320 - Form'(PpcKF(0,EdUndef,0,Nundef,(Upblmet,itms2itemppc thy [][]))),pt)
140.321 - end
140.322 -
140.323 - | generate1 thy (Apply_Method' (_,topt, is)) _ (pos as (p,p_)) pt =
140.324 - ((*writeln("###generate1 Apply_Method': pos = "^pos'2str (p,p_));
140.325 - writeln("###generate1 Apply_Method': topt= "^termopt2str topt);
140.326 - writeln("###generate1 Apply_Method': is = "^istate2str is);*)
140.327 - case topt of
140.328 - SOME t =>
140.329 - let val (pt,c) = cappend_form pt p is t
140.330 - (*val _= writeln("###generate1 Apply_Method: after cappend")*)
140.331 - in (pos,c, EmptyMout,pt)
140.332 - end
140.333 - | NONE =>
140.334 - (pos,[],EmptyMout,update_env pt p (SOME is)))
140.335 -(* val (thy, (Take' t), l, (p,p_), pt) =
140.336 - ((assoc_thy "Isac.thy"), tac_, is, pos, pt);
140.337 - *)
140.338 - | generate1 thy (Take' t) l (p,p_) pt = (* val (Take' t) = m; *)
140.339 - let (*val _=writeln("### generate1: Take' pos="^pos'2str (p,p_));*)
140.340 - val p = let val (ps,p') = split_last p(*no connex to prev.ppobj*)
140.341 - in if p'=0 then ps@[1] else p end;
140.342 - val (pt,c) = cappend_form pt p l t;
140.343 - in ((p,Frm):pos', c,
140.344 - Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)), pt) end
140.345 -
140.346 -(* val (l, (p,p_)) = (RrlsState is, p);
140.347 -
140.348 - val (thy, Begin_Trans' t, l, (p,Frm), pt) =
140.349 - (assoc_thy "Isac.thy", tac_, is, p, pt);
140.350 - *)
140.351 - | generate1 thy (Begin_Trans' t) l (p,Frm) pt =
140.352 - let (* print_depth 99;
140.353 - map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3;
140.354 - *)
140.355 - val (pt,c) = cappend_form pt p l t
140.356 - (* print_depth 99;
140.357 - map fst (get_interval ([],Pbl) ([],Res) 9999 pt);print_depth 3;
140.358 - *)
140.359 - val pt = update_branch pt p TransitiveB (*040312*)
140.360 - (*replace the old PrfOjb ~~~~~*)
140.361 - val p = (lev_on o lev_dn(*starts with [...,0]*)) p;
140.362 - val (pt,c') = cappend_form pt p l t(*FIXME.0402 same istate ???*);
140.363 - in ((p,Frm), c @ c', Form' (FormKF (~1,EdUndef,(length p), Nundef,
140.364 - term2str t)), pt) end
140.365 -
140.366 - (* val (thy, Begin_Trans' t, l, (p,Res), pt) =
140.367 - (assoc_thy "Isac.thy", tac_, is, p, pt);
140.368 - *)
140.369 - | generate1 thy (Begin_Trans' t) l (p ,Res) pt =
140.370 - (*append after existing PrfObj _________*)
140.371 - generate1 thy (Begin_Trans' t) l (lev_on p,Frm) pt
140.372 -
140.373 - | generate1 thy (End_Trans' tasm) l (p,p_) pt =
140.374 - let val p' = lev_up p
140.375 - val (pt,c) = append_result pt p' l tasm Complete;
140.376 - in ((p',Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str t)),
140.377 - pt) end
140.378 -
140.379 - | generate1 thy (Rewrite_Inst' (_,_,_,_,subs',thm',f,(f',asm))) l (p,p_) pt =
140.380 - let (*val _= writeln("###generate1 Rewrite_Inst': pos= "^pos'2str (p,p_));*)
140.381 - val (pt,c) = cappend_atomic pt p l f
140.382 - (Rewrite_Inst (subst2subs subs',thm')) (f',asm) Complete;
140.383 - val pt = update_branch pt p TransitiveB (*040312*)
140.384 - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*)
140.385 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
140.386 - pt) end
140.387 -
140.388 - | generate1 thy (Rewrite' (thy',ord',rls',pa,thm',f,(f',asm))) l (p,p_) pt =
140.389 - let (*val _= writeln("###generate1 Rewrite': pos= "^pos'2str (p,p_))*)
140.390 - val (pt,c) = cappend_atomic pt p l f (Rewrite thm') (f',asm) Complete
140.391 - val pt = update_branch pt p TransitiveB (*040312*)
140.392 - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm);9.6.03??*)
140.393 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
140.394 - pt)end
140.395 -
140.396 - | generate1 thy (Rewrite_Asm' all) l p pt =
140.397 - generate1 thy (Rewrite' all) l p pt
140.398 -
140.399 - | generate1 thy (Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm))) l (p,p_) pt =
140.400 -(* val (thy, Rewrite_Set_Inst' (_,_,subs',rls',f,(f',asm)), l, (p,p_), pt) =
140.401 - (assoc_thy "Isac.thy", tac_, is, pos, pt);
140.402 - *)
140.403 - let (*val _=writeln("###generate1 Rewrite_Set_Inst': pos= "^pos'2str(p,p_))*)
140.404 - val (pt,c) = cappend_atomic pt p l f
140.405 - (Rewrite_Set_Inst (subst2subs subs',id_rls rls')) (f',asm) Complete
140.406 - val pt = update_branch pt p TransitiveB (*040312*)
140.407 - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*)
140.408 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
140.409 - pt) end
140.410 -
140.411 - | generate1 thy (Detail_Set_Inst' (_,_,subs,rls,f,(f',asm))) l (p,p_) pt =
140.412 - let val (pt,c) = cappend_form pt p l f
140.413 - val pt = update_branch pt p TransitiveB (*040312*)
140.414 -
140.415 - val is = init_istate (Rewrite_Set_Inst (subst2subs subs, id_rls rls)) f
140.416 - val tac_ = Apply_Method' (e_metID, SOME t, is)
140.417 - val pos' = ((lev_on o lev_dn) p, Frm)
140.418 - in (*implicit Take*) generate1 thy tac_ is pos' pt end
140.419 -
140.420 - | generate1 thy (Rewrite_Set' (_,_,rls',f,(f',asm))) l (p,p_) pt =
140.421 - let (*val _= writeln("###generate1 Rewrite_Set': pos= "^pos'2str (p,p_))*)
140.422 - val (pt,c) = cappend_atomic pt p l f
140.423 - (Rewrite_Set (id_rls rls')) (f',asm) Complete
140.424 - val pt = update_branch pt p TransitiveB (*040312*)
140.425 - (*val pt = union_asm pt (par_pblobj pt p) (map (rpair p) asm');9.6.03??*)
140.426 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
140.427 - pt) end
140.428 -
140.429 - | generate1 thy (Detail_Set' (_,_,rls,f,(f',asm))) l (p,p_) pt =
140.430 - let val (pt,c) = cappend_form pt p l f
140.431 - val pt = update_branch pt p TransitiveB (*040312*)
140.432 -
140.433 - val is = init_istate (Rewrite_Set (id_rls rls)) f
140.434 - val tac_ = Apply_Method' (e_metID, SOME t, is)
140.435 - val pos' = ((lev_on o lev_dn) p, Frm)
140.436 - in (*implicit Take*) generate1 thy tac_ is pos' pt end
140.437 -
140.438 - | generate1 thy (Check_Postcond' (pI,(scval,asm))) l (p,p_) pt =
140.439 - let (*val _=writeln("###generate1 Check_Postcond': pos= "^pos'2str(p,p_))*)
140.440 - (*val (l',_) = get_obj g_loc pt p..don't overwrite with l from subpbl*)
140.441 - val (pt,c) = append_result pt p l (scval,map str2term asm) Complete
140.442 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p),
140.443 - Nundef, term2str scval)), pt) end
140.444 -
140.445 - | generate1 thy (Calculate' (thy',op_,f,(f',thm'))) l (p,p_) pt =
140.446 - let val (pt,c) = cappend_atomic pt p l f (Calculate op_) (f',[]) Complete;
140.447 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
140.448 - pt) end
140.449 -
140.450 - | generate1 thy (Check_elementwise' (consts,pred,(f',asm))) l (p,p_) pt =
140.451 - let(*val _=writeln("###generate1 Check_elementwise': p= "^pos'2str(p,p_))*)
140.452 - val (pt,c) = cappend_atomic pt p l consts
140.453 - (Check_elementwise pred) (f',asm) Complete;
140.454 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, term2str f')),
140.455 - pt) end
140.456 -
140.457 - | generate1 thy (Or_to_List' (ors,list)) l (p,p_) pt =
140.458 - let val (pt,c) = cappend_atomic pt p l ors
140.459 - Or_to_List (list,[]) Complete;
140.460 - in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef, term2str list)),
140.461 - pt) end
140.462 -
140.463 - | generate1 thy (Substitute' (subte, t, t')) l (p,p_) pt =
140.464 - let val (pt,c) = cappend_atomic pt p l t (Substitute (subte2sube subte))
140.465 - (t',[]) Complete;
140.466 - in ((p,Res), c, Form' (FormKF(~1,EdUndef,(length p), Nundef,
140.467 - term2str t')), pt)
140.468 - end
140.469 -
140.470 - | generate1 thy (Tac_ (_,f,id,f')) l (p,p_) pt =
140.471 - let val (pt,c) = cappend_atomic pt p l (str2term f)
140.472 - (Tac id) (str2term f',[]) Complete;
140.473 - in ((p,Res), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f')), pt)end
140.474 -
140.475 - | generate1 thy (Subproblem' ((domID, pblID, metID), oris, hdl, fmz_, f))
140.476 - l (p,p_) pt =
140.477 - let (*val _=writeln("###generate1 Subproblem': pos= "^pos'2str (p,p_))*)
140.478 - val (pt,c) = cappend_problem pt p l (fmz_, (domID, pblID, metID))
140.479 - (oris, (domID, pblID, metID), hdl);
140.480 - (*val pbl = init_pbl ((#ppc o get_pbt) pblID);
140.481 - val pt = update_pblppc pt p pbl;--------4.9.03->Model_Problem*)
140.482 - (*val _= writeln("### generate1: is([3],Frm)= "^
140.483 - (istate2str (get_istate pt ([3],Frm))));*)
140.484 - val f = Syntax.string_of_term (thy2ctxt thy) f;
140.485 - in ((p,Pbl), c, Form' (FormKF (~1,EdUndef,(length p), Nundef, f)), pt) end
140.486 -
140.487 - | generate1 thy m' _ _ _ =
140.488 - raise error ("generate1: not impl.for "^(tac_2str m'))
140.489 -;
140.490 -
140.491 -
140.492 -fun generate_hard thy m' (p,p_) pt =
140.493 - let
140.494 - val p = case p_ of Frm => p | Res => lev_on p
140.495 - | _ => raise error ("generate_hard: call by "^(pos'2str (p,p_)));
140.496 - in generate1 thy m' e_istate (p,p_) pt end;
140.497 -
140.498 -
140.499 -
140.500 -(*tacis are in reverse order from nxt_solve_/specify_: last = fst to insert*)
140.501 -(* val (tacis, (pt, _)) = (tacis, ptp);
140.502 -
140.503 - val (tacis, (pt, c, _)) = (rev tacis, (pt, [], (p, Res)));
140.504 - *)
140.505 -fun generate ([]: taci list) ptp = ptp
140.506 - | generate tacis (pt, c, _:pos'(*!dropped!WN0504redesign generate/tacis?*))=
140.507 - let val (tacis', (_, tac_, (p, is))) = split_last tacis
140.508 - (* for recursion ...
140.509 - (tacis', (_, tac_, (p, is))) = split_last tacis';
140.510 - *)
140.511 - val (p',c',_,pt') = generate1 (assoc_thy "Isac.thy") tac_ is p pt
140.512 - in generate tacis' (pt', c@c', p') end;
140.513 -
140.514 -
140.515 -
140.516 -(*. a '_deriv'ation is constructed during 'reverse rewring' by an Rrls *
140.517 - * of for connecting a user-input formula with the current calc-state. *
140.518 - *# It is somewhat incompatible with the rest of the math-engine: *
140.519 - * (1) it is not created by a script *
140.520 - * (2) thus there cannot be another user-input within a derivation *
140.521 - *# It suffers particularily from the not-well-foundedness of the math-engine*
140.522 - * (1) FIXME other branchtyptes than Transitive will change 'embed_deriv' *
140.523 - * (2) FIXME and eventually 'compare_step' (ie. the script interpreter) *
140.524 - * (3) FIXME and eventually 'lev_back' *
140.525 - *# SOME improvements are evident FIXME.040215 '_deriv'ation: *
140.526 - * (1) FIXME nest Rls_ in 'make_deriv' *
140.527 - * (2) FIXME do the not-reversed part in 'make_deriv' by scripts -- thus *
140.528 - * user-input will become possible in this part of a derivation *
140.529 - * (3) FIXME do (2) only if a derivation has been found -- for efficiency, *
140.530 - * while a non-derivable inform requires to step until End_Proof' *
140.531 - * (4) FIXME find criteria on when _not_ to step until End_Proof' *
140.532 - * (5) FIXME
140.533 -.*)
140.534 -(*.update pos in tacis for embedding by generate.*)
140.535 -(* val
140.536 - *)
140.537 -fun insert_pos _ [] = []
140.538 - | insert_pos (p:pos) (((tac,tac_,(_, ist))::tacis):taci list) =
140.539 - ((tac,tac_,((p, Res), ist)):taci)
140.540 - ::((insert_pos (lev_on p) tacis):taci list);
140.541 -
140.542 -fun res_from_taci (_, Rewrite'(_,_,_,_,_,_,(res, asm)), _) = (res, asm)
140.543 - | res_from_taci (_, Rewrite_Set'(_,_,_,_,(res, asm)), _) = (res, asm)
140.544 - | res_from_taci (_, tac_, _) =
140.545 - raise error ("res_from_taci: called with" ^ tac_2str tac_);
140.546 -
140.547 -(*.embed the tacis created by a '_deriv'ation; sys.form <> input.form
140.548 - tacis are in order, thus are reverted for generate.*)
140.549 -(* val (tacis, (pt, pos as (p, Frm))) = (tacis', ptp);
140.550 - *)
140.551 -fun embed_deriv (tacis:taci list) (pt, pos as (p, Frm):pos') =
140.552 - (*inform at Frm: replace the whole PrfObj by a Transitive-ProfObj FIXME?0402
140.553 - and transfer the istate (from _after_ compare_deriv) from Frm to Res*)
140.554 - let val (res, asm) = (res_from_taci o last_elem) tacis
140.555 - val (SOME ist,_) = get_obj g_loc pt p
140.556 - val form = get_obj g_form pt p
140.557 - (*val p = lev_on p; ---------------only difference to (..,Res) below*)
140.558 - val tacis = (Begin_Trans, Begin_Trans' form, (pos, Uistate))
140.559 - ::(insert_pos ((lev_on o lev_dn) p) tacis)
140.560 - @ [(End_Trans, End_Trans' (res, asm),
140.561 - (pos_plus (length tacis) (lev_dn p, Res),
140.562 - new_val res ist))]
140.563 - val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p))
140.564 - val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res))
140.565 - val pt = update_tac pt p (Derive (id_rls nrls))
140.566 - (*FIXME.040216 struct.ctree*)
140.567 - val pt = update_branch pt p TransitiveB
140.568 - in (c, (pt, pos:pos')) end
140.569 -
140.570 -(* val (tacis, (pt, (p, Res))) = (tacis', ptp);
140.571 - *)
140.572 - | embed_deriv tacis (pt, (p, Res)) =
140.573 - (*inform at Res: append a Transitive-PrfObj FIXME?0402 other branch-types ?
140.574 - and transfer the istate (from _after_ compare_deriv) from Res to new Res*)
140.575 - let val (res, asm) = (res_from_taci o last_elem) tacis
140.576 - val (_, SOME ist) = get_obj g_loc pt p
140.577 - val (f,a) = get_obj g_result pt p
140.578 - val p = lev_on p(*---------------only difference to (..,Frm) above*);
140.579 - val tacis = (Begin_Trans, Begin_Trans' f, ((p, Frm), Uistate))
140.580 - ::(insert_pos ((lev_on o lev_dn) p) tacis)
140.581 - @ [(End_Trans, End_Trans' (res, asm),
140.582 - (pos_plus (length tacis) (lev_dn p, Res),
140.583 - new_val res ist))];
140.584 - val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p))
140.585 - val (pt, c, pos as (p,_)) = generate (rev tacis) (pt, [], (p, Res))
140.586 - val pt = update_tac pt p (Derive (id_rls nrls))
140.587 - (*FIXME.040216 struct.ctree*)
140.588 - val pt = update_branch pt p TransitiveB
140.589 - in (c, (pt, pos)) end;
141.1 --- a/src/Tools/isac/ME/inform.sml Wed Aug 25 15:15:01 2010 +0200
141.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
141.3 @@ -1,734 +0,0 @@
141.4 -(* Handle user-input during the specify- and the solve-phase.
141.5 - author: Walther Neuper
141.6 - 0603
141.7 - (c) due to copyright terms
141.8 -
141.9 -use"ME/inform.sml";
141.10 -use"inform.sml";
141.11 -*)
141.12 -
141.13 -signature INFORM =
141.14 - sig
141.15 -
141.16 - type castab
141.17 - type icalhd
141.18 -
141.19 - (* type iitem *)
141.20 - datatype
141.21 - iitem =
141.22 - Find of cterm' list
141.23 - | Given of cterm' list
141.24 - | Relate of cterm' list
141.25 - type imodel
141.26 - val imodel2fstr : iitem list -> (string * cterm') list
141.27 -
141.28 -
141.29 - val Isac : 'a -> theory
141.30 - val appl_add' :
141.31 - theory' ->
141.32 - SpecifyTools.ori list ->
141.33 - SpecifyTools.itm list ->
141.34 - ('a * (Term.term * Term.term)) list ->
141.35 - string * cterm' -> SpecifyTools.itm
141.36 - (* val appl_adds :
141.37 - theory' ->
141.38 - SpecifyTools.ori list ->
141.39 - SpecifyTools.itm list ->
141.40 - (string * (Term.term * Term.term)) list ->
141.41 - (string * string) list -> SpecifyTools.itm list *)
141.42 - (* val cas_input : string -> ptree * ocalhd *)
141.43 - (* val cas_input_ :
141.44 - spec ->
141.45 - (Term.term * Term.term list) list ->
141.46 - pblID * SpecifyTools.itm list * metID * SpecifyTools.itm list *
141.47 - (bool * Term.term) list *)
141.48 - val castab : castab ref
141.49 - val compare_step :
141.50 - calcstate' -> Term.term -> string * calcstate'
141.51 - (* val concat_deriv :
141.52 - 'a * ((Term.term * Term.term) list -> Term.term * Term.term -> bool)
141.53 - ->
141.54 - rls ->
141.55 - rule list ->
141.56 - Term.term ->
141.57 - Term.term ->
141.58 - bool * (Term.term * rule * (Term.term * Term.term list)) list *)
141.59 - val dropwhile' : (* systest/auto-inform.sml *)
141.60 - ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
141.61 - (* val dtss2itm_ :
141.62 - pbt_ list ->
141.63 - Term.term * Term.term list ->
141.64 - int list * bool * string * SpecifyTools.itm_ *)
141.65 - (* val e_icalhd : icalhd *)
141.66 - val eq7 : ''a * ''b -> ''a * (''b * 'c) -> bool
141.67 - val equal : ''a -> ''a -> bool
141.68 - (* val filter_dsc :
141.69 - SpecifyTools.ori list -> SpecifyTools.itm -> SpecifyTools.ori list *)
141.70 - (* val filter_sep : ('a -> bool) -> 'a list -> 'a list * 'a list *)
141.71 - (* val flattup2 : 'a * ('b * 'c * 'd * 'e) -> 'a * 'b * 'c * 'd * 'e *)
141.72 - (* val fstr2itm_ :
141.73 - theory ->
141.74 - (''a * (Term.term * Term.term)) list ->
141.75 - ''a * string -> int list * bool * ''a * SpecifyTools.itm_ *)
141.76 - val inform :
141.77 - calcstate' -> cterm' -> string * calcstate'
141.78 - val input_icalhd : ptree -> icalhd -> ptree * ocalhd
141.79 - (* val is_Par : SpecifyTools.itm -> bool *)
141.80 - (* val is_casinput : cterm' -> fmz -> bool *)
141.81 - (* val is_e_ts : Term.term list -> bool *)
141.82 - (* val itms2fstr : SpecifyTools.itm -> string * string *)
141.83 - (* val mk_tacis :
141.84 - rew_ord' * 'a ->
141.85 - rls ->
141.86 - Term.term * rule * (Term.term * Term.term list) ->
141.87 - tac * tac_ * (pos' * istate) *)
141.88 - val oris2itms :
141.89 - 'a -> int -> SpecifyTools.ori list -> SpecifyTools.itm list
141.90 - (* val par2fstr : SpecifyTools.itm -> string * cterm' *)
141.91 - (* val parsitm : theory -> SpecifyTools.itm -> SpecifyTools.itm *)
141.92 - val rev_deriv' : 'a * rule * ('b * 'c) -> 'b * rule * ('a * 'c)
141.93 - (* val unknown_expl :
141.94 - theory' ->
141.95 - (string * (Term.term * Term.term)) list ->
141.96 - (string * string) list -> SpecifyTools.itm list *)
141.97 - end
141.98 -
141.99 -
141.100 -
141.101 -
141.102 -
141.103 -
141.104 -(***. handle an input calc-head .***)
141.105 -
141.106 -(*------------------------------------------------------------------(**)
141.107 -structure inform :INFORM =
141.108 -struct
141.109 -(**)------------------------------------------------------------------*)
141.110 -
141.111 -datatype iitem =
141.112 - Given of cterm' list
141.113 -(*Where is never input*)
141.114 -| Find of cterm' list
141.115 -| Relate of cterm' list;
141.116 -
141.117 -type imodel = iitem list;
141.118 -
141.119 -(*calc-head as input*)
141.120 -type icalhd =
141.121 - pos' * (*the position of the calc-head in the calc-tree
141.122 - pos' as (p,p_) where p_ is neglected due to pos_ below*)
141.123 - cterm' * (*the headline*)
141.124 - imodel * (*the model (without Find) of the calc-head*)
141.125 - pos_ * (*model belongs to Pbl or Met*)
141.126 - spec; (*specification: domID, pblID, metID*)
141.127 -val e_icalhd = (e_pos', "", [Given [""]], Pbl, e_spec): icalhd;
141.128 -
141.129 -fun is_casinput (hdf: cterm') ((fmz_, spec): fmz) =
141.130 - hdf <> "" andalso fmz_ = [] andalso spec = e_spec;
141.131 -
141.132 -(*.handle an input as into an algebra system.*)
141.133 -fun dtss2itm_ ppc (d, ts) =
141.134 - let val (f, (d, id)) = the (find_first ((curry op= d) o
141.135 - (#1: (term * term) -> term) o
141.136 - (#2: pbt_ -> (term * term))) ppc)
141.137 - in ([1], true, f, Cor ((d, ts), (id, ts))) end;
141.138 -
141.139 -fun flattup2 (a,(b,c,d,e)) = (a,b,c,d,e);
141.140 -
141.141 -
141.142 -
141.143 -(*.association list with cas-commands, for generating a complete calc-head.*)
141.144 -type castab =
141.145 - (term * (*cas-command, eg. 'solve'*)
141.146 - (spec * (*theory, problem, method*)
141.147 -
141.148 - (*the function generating a kind of formalization*)
141.149 - (term list -> (*the arguments of the cas-command, eg. (x+1=2, x)*)
141.150 - (term * (*description of an element*)
141.151 - term list) (*value of the element (always put into a list)*)
141.152 - list))) (*of elements in the formalization*)
141.153 - list; (*of cas-entries in the association list*)
141.154 -
141.155 -val castab = ref ([]: castab);
141.156 -
141.157 -
141.158 -(*..*)
141.159 -(* val (dI,pI,mI) = spec;
141.160 - *)
141.161 -(*fun cas_input_ ((dI,pI,mI): spec) dtss =
141.162 - let val thy = assoc_thy dI
141.163 - val {ppc,...} = get_pbt pI
141.164 - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
141.165 - val its = add_id its_
141.166 - val pits = map flattup2 its
141.167 - val (pI, mI) = if mI <> ["no_met"] then (pI, mI)
141.168 - else let val SOME (pI,_) = refine_pbl thy pI pits
141.169 - in (pI, (hd o #met o get_pbt) pI) end
141.170 - val {ppc,pre,prls,...} = get_met mI
141.171 - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
141.172 - val its = add_id its_
141.173 - val mits = map flattup2 its
141.174 - val pre = check_preconds thy prls pre mits
141.175 -in (pI, pits: itm list, mI, mits: itm list, pre) end;*)
141.176 -
141.177 -(* val (dI,pI,mI) = spec;
141.178 - *)
141.179 -fun cas_input_ ((dI,pI,mI): spec) dtss =
141.180 - let val thy = assoc_thy dI
141.181 - val {ppc,...} = get_pbt pI
141.182 - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
141.183 - val its = add_id its_
141.184 - val pits = map flattup2 its
141.185 - val (pI, mI) = if mI <> ["no_met"] then (pI, mI)
141.186 - else case refine_pbl thy pI pits of
141.187 - SOME (pI,_) => (pI, (hd o #met o get_pbt) pI)
141.188 - | NONE => (pI, (hd o #met o get_pbt) pI)
141.189 - val {ppc,pre,prls,...} = get_met mI
141.190 - val its_ = map (dtss2itm_ ppc) dtss (*([1],true,"#Given",Cor (...))*)
141.191 - val its = add_id its_
141.192 - val mits = map flattup2 its
141.193 - val pre = check_preconds thy prls pre mits
141.194 -in (pI, pits: itm list, mI, mits: itm list, pre) end;
141.195 -
141.196 -
141.197 -(*.check if the input term is a CAScmd and return a ptree with
141.198 - a _complete_ calchead.*)
141.199 -(* val hdt = ifo;
141.200 - *)
141.201 -fun cas_input hdt =
141.202 - let val (h,argl) = strip_comb hdt
141.203 - in case assoc (!castab, h) of
141.204 - NONE => NONE
141.205 - (*let val (pt,_) =
141.206 - cappend_problem e_ptree [] e_istate
141.207 - ([], e_spec) ([], e_spec, e_term)
141.208 - in (pt, (false, Pbl, e_term(*FIXXME031:'not found'*),
141.209 - [], [], e_spec)) end*)
141.210 - | SOME (spec as (dI,_,_), argl2dtss) =>
141.211 - (* val SOME (spec as (dI,_,_), argl2dtss ) = assoc (!castab, h);
141.212 - *)
141.213 - let val dtss = argl2dtss argl
141.214 - val (pI, pits, mI, mits, pre) = cas_input_ spec dtss
141.215 - val spec = (dI, pI, mI)
141.216 - val (pt,_) =
141.217 - cappend_problem e_ptree [] e_istate ([], e_spec)
141.218 - ([], e_spec, hdt)
141.219 - val pt = update_spec pt [] spec
141.220 - val pt = update_pbl pt [] pits
141.221 - val pt = update_met pt [] mits
141.222 - in SOME (pt, (true, Met, hdt, mits, pre, spec):ocalhd) end
141.223 - end;
141.224 -
141.225 -(*lazy evaluation for Isac.thy*)
141.226 -fun Isac _ = assoc_thy "Isac.thy";
141.227 -
141.228 -(*re-parse itms with a new thy and prepare for checking with ori list*)
141.229 -fun parsitm dI (itm as (i,v,b,f, Cor ((d,ts),_)):itm) =
141.230 -(* val itm as (i,v,b,f, Cor ((d,ts),_)) = hd probl;
141.231 - *)
141.232 - (let val t = (comp_dts (Isac "delay")) (d,ts);
141.233 - val s = Syntax.string_of_term (thy2ctxt dI) t;
141.234 - (*this ^ should raise the exn on unability of re-parsing dts*)
141.235 - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
141.236 - | parsitm dI (itm as (i,v,b,f, Syn str)) =
141.237 - (let val t = (term_of o the o (parse dI)) str
141.238 - in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str))
141.239 - | parsitm dI (itm as (i,v,b,f, Typ str)) =
141.240 - (let val t = (term_of o the o (parse dI)) str
141.241 - in (i,v,b,f, Par str) end handle _ => (i,v,b,f, Syn str))
141.242 - | parsitm dI (itm as (i,v,_,f, Inc ((d,ts),_))) =
141.243 - (let val t = (comp_dts (Isac "delay")) (d,ts);
141.244 - val s = Syntax.string_of_term (thy2ctxt dI) t;
141.245 - (*this ^ should raise the exn on unability of re-parsing dts*)
141.246 - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
141.247 - | parsitm dI (itm as (i,v,_,f, Sup (d,ts))) =
141.248 - (let val t = (comp_dts (Isac"delay" )) (d,ts);
141.249 - val s = Syntax.string_of_term (thy2ctxt dI) t;
141.250 - (*this ^ should raise the exn on unability of re-parsing dts*)
141.251 - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
141.252 - | parsitm dI (itm as (i,v,_,f, Mis (d,t'))) =
141.253 - (let val t = d $ t';
141.254 - val s = Syntax.string_of_term (thy2ctxt dI) t;
141.255 - (*this ^ should raise the exn on unability of re-parsing dts*)
141.256 - in itm end handle _ => ((i,v,false,f, Syn (term2str t)):itm))
141.257 - | parsitm dI (itm as (i,v,_,f, Par _)) =
141.258 - raise error ("parsitm (" ^ itm2str_ (thy2ctxt dI) itm^
141.259 - "): Par should be internal");
141.260 -
141.261 -(*separate a list to a pair of elements that do NOT satisfy the predicate,
141.262 - and of elements that satisfy the predicate, i.e. (false, true)*)
141.263 -fun filter_sep pred xs =
141.264 - let fun filt ab [] = ab
141.265 - | filt (a,b) (x :: xs) = if pred x
141.266 - then filt (a,b@[x]) xs
141.267 - else filt (a@[x],b) xs
141.268 - in filt ([],[]) xs end;
141.269 -fun is_Par ((_,_,_,_,Par _):itm) = true
141.270 - | is_Par _ = false;
141.271 -
141.272 -fun is_e_ts [] = true
141.273 - | is_e_ts [Const ("List.list.Nil", _)] = true
141.274 - | is_e_ts _ = false;
141.275 -
141.276 -(*WN.9.11.03 copied from fun appl_add (in modspec.sml)*)
141.277 -(* val (sel,ct) = selct;
141.278 - val (dI, oris, ppc, pbt, (sel, ct))=
141.279 - (#1 (some_spec ospec spec), oris, []:itm list,
141.280 - ((#ppc o get_pbt) (#2 (some_spec ospec spec))),
141.281 - hd (imodel2fstr imodel));
141.282 - *)
141.283 -fun appl_add' dI oris ppc pbt (sel, ct) =
141.284 - let
141.285 - val thy = assoc_thy dI;
141.286 - in case parse thy ct of
141.287 - NONE => (0,[],false,sel, Syn ct):itm
141.288 - | SOME ct => (* val SOME ct = parse thy ct;
141.289 - *)
141.290 - (case is_known thy sel oris (term_of ct) of
141.291 - (* val ("",ori'(*ts='ct'*), all) = is_known thy sel oris (term_of ct);
141.292 - *)
141.293 - ("",ori'(*ts='ct'*), all) =>
141.294 - (case is_notyet_input thy ppc all ori' pbt of
141.295 - (* val ("",itm) = is_notyet_input thy ppc all ori' pbt;
141.296 - *)
141.297 - ("",itm) => itm
141.298 - (* val (msg,xx) = is_notyet_input thy ppc all ori' pbt;
141.299 - *)
141.300 - | (msg,_) => raise error ("appl_add': "^msg))
141.301 - (* val (msg,(_,_,_,d,ts),all) = is_known thy sel oris (term_of ct);
141.302 - *)
141.303 - | (msg,(i,v,_,d,ts),_) =>
141.304 - if is_e_ts ts then (i,v,false, sel, Inc ((d,ts),(e_term,[])))
141.305 - else (i,v,false,sel, Sup (d,ts)))
141.306 - end;
141.307 -
141.308 -(*.generate preliminary itm_ from a strin (with field "#Given" etc.).*)
141.309 -(* val (f, str) = hd selcts;
141.310 - *)
141.311 -fun eq7 (f, d) (f', (d', _)) = f=f' andalso d=d';
141.312 -fun fstr2itm_ thy pbt (f, str) =
141.313 - let val topt = parse thy str
141.314 - in case topt of
141.315 - NONE => ([], false, f, Syn str)
141.316 - | SOME ct =>
141.317 -(* val SOME ct = parse thy str;
141.318 - *)
141.319 - let val (d,ts) = ((split_dts thy) o term_of) ct
141.320 - val popt = find_first (eq7 (f,d)) pbt
141.321 - in case popt of
141.322 - NONE => ([1](*??*), true(*??*), f, Sup (d,ts))
141.323 - | SOME (f, (d, id)) => ([1], true, f, Cor ((d,ts), (id, ts)))
141.324 - end
141.325 - end;
141.326 -
141.327 -
141.328 -(*.input into empty PblObj, i.e. empty fmz+origin (unknown example).*)
141.329 -fun unknown_expl dI pbt selcts =
141.330 - let
141.331 - val thy = assoc_thy dI
141.332 - val its_ = map (fstr2itm_ thy pbt) selcts (*([1],true,"#Given",Cor (...))*)
141.333 - val its = add_id its_
141.334 -in (map flattup2 its): itm list end;
141.335 -
141.336 -
141.337 -
141.338 -
141.339 -(*WN.11.03 for input_icalhd, ~ specify_additem for Add_Given/_Find/_Relation
141.340 - appl_add': generate 1 item
141.341 - appl_add' . is_known: parse, get data from oris (vats, all (elems if list)..)
141.342 - appl_add' . is_notyet_input: compare with items in model already input
141.343 - insert_ppc': insert this 1 item*)
141.344 -(* val (dI,oris,ppc,pbt,selcts) =((#1 (some_spec ospec spec)),oris,[(*!!*)],
141.345 - ((#ppc o get_pbt) (#2 (some_spec ospec spec))),
141.346 - (imodel2fstr imodel));
141.347 - *)
141.348 -fun appl_adds dI [] _ pbt selcts = unknown_expl dI pbt selcts
141.349 - (*already present itms in model are being overwritten*)
141.350 - | appl_adds dI oris ppc pbt [] = ppc
141.351 - | appl_adds dI oris ppc pbt (selct::ss) =
141.352 - (* val selct = (sel, string_of_cterm ct);
141.353 - *)
141.354 - let val itm = appl_add' dI oris ppc pbt selct;
141.355 - in appl_adds dI oris (insert_ppc' itm ppc) pbt ss end;
141.356 -(* val (dI, oris, ppc, pbt, selct::ss) =
141.357 - (dI, pors, probl, ppc, map itms2fstr probl);
141.358 - ...vvv
141.359 - *)
141.360 -(* val (dI, oris, ppc, pbt, (selct::ss))=
141.361 - (#1 (some_spec ospec spec), oris, []:itm list,
141.362 - ((#ppc o get_pbt) (#2 (some_spec ospec spec))),(imodel2fstr imodel));
141.363 - val iii = appl_adds dI oris ppc pbt (selct::ss);
141.364 - writeln(itms2str_ thy iii);
141.365 -
141.366 - val itm = appl_add' dI oris ppc pbt selct;
141.367 - val ppc = insert_ppc' itm ppc;
141.368 -
141.369 - val _::selct::ss = (selct::ss);
141.370 - val itm = appl_add' dI oris ppc pbt selct;
141.371 - val ppc = insert_ppc' itm ppc;
141.372 -
141.373 - val _::selct::ss = (selct::ss);
141.374 - val itm = appl_add' dI oris ppc pbt selct;
141.375 - val ppc = insert_ppc' itm ppc;
141.376 - writeln(itms2str_ thy ppc);
141.377 -
141.378 - val _::selct::ss = (selct::ss);
141.379 - val itm = appl_add' dI oris ppc pbt selct;
141.380 - val ppc = insert_ppc' itm ppc;
141.381 - *)
141.382 -
141.383 -
141.384 -fun oris2itms _ _ ([]:ori list) = ([]:itm list)
141.385 - | oris2itms pbt vat ((i,v,f,d,ts)::(os: ori list)) =
141.386 - if member op = vat v
141.387 - then (i,v,true,f,Cor ((d,ts),(e_term,[])))::(oris2itms pbt vat os)
141.388 - else oris2itms pbt vat os;
141.389 -
141.390 -fun filter_dsc oris itm =
141.391 - filter_out ((curry op= ((d_in o #5) (itm:itm))) o
141.392 - (#4:ori -> term)) oris;
141.393 -
141.394 -
141.395 -
141.396 -
141.397 -fun par2fstr ((_,_,_,f, Par s):itm) = (f, s)
141.398 - | par2fstr itm = raise error ("par2fstr: called with " ^
141.399 - itm2str_ (thy2ctxt' "Isac") itm);
141.400 -fun itms2fstr ((_,_,_,f, Cor ((d,ts),_)):itm) = (f, comp_dts'' (d,ts))
141.401 - | itms2fstr (_,_,_,f, Syn str) = (f, str)
141.402 - | itms2fstr (_,_,_,f, Typ str) = (f, str)
141.403 - | itms2fstr (_,_,_,f, Inc ((d,ts),_)) = (f, comp_dts'' (d,ts))
141.404 - | itms2fstr (_,_,_,f, Sup (d,ts)) = (f, comp_dts'' (d,ts))
141.405 - | itms2fstr (_,_,_,f, Mis (d,t)) = (f, term2str (d $ t))
141.406 - | itms2fstr (itm as (_,_,_,f, Par _)) =
141.407 - raise error ("parsitm ("^itm2str_ (thy2ctxt' "Isac") itm ^
141.408 - "): Par should be internal");
141.409 -
141.410 -fun imodel2fstr iitems =
141.411 - let fun xxx is [] = is
141.412 - | xxx is ((Given strs)::iis) =
141.413 - xxx (is @ (map (pair "#Given") strs)) iis
141.414 - | xxx is ((Find strs)::iis) =
141.415 - xxx (is @ (map (pair "#Find") strs)) iis
141.416 - | xxx is ((Relate strs)::iis) =
141.417 - xxx (is @ (map (pair "#Relate") strs)) iis
141.418 - in xxx [] iitems end;
141.419 -
141.420 -(*.input a CAS-command via a whole calchead;
141.421 - dWN0602 ropped due to change of design in the front-end.*)
141.422 -(*since previous calc-head _only_ has changed:
141.423 - EITHER _1_ part of the specification OR some items in the model;
141.424 - the hdform is left as is except in cas_input .*)
141.425 -(*FIXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX___Met___XXXXXXXXXXXME.TODO.WN:11.03*)
141.426 -(* val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) =
141.427 - (p, "xxx", empty_model, Pbl, e_spec);
141.428 - val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) =
141.429 - (p,"", [Given ["fixedValues [r=Arbfix]"],
141.430 - Find ["maximum A", "valuesFor [a,b]"],
141.431 - Relate ["relations [A=a*b, a/2=r*sin alpha, \
141.432 - \b/2=r*cos alpha]"]], Pbl, e_spec);
141.433 - val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) =
141.434 - (([],Pbl), "not used here",
141.435 - [Given ["fixedValues [r=Arbfix]"],
141.436 - Find ["maximum A", "valuesFor [a,b]"(*new input*)],
141.437 - Relate ["relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]"]], Pbl,
141.438 - ("DiffApp.thy", ["e_pblID"], ["e_metID"]));
141.439 - val ((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)) = ichd;
141.440 - *)
141.441 -fun input_icalhd pt (((p,_), hdf, imodel, Pbl, spec as (dI,pI,mI)):icalhd) =
141.442 - let val PblObj {fmz = fmz as (fmz_,_), origin = (oris, ospec, hdf'),
141.443 - spec = sspec as (sdI,spI,smI), probl, meth,...} =
141.444 - get_obj I pt p;
141.445 - in if is_casinput hdf fmz then the (cas_input (str2term hdf))
141.446 - else (*hacked WN0602 ~~~ ~~~~~~~~~, ..dropped !*)
141.447 - let val (pos_, pits, mits) =
141.448 - if dI <> sdI
141.449 - then let val its = map (parsitm (assoc_thy dI)) probl;
141.450 - val (its, trms) = filter_sep is_Par its;
141.451 - val pbt = (#ppc o get_pbt) (#2(some_spec ospec sspec));
141.452 - in (Pbl, appl_adds dI oris its pbt
141.453 - (map par2fstr trms), meth) end else
141.454 - if pI <> spI
141.455 - then if pI = snd3 ospec then (Pbl, probl, meth) else
141.456 - let val pbt = (#ppc o get_pbt) pI
141.457 - val dI' = #1 (some_spec ospec spec)
141.458 - val oris = if pI = #2 ospec then oris
141.459 - else prep_ori fmz_(assoc_thy"Isac.thy") pbt;
141.460 - in (Pbl, appl_adds dI' oris probl pbt
141.461 - (map itms2fstr probl), meth) end else
141.462 - if mI <> smI (*FIXME.WN0311: what if probl is incomplete?!*)
141.463 - then let val met = (#ppc o get_met) mI
141.464 - val mits = complete_metitms oris probl meth met
141.465 - in if foldl and_ (true, map #3 mits)
141.466 - then (Pbl, probl, mits) else (Met, probl, mits)
141.467 - end else
141.468 - (Pbl, appl_adds (#1 (some_spec ospec spec)) oris [(*!!!*)]
141.469 - ((#ppc o get_pbt) (#2 (some_spec ospec spec)))
141.470 - (imodel2fstr imodel), meth);
141.471 - val pt = update_spec pt p spec;
141.472 - in if pos_ = Pbl
141.473 - then let val {prls,where_,...} = get_pbt (#2 (some_spec ospec spec))
141.474 - val pre =check_preconds(assoc_thy"Isac.thy")prls where_ pits
141.475 - in (update_pbl pt p pits,
141.476 - (ocalhd_complete pits pre spec,
141.477 - Pbl, hdf', pits, pre, spec):ocalhd) end
141.478 - else let val {prls,pre,...} = get_met (#3 (some_spec ospec spec))
141.479 - val pre = check_preconds (assoc_thy"Isac.thy") prls pre mits
141.480 - in (update_met pt p mits,
141.481 - (ocalhd_complete mits pre spec,
141.482 - Met, hdf', mits, pre, spec):ocalhd) end
141.483 - end end
141.484 - | input_icalhd pt ((p,_), hdf, imodel, _(*Met*), spec as (dI,pI,mI)) =
141.485 - raise error "input_icalhd Met not impl.";
141.486 -
141.487 -
141.488 -(***. handle an input formula .***)
141.489 -(*
141.490 -Untersuchung zur Formeleingabe (appendFormula, replaceFormla) zu einer Anregung von Alan Krempler:
141.491 -Welche RICHTIGEN Formeln koennen NICHT abgeleitet werden,
141.492 -wenn Abteilungen nur auf gleichem Level gesucht werden ?
141.493 -WN.040216
141.494 -
141.495 -Beispiele zum Equationsolver von Richard Lang aus /src/sml/kbtest/rlang.sml
141.496 -
141.497 -------------------------------------------------------------------------------
141.498 -"Schalk I s.87 Bsp 52a ((5*x)/(x - 2) - x/(x+2)=4)";
141.499 -------------------------------------------------------------------------------
141.500 -1. "5 * x / (x - 2) - x / (x + 2) = 4"
141.501 -...
141.502 -4. "12 * x + 4 * x ^^^ 2 = 4 * (-4 + x ^^^ 2)",Subproblem["normalize", "poly"..
141.503 -...
141.504 -4.3. "16 + 12 * x = 0", Subproblem["degree_1", "polynomial", "univariate"..
141.505 -...
141.506 -4.3.3. "[x = -4 / 3]")), Check_elementwise "Assumptions"
141.507 -...
141.508 -"[x = -4 / 3]"
141.509 -------------------------------------------------------------------------------
141.510 -(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n]
141.511 -
141.512 -(4.1)..(4.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 4.3.n]
141.513 -------------------------------------------------------------------------------
141.514 -
141.515 -
141.516 -------------------------------------------------------------------------------
141.517 -"Schalk I s.87 Bsp 55b (x/(x^^^2 - 6*x+9) - 1/(x^^^2 - 3*x) =1/x)";
141.518 -------------------------------------------------------------------------------
141.519 -1. "x / (x ^^^ 2 - 6 * x + 9) - 1 / (x ^^^ 2 - 3 * x) = 1 / x"
141.520 -...
141.521 -4. "(3 + (-1 * x + x ^^^ 2)) * x = 1 * (9 * x + (x ^^^ 3 + -6 * x ^^^ 2))"
141.522 - Subproblem["normalize", "polynomial", "univariate"..
141.523 -...
141.524 -4.4. "-6 * x + 5 * x ^^^ 2 = 0", Subproblem["bdv_only", "degree_2", "poly"..
141.525 -...
141.526 -4.4.4. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions"
141.527 -4.4.5. "[x = 0, x = 6 / 5]"
141.528 -...
141.529 -5. "[x = 0, x = 6 / 5]", Check_elementwise "Assumptions"
141.530 - "[x = 6 / 5]"
141.531 -------------------------------------------------------------------------------
141.532 -(1)..(4): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite schiebt [Ableitung waere in 4.4.x]
141.533 -
141.534 -(4.1)..(4.4.5): keine 'richtige' Eingabe kann abgeleitet werden, die dem Ergebnis "[x = 6 / 5]" aequivalent ist [Ableitung waere in 5.]
141.535 -------------------------------------------------------------------------------
141.536 -
141.537 -
141.538 -------------------------------------------------------------------------------
141.539 -"Schalk II s.56 Bsp 73b (sqrt(x+1)+sqrt(4*x+4)=sqrt(9*x+9))";
141.540 -------------------------------------------------------------------------------
141.541 -1. "sqrt (x + 1) + sqrt (4 * x + 4) = sqrt (9 * x + 9)"
141.542 -...
141.543 -6. "13 + 13 * x + -2 * sqrt ((4 + 4 * x) * (9 + 9 * x)) = 1 + x"
141.544 - Subproblem["sq", "root", "univariate", "equation"]
141.545 -...
141.546 -6.6. "144 + 288 * x + 144 * x ^^^ 2 = 144 + x ^^^ 2 + 288 * x + 143 * x ^^^ 2"
141.547 - Subproblem["normalize", "polynomial", "univariate", "equation"]
141.548 -...
141.549 -6.6.3 "0 = 0" Subproblem["degree_0", "polynomial", "univariate", "equation"]
141.550 -... Or_to_List
141.551 -6.6.3.2 "UniversalList"
141.552 -------------------------------------------------------------------------------
141.553 -(1)..(6): keine 'richtige' Eingabe kann abgeleitet werden, die eine der Wurzeln auf die andere Seite verschieb [Ableitung ware in 6.6.n]
141.554 -
141.555 -(6.1)..(6.3): keine 'richtige' Eingabe kann abgeleitet werden, die einen Summanden auf die andere Seite verschiebt [Ableitung ware in 6.6.n]
141.556 -------------------------------------------------------------------------------
141.557 -*)
141.558 -(*sh. comments auf 498*)
141.559 -
141.560 -fun equal a b = a=b;
141.561 -
141.562 -(*the lists contain eq-al elem-pairs at the beginning;
141.563 - return first list reverted (again) - ie. in order as required subsequently*)
141.564 -fun dropwhile' equal (f1::f2::fs) (i1::i2::is) =
141.565 - if equal f1 i1 then
141.566 - if equal f2 i2 then dropwhile' equal (f2::fs) (i2::is)
141.567 - else (rev (f1::f2::fs), i1::i2::is)
141.568 - else raise error "dropwhile': did not start with equal elements"
141.569 - | dropwhile' equal (f::fs) [i] =
141.570 - if equal f i then (rev (f::fs), [i])
141.571 - else raise error "dropwhile': did not start with equal elements"
141.572 - | dropwhile' equal [f] (i::is) =
141.573 - if equal f i then ([f], i::is)
141.574 - else raise error "dropwhile': did not start with equal elements";
141.575 -(*
141.576 - fun equal a b = a=b;
141.577 - val foder = [0,1,2,3,4,5]; val ifoder = [11,12,3,4,5];
141.578 - val r_foder = rev foder; val r_ifoder = rev ifoder;
141.579 - dropwhile' equal r_foder r_ifoder;
141.580 -> vval it = ([0, 1, 2, 3], [3, 12, 11]) : int list * int list
141.581 -
141.582 - val foder = [3,4,5]; val ifoder = [11,12,3,4,5];
141.583 - val r_foder = rev foder; val r_ifoder = rev ifoder;
141.584 - dropwhile' equal r_foder r_ifoder;
141.585 -> val it = ([3], [3, 12, 11]) : int list * int list
141.586 -
141.587 - val foder = [5]; val ifoder = [11,12,3,4,5];
141.588 - val r_foder = rev foder; val r_ifoder = rev ifoder;
141.589 - dropwhile' equal r_foder r_ifoder;
141.590 -> val it = ([5], [5, 4, 3, 12, 11]) : int list * int list
141.591 -
141.592 - val foder = [10,11,12,13,14,15]; val ifoder = [11,12,3,4,5];
141.593 - val r_foder = rev foder; val r_ifoder = rev ifoder;
141.594 - dropwhile' equal r_foder r_ifoder;
141.595 -> *** dropwhile': did not start with equal elements*)
141.596 -
141.597 -(*040214: version for concat_deriv*)
141.598 -fun rev_deriv' (t, r, (t', a)) = (t', sym_Thm r, (t, a));
141.599 -
141.600 -fun mk_tacis ro erls (t, r as Thm _, (t', a)) =
141.601 - (Rewrite (rule2thm' r),
141.602 - Rewrite' ("Isac.thy", fst ro, erls, false,
141.603 - rule2thm' r, t, (t', a)),
141.604 - (e_pos'(*to be updated before generate tacis!!!*), Uistate))
141.605 - | mk_tacis ro erls (t, r as Rls_ rls, (t', a)) =
141.606 - (Rewrite_Set (rule2rls' r),
141.607 - Rewrite_Set' ("Isac.thy", false, rls, t, (t', a)),
141.608 - (e_pos'(*to be updated before generate tacis!!!*), Uistate));
141.609 -
141.610 -(*fo = ifo excluded already in inform*)
141.611 -fun concat_deriv rew_ord erls rules fo ifo =
141.612 - let fun derivat ([]:(term * rule * (term * term list)) list) = e_term
141.613 - | derivat dt = (#1 o #3 o last_elem) dt
141.614 - fun equal (_,_,(t1, _)) (_,_,(t2, _)) = t1=t2
141.615 - val fod = make_deriv (Isac"") erls rules (snd rew_ord) NONE fo
141.616 - val ifod = make_deriv (Isac"") erls rules (snd rew_ord) NONE ifo
141.617 - in case (fod, ifod) of
141.618 - ([], []) => if fo = ifo then (true, [])
141.619 - else (false, [])
141.620 - | (fod, []) => if derivat fod = ifo
141.621 - then (true, fod) (*ifo is normal form*)
141.622 - else (false, [])
141.623 - | ([], ifod) => if fo = derivat ifod
141.624 - then (true, ((map rev_deriv') o rev) ifod)
141.625 - else (false, [])
141.626 - | (fod, ifod) =>
141.627 - if derivat fod = derivat ifod (*common normal form found*)
141.628 - then let val (fod', rifod') =
141.629 - dropwhile' equal (rev fod) (rev ifod)
141.630 - in (true, fod' @ (map rev_deriv' rifod')) end
141.631 - else (false, [])
141.632 - end;
141.633 -(*
141.634 - val ({rew_ord, erls, rules,...}, fo, ifo) =
141.635 - (rep_rls Test_simplify, str2term "x+1+ -1*2=0", str2term "-2*1+(x+1)=0");
141.636 - (writeln o trtas2str) fod';
141.637 -> ["
141.638 -(x + 1 + -1 * 2 = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (x + 1) = 0, []))","
141.639 -(-1 * 2 + (x + 1) = 0, Thm ("radd_commute","?m + ?n = ?n + ?m"), (-1 * 2 + (1 + x) = 0, []))","
141.640 -(-1 * 2 + (1 + x) = 0, Thm ("radd_left_commute","?x + (?y + ?z) = ?y + (?x + ?z)"), (1 + (-1 * 2 + x) = 0, []))","
141.641 -(1 + (-1 * 2 + x) = 0, Thm ("#mult_Float ((~1,0), (0,0)) __ ((2,0), (0,0))","-1 * 2 = -2"), (1 + (-2 + x) = 0, []))"]
141.642 -val it = () : unit
141.643 - (writeln o trtas2str) (map rev_deriv' rifod');
141.644 -> ["
141.645 -(1 + (-2 + x) = 0, Thm ("sym_#mult_Float ((~2,0), (0,0)) __ ((1,0), (0,0))","-2 = -2 * 1"), (1 + (-2 * 1 + x) = 0, []))","
141.646 -(1 + (-2 * 1 + x) = 0, Thm ("sym_radd_left_commute","?y + (?x + ?z) = ?x + (?y + ?z)"), (-2 * 1 + (1 + x) = 0, []))","
141.647 -(-2 * 1 + (1 + x) = 0, Thm ("sym_radd_commute","?n + ?m = ?m + ?n"), (-2 * 1 + (x + 1) = 0, []))"]
141.648 -val it = () : unit
141.649 -*)
141.650 -
141.651 -
141.652 -(*.compare inform with ctree.form at current pos by nrls;
141.653 - if found, embed the derivation generated during comparison
141.654 - if not, let the mat-engine compute the next ctree.form.*)
141.655 -(*structure copied from complete_solve
141.656 - CAUTION: tacis in returned calcstate' do NOT construct resulting ptp --
141.657 - all_modspec etc. has to be inserted at Subproblem'*)
141.658 -(* val (tacis, c, ptp as (pt, pos as (p,p_))) = (tacis, ptp);
141.659 - val (tacis, c, ptp as (pt, pos as (p,p_))) = cs';
141.660 -
141.661 - val (tacis, c, ptp as (pt, pos as (p,p_))) = ([],[],(pt, lev_back pos));
141.662 - -----rec.call:
141.663 - val (tacis, c, ptp as (pt, pos as (p,p_))) = cs';
141.664 - *)
141.665 -fun compare_step ((tacis, c, ptp as (pt, pos as (p,p_))): calcstate') ifo =
141.666 - let val fo = case p_ of Frm => get_obj g_form pt p
141.667 - | Res => (fst o (get_obj g_result pt)) p
141.668 - | _ => e_term (*on PblObj is fo <> ifo*);
141.669 - val {nrls,...} = get_met (get_obj g_metID pt (par_pblobj pt p))
141.670 - val {rew_ord, erls, rules,...} = rep_rls nrls
141.671 - val (found, der) = concat_deriv rew_ord erls rules fo ifo;
141.672 - in if found
141.673 - then let val tacis' = map (mk_tacis rew_ord erls) der;
141.674 - val (c', ptp) = embed_deriv tacis' ptp;
141.675 - in ("ok", (tacis (*@ tacis'?WN050408*), c @ c', ptp)) end
141.676 - else
141.677 - if pos = ([], Res)
141.678 - then ("no derivation found", (tacis, c, ptp): calcstate')
141.679 - else let val cs' as (tacis, c', ptp) = nxt_solve_ ptp;
141.680 - val cs' as (tacis, c'', ptp) =
141.681 - case tacis of
141.682 - ((Subproblem _, _, _)::_) =>
141.683 - let val ptp as (pt, (p,_)) = all_modspec ptp
141.684 - val mI = get_obj g_metID pt p
141.685 - in nxt_solv (Apply_Method' (mI, NONE, e_istate))
141.686 - e_istate ptp end
141.687 - | _ => cs';
141.688 - in compare_step (tacis, c @ c' @ c'', ptp) ifo end
141.689 - end;
141.690 -(* writeln (trtas2str der);
141.691 - *)
141.692 -
141.693 -(*.handle a user-input formula, which may be a CAS-command, too.
141.694 -CAS-command:
141.695 - create a calchead, and do 1 step
141.696 - TOOODO.WN0602 works only for the root-problem !!!
141.697 -formula, which is no CAS-command:
141.698 - compare iform with calc-tree.form at pos by equ_nrls and all subsequent pos;
141.699 - collect all the tacs applied by the way.*)
141.700 -(*structure copied from autocalc*)
141.701 -(* val (cs as (_, _, (pt, pos as (p, p_))): calcstate') = cs';
141.702 - val ifo = str2term ifo;
141.703 -
141.704 - val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) =
141.705 - (cs', encode ifo);
141.706 - val ((cs as (_, _, ptp as (pt, pos as (p, p_)))), istr)=(cs', (encode ifo));
141.707 - val ((cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate'), istr) =
141.708 - (([],[],(pt,p)), (encode ifo));
141.709 - *)
141.710 -fun inform (cs as (_, _, ptp as (pt, pos as (p, p_))): calcstate') istr =
141.711 - case parse (assoc_thy "Isac.thy") istr of
141.712 -(* val SOME ifo = parse (assoc_thy "Isac.thy") istr;
141.713 - *)
141.714 - SOME ifo =>
141.715 - let val ifo = term_of ifo
141.716 - val fo = case p_ of Frm => get_obj g_form pt p
141.717 - | Res => (fst o (get_obj g_result pt)) p
141.718 - | _ => #3 (get_obj g_origin pt p)
141.719 - in if fo = ifo
141.720 - then ("same-formula", cs)
141.721 - (*thus ctree not cut with replaceFormula!*)
141.722 - else case cas_input ifo of
141.723 -(* val SOME (pt, _) = cas_input ifo;
141.724 - *)
141.725 - SOME (pt, _) => ("ok",([],[],(pt, (p, Met))))
141.726 - | NONE =>
141.727 - compare_step ([],[],(pt,
141.728 - (*last step re-calc in compare_step TODO*)
141.729 - lev_back pos)) ifo
141.730 - end
141.731 - | NONE => ("syntax error in '"^istr^"'", e_calcstate');
141.732 -
141.733 -
141.734 -(*------------------------------------------------------------------(**)
141.735 -end
141.736 -open inform;
141.737 -(**)------------------------------------------------------------------*)
142.1 --- a/src/Tools/isac/ME/mathengine.sml Wed Aug 25 15:15:01 2010 +0200
142.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
142.3 @@ -1,506 +0,0 @@
142.4 -(* The _functional_ mathematics engine, ie. without a state.
142.5 - Input and output are Isabelle's formulae as strings.
142.6 - authors: Walther Neuper 2000
142.7 - (c) due to copyright terms
142.8 -
142.9 -use"mathengine.sml";
142.10 -*)
142.11 -
142.12 -signature MATHENGINE =
142.13 - sig
142.14 - type nxt_
142.15 - (* datatype nxt_ = HElpless | Nexts of CalcHead.calcstate *)
142.16 - type NEW
142.17 - type lOc_
142.18 - (*datatype
142.19 - lOc_ =
142.20 - ERror of string
142.21 - | UNsafe of CalcHead.calcstate'
142.22 - | Updated of CalcHead.calcstate' *)
142.23 -
142.24 - val CalcTreeTEST :
142.25 - fmz list ->
142.26 - pos' * NEW * mout * (string * tac) * safe * ptree
142.27 -
142.28 - val TESTg_form : ptree * (int list * pos_) -> mout
142.29 - val autocalc :
142.30 - pos' list ->
142.31 - pos' ->
142.32 - (ptree * pos') * taci list ->
142.33 - auto -> string * pos' list * (ptree * pos')
142.34 - val detailstep : ptree -> pos' -> string * ptree * pos'
142.35 - (* val e_tac_ : tac_ *)
142.36 - val f2str : mout -> cterm'
142.37 - (* val get_pblID : ptree * pos' -> pblID option *)
142.38 - val initmatch : ptree -> pos' -> ptform
142.39 - (* val loc_solve_ :
142.40 - string * tac_ -> ptree * (int list * pos_) -> lOc_ *)
142.41 - (* val loc_specify_ : tac_ -> ptree * pos' -> lOc_ *)
142.42 - val locatetac : (*tests only*)
142.43 - tac ->
142.44 - ptree * (posel list * pos_) ->
142.45 - string * (taci list * pos' list * (ptree * (posel list * pos_)))
142.46 - val me :
142.47 - tac'_ ->
142.48 - pos' ->
142.49 - NEW ->
142.50 - ptree -> pos' * NEW * mout * tac'_ * safe * ptree
142.51 -
142.52 - val nxt_specify_ : ptree * (int list * pos_) -> calcstate'(*tests only*)
142.53 - val set_method : metID -> ptree * pos' -> ptree * ocalhd
142.54 - val set_problem : pblID -> ptree * pos' -> ptree * ocalhd
142.55 - val set_theory : thyID -> ptree * pos' -> ptree * ocalhd
142.56 - val step : pos' -> calcstate -> string * calcstate'
142.57 - val trymatch : pblID -> ptree -> pos' -> ptform
142.58 - val tryrefine : pblID -> ptree -> pos' -> ptform
142.59 - end
142.60 -
142.61 -
142.62 -
142.63 -(*------------------------------------------------------------------(**)
142.64 -structure MathEngine : MATHENGINE =
142.65 -struct
142.66 -(**)------------------------------------------------------------------*)
142.67 -
142.68 -fun get_pblID (pt, (p,_):pos') =
142.69 - let val p' = par_pblobj pt p
142.70 - val (_,pI,_) = get_obj g_spec pt p'
142.71 - val (_,(_,oI,_),_) = get_obj g_origin pt p'
142.72 - in if pI <> e_pblID then SOME pI
142.73 - else if oI <> e_pblID then SOME oI
142.74 - else NONE end;
142.75 -(*fun get_pblID (pt, (p,_):pos') =
142.76 - ((snd3 o (get_obj g_spec pt)) (par_pblobj pt p));*)
142.77 -
142.78 -
142.79 -(*--vvv--dummies for test*)
142.80 -val e_tac_ = Tac_ (Pure.thy,"","","");
142.81 -datatype lOc_ =
142.82 - ERror of string (*after loc_specify, loc_solve*)
142.83 -| UNsafe of calcstate' (*after loc_specify, loc_solve*)
142.84 -| Updated of calcstate'; (*after loc_specify, loc_solve*)
142.85 -fun loc_specify_ m (pt,pos) =
142.86 -(* val pos = ip;
142.87 - *)
142.88 - let val (p,_,f,_,s,pt) = specify m pos [] pt;
142.89 -(* val (_,_,_,_,_,pt')= specify m pos [] pt;
142.90 - *)
142.91 - in case f of
142.92 - (Error' (Error_ e)) => ERror e
142.93 - | _ => Updated ([], [], (pt,p)) end;
142.94 -
142.95 -(*. TODO push return-value cs' into solve and rename solve->loc_solve?_? .*)
142.96 -(* val (m, pos) = ((mI,m), ip);
142.97 - val (m,(pt,pos) ) = ((mI,m), ptp);
142.98 - *)
142.99 -fun loc_solve_ m (pt,pos) =
142.100 - let val (msg, cs') = solve m (pt, pos);
142.101 -(* val (tacis,dels,(pt',p')) = cs';
142.102 - (writeln o istate2str) (get_istate pt' p');
142.103 - (term2str o fst) (get_obj g_result pt' (fst p'));
142.104 - *)
142.105 - in case msg of
142.106 - "ok" => Updated cs'
142.107 - | msg => ERror msg
142.108 - end;
142.109 -
142.110 -datatype nxt_ =
142.111 - HElpless (**)
142.112 - | Nexts of calcstate; (**)
142.113 -
142.114 -(*. locate a tactic in a script and apply it if possible .*)
142.115 -(*report applicability of tac in tacis; pt is dropped in setNextTactic*)
142.116 -fun locatetac _ (ptp as (_,([],Res))) = ("end-of-calculation", ([], [], ptp))
142.117 -(* val ptp as (pt, p) = (pt, p);
142.118 - val ptp as (pt, p) = (pt, ip);
142.119 - *)
142.120 - | locatetac tac (ptp as (pt, p)) =
142.121 - let val (mI,m) = mk_tac'_ tac;
142.122 - in case applicable_in p pt m of
142.123 - Notappl e => ("not-applicable", ([],[], ptp):calcstate')
142.124 - | Appl m =>
142.125 -(* val Appl m = applicable_in p pt m;
142.126 - *)
142.127 - let val x = if member op = specsteps mI
142.128 - then loc_specify_ m ptp else loc_solve_ (mI,m) ptp
142.129 - in case x of
142.130 - ERror e => ("failure", ([], [], ptp))
142.131 - (*FIXXXXXME: loc_specify_, loc_solve_ TOGETHER with dropping meOLD+detail.sml*)
142.132 - | UNsafe cs' => ("unsafe-ok", cs')
142.133 - | Updated (cs' as (_,_,(_,p'))) =>
142.134 - (*ev.SEVER.tacs like Begin_Trans*)
142.135 - (if p' = ([],Res) then "end-of-calculation" else "ok",
142.136 - cs')(*for -"- user to ask ? *)
142.137 - end
142.138 - end;
142.139 -
142.140 -
142.141 -(*------------------------------------------------------------------
142.142 -fun init_detail ptp = e_calcstate;(*15.8.03.MISSING-->solve.sml!?*)
142.143 -(*----------------------------------------------------from solve.sml*)
142.144 - | nxt_solv (Detail_Set'(thy', rls, t)) (pt, p) =
142.145 - let (*val rls = the (assoc(!ruleset',rls'))
142.146 - handle _ => raise error ("solve: '"^rls'^"' not known");*)
142.147 - val thy = assoc_thy thy';
142.148 - val (srls, sc, is) =
142.149 - case rls of
142.150 - Rrls {scr=sc as Rfuns {init_state=ii,...},...} =>
142.151 - (e_rls, sc, RrlsState (ii t))
142.152 - | Rls {srls=srls,scr=sc as Script s,...} =>
142.153 - (srls, sc, ScrState ([(one_scr_arg s,t)], [],
142.154 - NONE, e_term, Sundef, true));
142.155 - val pt = update_tac pt (fst p) (Detail_Set (id_rls rls));
142.156 - val (p,cid,_,pt) = generate1 thy (Begin_Trans' t) is p pt;
142.157 - val nx = (tac_2tac o fst3) (next_tac (thy',srls) (pt,p) sc is);
142.158 - val aopt = applicable_in p pt nx;
142.159 - in case aopt of
142.160 - Notappl s => raise error ("solve Detail_Set: "^s)
142.161 - (* val Appl m = aopt;
142.162 - *)
142.163 - | Appl m => solve ("discardFIXME",m) p pt end
142.164 -------------------------------------------------------------------*)
142.165 -
142.166 -
142.167 -(*iterated by nxt_me; there (the resulting) ptp dropped
142.168 - may call nxt_solve Apply_Method --- thus evaluated here after solve.sml*)
142.169 -(* val (ptp as (pt, pos as (p,p_))) = ptp;
142.170 - val (ptp as (pt, pos as (p,p_))) = (pt,ip);
142.171 - *)
142.172 -fun nxt_specify_ (ptp as (pt, pos as (p,p_))) =
142.173 - let val pblobj as (PblObj{meth,origin=origin as (oris,(dI',pI',mI'),_),
142.174 - probl,spec=(dI,pI,mI),...}) = get_obj I pt p;
142.175 - in if just_created_ pblobj (*by Subproblem*) andalso origin <> e_origin
142.176 - then case mI' of
142.177 - ["no_met"] => nxt_specif (Refine_Tacitly pI') (pt, (p, Pbl))
142.178 - | _ => nxt_specif Model_Problem (pt, (p,Pbl))
142.179 - else let val cpI = if pI = e_pblID then pI' else pI;
142.180 - val cmI = if mI = e_metID then mI' else mI;
142.181 - val {ppc,prls,where_,...} = get_pbt cpI;
142.182 - val pre = check_preconds "thy 100820" prls where_ probl;
142.183 - val pb = foldl and_ (true, map fst pre);
142.184 - (*FIXME.WN0308: ~~~~~: just check true in itms of pbl/met?*)
142.185 - val (_,tac) =
142.186 - nxt_spec p_ pb oris (dI',pI',mI') (probl, meth)
142.187 - (ppc, (#ppc o get_met) cmI) (dI, pI, mI);
142.188 - in case tac of
142.189 - Apply_Method mI =>
142.190 -(* val Apply_Method mI = tac;
142.191 - *)
142.192 - nxt_solv (Apply_Method' (mI, NONE, e_istate)) e_istate ptp
142.193 - | _ => nxt_specif tac ptp end
142.194 - end;
142.195 -
142.196 -
142.197 -(*.specify a new method;
142.198 - WN0512 impl.incomplete, see 'nxt_specif (Specify_Method ' .*)
142.199 -fun set_method (mI:metID) ptp =
142.200 - let val ([(_, Specify_Method' (_, _, mits), _)], [], (pt, pos as (p,_))) =
142.201 - nxt_specif (Specify_Method mI) ptp
142.202 - val pre = [] (*...from Specify_Method'*)
142.203 - val complete = true (*...from Specify_Method'*)
142.204 - (*from Specify_Method' ? vvv, vvv ?*)
142.205 - val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p
142.206 - in (pt, (complete, Met, hdf, mits, pre, spec):ocalhd) end;
142.207 -
142.208 -(* val ([(_, Specify_Method' (_, _, mits), _)], [],_) =
142.209 - nxt_specif (Specify_Method mI) ptp;
142.210 - *)
142.211 -
142.212 -(*.specify a new problem;
142.213 - WN0512 impl.incomplete, see 'nxt_specif (Specify_Problem ' .*)
142.214 -(* val (pI, ptp) = (pI, (pt, ip));
142.215 - *)
142.216 -fun set_problem pI (ptp: ptree * pos') =
142.217 - let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)],
142.218 - _, (pt, pos as (p,_))) = nxt_specif (Specify_Problem pI) ptp
142.219 - (*from Specify_Problem' ? vvv, vvv ?*)
142.220 - val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p
142.221 - in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end;
142.222 -
142.223 -fun set_theory (tI:thyID) (ptp: ptree * pos') =
142.224 - let val ([(_, Specify_Problem' (_, (complete, (pits, pre))),_)],
142.225 - _, (pt, pos as (p,_))) = nxt_specif (Specify_Theory tI) ptp
142.226 - (*from Specify_Theory' ? vvv, vvv ?*)
142.227 - val PblObj {origin = (_,_,hdf), spec,...} = get_obj I pt p
142.228 - in (pt, (complete, Pbl, hdf, pits, pre, spec):ocalhd) end;
142.229 -
142.230 -(*.does a step forward; returns tactic used, ctree updated.
142.231 -TODO.WN0512 redesign after specify-phase became more separated from solve-phase
142.232 -arg ip:
142.233 - calcstate
142.234 -.*)
142.235 -(* val (ip as (_,p_), (ptp as (pt,p), tacis)) = (get_pos 1 1, get_calc 1);
142.236 - val (ip as (_,p_), (ptp as (pt,p), tacis)) = (pos, cs);
142.237 - val (ip as (_,p_), (ptp as (pt,p), tacis)) = (p, ((pt, e_pos'),[]));
142.238 - val (ip as (_,p_), (ptp as (pt,p), tacis)) = (ip,cs);
142.239 - *)
142.240 -fun step ((ip as (_,p_)):pos') ((ptp as (pt,p), tacis):calcstate) =
142.241 - let val pIopt = get_pblID (pt,ip);
142.242 - in if (*p = ([],Res) orelse*) ip = ([],Res)
142.243 - then ("end-of-calculation",(tacis, [], ptp):calcstate') else
142.244 - case tacis of
142.245 - (_::_) =>
142.246 -(* val((tac,_,_)::_) = tacis;
142.247 - *)
142.248 - if ip = p (*the request is done where ptp waits for*)
142.249 - then let val (pt',c',p') = generate tacis (pt,[],p)
142.250 - in ("ok", (tacis, c', (pt', p'))) end
142.251 - else (case (if member op = [Pbl,Met] p_
142.252 - then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip))
142.253 - handle _ => ([],[],ptp)(*e.g.by Add_Given "equality///"*)
142.254 - of cs as ([],_,_) => ("helpless", cs)
142.255 - | cs => ("ok", cs))
142.256 -(* val [] = tacis;
142.257 - *)
142.258 - | _ => (case pIopt of
142.259 - NONE => ("no-fmz-spec", ([], [], ptp))
142.260 - | SOME pI =>
142.261 -(* val SOME pI = pIopt;
142.262 - val cs=(if member op = [Pbl,Met] p_ andalso is_none(get_obj g_env pt (fst p))
142.263 - then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip))
142.264 - handle _ => ([], ptp);
142.265 - *)
142.266 - (case (if member op = [Pbl,Met] p_
142.267 - andalso is_none (get_obj g_env pt (fst p))
142.268 - (*^^^^^^^^: Apply_Method without init_form*)
142.269 - then nxt_specify_ (pt,ip) else nxt_solve_ (pt,ip) )
142.270 - handle _ => ([],[],ptp)(*e.g.by Add_Giv"equality/"*)
142.271 - of cs as ([],_,_) =>("helpless", cs)(*FIXXMEdel.handle*)
142.272 - | cs => ("ok", cs)))
142.273 - end;
142.274 -
142.275 -(* (nxt_solve_ (pt,ip)) handle e => print_exn e ;
142.276 -
142.277 - *)
142.278 -
142.279 -
142.280 -
142.281 -
142.282 -(*.does several steps within one calculation as given by "type auto";
142.283 - the steps may arbitrarily go into and leave different phases,
142.284 - i.e. specify-phase and solve-phase.*)
142.285 -(*TODO.WN0512 ? redesign after the phases have been more separated
142.286 - at the fron-end in 05:
142.287 - eg. CompleteCalcHead could be done by a separate fun !!!*)
142.288 -(* val (ip, cs as (ptp as (pt,p),tacis)) = (get_pos cI 1, get_calc cI);
142.289 - val (ip, cs as (ptp as (pt,p),tacis)) = (pold, get_calc cI);
142.290 - val (c, ip, cs as (ptp as (_,p),tacis), Step s) =
142.291 - ([]:pos' list, pold, get_calc cI, auto);
142.292 - *)
142.293 -fun autocalc c ip (cs as (ptp as (_,p),tacis)) (Step s) =
142.294 - if s <= 1
142.295 - then let val (str, (_, c', ptp)) = step ip cs;(*1*)
142.296 - (*at least does 1 step, ev.1 too much*)
142.297 - in (str, c@c', ptp) end
142.298 - else let val (str, (_, c', ptp as (_, p))) = step ip cs;
142.299 - in if str = "ok"
142.300 - then autocalc (c@c') p (ptp,[]) (Step (s-1))
142.301 - else (str, c@c', ptp) end
142.302 -(*handles autoord <= 3, autoord > 3 handled by all_/complete_solve*)
142.303 - | autocalc c (pos as (_,p_)) ((pt,_), _(*tacis would help 1x in solve*))auto=
142.304 -(* val (c:pos' list, (pos as (_,p_)),((pt,_),_),auto) =
142.305 - ([], pold, get_calc cI, auto);
142.306 - *)
142.307 - if autoord auto > 3 andalso just_created (pt, pos)
142.308 - then let val ptp = all_modspec (pt, pos);
142.309 - in all_solve auto c ptp end
142.310 - else
142.311 - if member op = [Pbl, Met] p_
142.312 - then if not (is_complete_mod (pt, pos))
142.313 - then let val ptp = complete_mod (pt, pos)
142.314 - in if autoord auto < 3 then ("ok", c, ptp)
142.315 - else
142.316 - if not (is_complete_spec ptp)
142.317 - then let val ptp = complete_spec ptp
142.318 - in if autoord auto = 3 then ("ok", c, ptp)
142.319 - else all_solve auto c ptp
142.320 - end
142.321 - else if autoord auto = 3 then ("ok", c, ptp)
142.322 - else all_solve auto c ptp
142.323 - end
142.324 - else
142.325 - if not (is_complete_spec (pt,pos))
142.326 - then let val ptp = complete_spec (pt, pos)
142.327 - in if autoord auto = 3 then ("ok", c, ptp)
142.328 - else all_solve auto c ptp
142.329 - end
142.330 - else if autoord auto = 3 then ("ok", c, (pt, pos))
142.331 - else all_solve auto c (pt, pos)
142.332 - else complete_solve auto c (pt, pos);
142.333 -(* val pbl = get_obj g_pbl (fst ptp) [];
142.334 - val (oris,_,_) = get_obj g_origin (fst ptp) [];
142.335 -*)
142.336 -
142.337 -
142.338 -
142.339 -
142.340 -
142.341 -(*.initialiye matching; before 'tryMatch' get the pblID to match with:
142.342 - if no pbl has been specified, take the init from origin.*)
142.343 -(*fun initmatch pt (pos as (p,_):pos') =
142.344 - let val PblObj {probl,origin=(os,(_,pI,_),_),spec=(dI',pI',mI'),...} =
142.345 - get_obj I pt p
142.346 - val pblID = if pI' = e_pblID
142.347 - then (*TODO.WN051125 (#init o get_pbt) pI <<<*)
142.348 - takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*)
142.349 - else pI'
142.350 - val spec = (dI',pblID,mI')
142.351 - val {ppc,where_,prls,...} = get_pbt pblID
142.352 - val (model_ok, (pbl, pre)) =
142.353 - match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os
142.354 - in ModSpec (ocalhd_complete pbl pre spec,
142.355 - Pbl, e_term, pbl, pre, spec) end;*)
142.356 -fun initcontext_pbl pt (pos as (p,_):pos') =
142.357 - let val PblObj {probl,origin=(os,(_,pI,_),hdl),spec=(dI',pI',mI'),...} =
142.358 - get_obj I pt p
142.359 - val pblID = if pI' = e_pblID
142.360 - then (*TODO.WN051125 (#init o get_pbt) pI <<<*)
142.361 - takelast (2, pI) (*FIXME.WN051125 a hack, impl.^^^*)
142.362 - else pI'
142.363 - val {ppc,where_,prls,...} = get_pbt pblID
142.364 - val (model_ok, (pbl, pre)) =
142.365 - match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os
142.366 - in (model_ok, pblID, hdl, pbl, pre) end;
142.367 -
142.368 -fun initcontext_met pt (pos as (p,_):pos') =
142.369 - let val PblObj {meth,origin=(os,(_,_,mI), _),spec=(_, _, mI'),...} =
142.370 - get_obj I pt p
142.371 - val metID = if mI' = e_metID
142.372 - then (*TODO.WN051125 (#init o get_pbt) pI <<<*)
142.373 - takelast (2, mI) (*FIXME.WN051125 a hack, impl.^^^*)
142.374 - else mI'
142.375 - val {ppc,pre,prls,scr,...} = get_met metID
142.376 - val (model_ok, (pbl, pre)) =
142.377 - match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os
142.378 - in (model_ok, metID, scr, pbl, pre) end;
142.379 -
142.380 -(*.match the model of a problem at pos p
142.381 - with the model-pattern of the problem with pblID*)
142.382 -fun context_pbl pI pt (p:pos) =
142.383 - let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p
142.384 - val {ppc,where_,prls,...} = get_pbt pI
142.385 - val (model_ok, (pbl, pre)) =
142.386 - match_itms_oris (assoc_thy "Isac.thy") probl (ppc,where_,prls) os
142.387 - in (model_ok, pI, hdl, pbl, pre) end;
142.388 -
142.389 -fun context_met mI pt (p:pos) =
142.390 - let val PblObj {meth,origin=(os,_,hdl),...} = get_obj I pt p
142.391 - val {ppc,pre,prls,scr,...} = get_met mI
142.392 - val (model_ok, (pbl, pre)) =
142.393 - match_itms_oris (assoc_thy "Isac.thy") meth (ppc,pre,prls) os
142.394 - in (model_ok, mI, scr, pbl, pre) end
142.395 -
142.396 -
142.397 -(* val (pI, pt, pos as (p,_)) = (pblID, pt, p);
142.398 - *)
142.399 -fun tryrefine pI pt (pos as (p,_):pos') =
142.400 - let val PblObj {probl,origin=(os,_,hdl),...} = get_obj I pt p
142.401 - in case refine_pbl (assoc_thy "Isac.thy") pI probl of
142.402 - NONE => (*copy from context_pbl*)
142.403 - let val {ppc,where_,prls,...} = get_pbt pI
142.404 - val (_, (pbl, pre)) = match_itms_oris (assoc_thy "Isac.thy")
142.405 - probl (ppc,where_,prls) os
142.406 - in (false, pI, hdl, pbl, pre) end
142.407 - | SOME (pI, (pbl, pre)) =>
142.408 - (true, pI, hdl, pbl, pre)
142.409 - end;
142.410 -
142.411 -(* val (pt, (pos as (p,p_):pos')) = (pt, ip);
142.412 - *)
142.413 -fun detailstep pt (pos as (p,p_):pos') =
142.414 - let val nd = get_nd pt p
142.415 - val cn = children nd
142.416 - in if null cn
142.417 - then if (is_rewset o (get_obj g_tac nd)) [(*root of nd*)]
142.418 - then detailrls pt pos
142.419 - else ("no-Rewrite_Set...", EmptyPtree, e_pos')
142.420 - else ("donesteps", pt(*, get_formress [] ((lev_on o lev_dn) p) cn*),
142.421 - (p @ [length (children (get_nd pt p))], Res) )
142.422 - end;
142.423 -
142.424 -
142.425 -
142.426 -(***. for mathematics authoring on sml-toplevel; no XML .***)
142.427 -
142.428 -type NEW = int list;
142.429 -(* val sp = (dI',pI',mI');
142.430 - *)
142.431 -
142.432 -(*15.8.03 for me with loc_specify/solve, nxt_specify/solve
142.433 - delete as soon as TESTg_form -> _mout_ dropped*)
142.434 -fun TESTg_form ptp =
142.435 -(* val ptp = (pt,p);
142.436 - *)
142.437 - let val (form,_,_) = pt_extract ptp
142.438 - in case form of
142.439 - Form t => Form' (FormKF (~1,EdUndef,0,Nundef,term2str t))
142.440 - | ModSpec (_,p_, head, gfr, pre, _) =>
142.441 - Form' (PpcKF (0,EdUndef,0,Nundef,
142.442 - (case p_ of Pbl => Problem[] | Met => Method[],
142.443 - itms2itemppc (assoc_thy"Isac.thy") gfr pre)))
142.444 - end;
142.445 -
142.446 -(*.create a calc-tree; for use within sml: thus ^^^ NOT decoded to ^;
142.447 - compare "fun CalcTree" which DOES decode.*)
142.448 -fun CalcTreeTEST [(fmz, sp):fmz] =
142.449 -(* val [(fmz, sp):fmz] = [(fmz, (dI',pI',mI'))];
142.450 - val [(fmz, sp):fmz] = [([], ("e_domID", ["e_pblID"], ["e_metID"]))];
142.451 - *)
142.452 - let val cs as ((pt,p), tacis) = nxt_specify_init_calc (fmz, sp)
142.453 - val tac = case tacis of [] => Empty_Tac | _ => (#1 o hd) tacis
142.454 - val f = TESTg_form (pt,p)
142.455 - in (p, []:NEW, f, (tac2IDstr tac, tac), Sundef, pt) end;
142.456 -
142.457 -(*for tests > 15.8.03 after separation setnexttactic / nextTac:
142.458 - external view: me should be used by math-authors as done so far
142.459 - internal view: loc_specify/solve, nxt_specify/solve used
142.460 - i.e. same as in setnexttactic / nextTac*)
142.461 -(*ENDE TESTPHASE 08/10.03:
142.462 - NEW loeschen, eigene Version von locatetac, step
142.463 - meNEW, CalcTreeTEST: tac'_ -replace-> tac, remove [](cid) *)
142.464 -
142.465 -(* val ((_,tac), p, _, pt) = (nxt, p, c, pt);
142.466 - *)
142.467 -fun me ((_,tac):tac'_) (p:pos') (_:NEW(*remove*)) (pt:ptree) =
142.468 - let val (pt, p) =
142.469 -(* val (msg, (tacis, pos's, (pt',p'))) = locatetac tac (pt,p);
142.470 - p = ([1, 9], Res);
142.471 - (writeln o istate2str) (get_istate pt p);
142.472 - *)
142.473 - (*locatetac is here for testing by me; step would suffice in me*)
142.474 - case locatetac tac (pt,p) of
142.475 - ("ok", (_, _, ptp)) => ptp
142.476 - | ("unsafe-ok", (_, _, ptp)) => ptp
142.477 - | ("not-applicable",_) => (pt, p)
142.478 - | ("end-of-calculation", (_, _, ptp)) => ptp
142.479 - | ("failure",_) => raise error "sys-error";
142.480 - val (_, ts) =
142.481 -(* val (eee, (ts, _, (pt'',_))) = step p ((pt, e_pos'),[]);
142.482 - *)
142.483 - (case step p ((pt, e_pos'),[]) of
142.484 - ("ok", (ts as (tac,_,_)::_, _, _)) => ("",ts)
142.485 - | ("helpless",_) => ("helpless: cannot propose tac", [])
142.486 - | ("no-fmz-spec",_) => raise error "no-fmz-spec"
142.487 - | ("end-of-calculation", (ts, _, _)) => ("",ts))
142.488 - handle _ => raise error "sys-error";
142.489 - val tac = case ts of tacis as (_::_) =>
142.490 -(* val tacis as (_::_) = ts;
142.491 - *)
142.492 - let val (tac,_,_) = last_elem tacis
142.493 - in tac end
142.494 - | _ => if p = ([],Res) then End_Proof'
142.495 - else Empty_Tac;
142.496 - (*form output comes from locatetac*)
142.497 - in(p:pos',[]:NEW, TESTg_form (pt, p),
142.498 - (tac2IDstr tac, tac):tac'_, Sundef, pt) end;
142.499 -
142.500 -(*for quick test-print-out, until 'type inout' is removed*)
142.501 -fun f2str (Form' (FormKF (_, _, _, _, cterm'))) = cterm';
142.502 -
142.503 -
142.504 -
142.505 -(*------------------------------------------------------------------(**)
142.506 -end
142.507 -open MathEngine;
142.508 -(**)------------------------------------------------------------------*)
142.509 -
143.1 --- a/src/Tools/isac/ME/mstools.sml Wed Aug 25 15:15:01 2010 +0200
143.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
143.3 @@ -1,969 +0,0 @@
143.4 -(* Types and tools for 'modeling' und 'specifying' to be used in
143.5 - modspec.sml. The types are separated from calchead.sml into this file,
143.6 - because some of them are stored in the calc-tree, and thus are required
143.7 - _before_ ctree.sml.
143.8 - author: Walther Neuper
143.9 - (c) due to copyright terms
143.10 -
143.11 -use"ME/mstools.sml" (*re-evaluate sml/ from scratch!*);
143.12 -use"mstools.sml";
143.13 -12345678901234567890123456789012345678901234567890123456789012345678901234567890
143.14 - 10 20 30 40 50 60 70 80
143.15 -*)
143.16 -
143.17 -signature SPECIFY_TOOLS =
143.18 - sig
143.19 - type envv
143.20 - datatype
143.21 - item =
143.22 - Correct of cterm'
143.23 - | False of cterm'
143.24 - | Incompl of cterm'
143.25 - | Missing of cterm'
143.26 - | Superfl of string
143.27 - | SyntaxE of string
143.28 - | TypeE of string
143.29 - val item2str : item -> string
143.30 - type itm
143.31 - val itm2str_ : Proof.context -> itm -> string
143.32 - datatype
143.33 - itm_ =
143.34 - Cor of (term * term list) * (term * term list)
143.35 - | Inc of (term * term list) * (term * term list)
143.36 - | Mis of term * term
143.37 - | Par of cterm'
143.38 - | Sup of term * term list
143.39 - | Syn of cterm'
143.40 - | Typ of cterm'
143.41 - val itm_2str : itm_ -> string
143.42 - val itm_2str_ : Proof.context -> itm_ -> string
143.43 - val itms2str_ : Proof.context -> itm list -> string
143.44 - type 'a ppc
143.45 - val ppc2str :
143.46 - {Find: string list, With: string list, Given: string list,
143.47 - Where: string list, Relate: string list} -> string
143.48 - datatype
143.49 - match =
143.50 - Matches of pblID * item ppc
143.51 - | NoMatch of pblID * item ppc
143.52 - val match2str : match -> string
143.53 - datatype
143.54 - match_ =
143.55 - Match_ of pblID * (itm list * (bool * term) list)
143.56 - | NoMatch_
143.57 - val matchs2str : match list -> string
143.58 - type ori
143.59 - val ori2str : ori -> string
143.60 - val oris2str : ori list -> string
143.61 - type preori
143.62 - val preori2str : preori -> string
143.63 - val preoris2str : preori list -> string
143.64 - type penv
143.65 - (* val penv2str_ : Proof.context -> penv -> string *)
143.66 - type vats
143.67 - (*----------------------------------------------------------------------*)
143.68 - val all_ts_in : itm_ list -> term list
143.69 - val check_preconds :
143.70 - 'a ->
143.71 - rls ->
143.72 - term list -> itm list -> (bool * term) list
143.73 - val check_preconds' :
143.74 - rls ->
143.75 - term list ->
143.76 - itm list -> 'a -> (bool * term) list
143.77 - (* val chkpre2item : rls -> term -> bool * item *)
143.78 - val pres2str : (bool * term) list -> string
143.79 - (* val evalprecond : rls -> term -> bool * term *)
143.80 - (* val cnt : itm list -> int -> int * int *)
143.81 - val comp_dts : theory -> term * term list -> term
143.82 - val comp_dts' : term * term list -> term
143.83 - val comp_dts'' : term * term list -> string
143.84 - val comp_ts : term * term list -> term
143.85 - val d_in : itm_ -> term
143.86 - val de_item : item -> cterm'
143.87 - val dest_list : term * term list -> term list (* for testing *)
143.88 - val dest_list' : term -> term list
143.89 - val dts2str : term * term list -> string
143.90 - val e_itm : itm
143.91 - (* val e_listBool : term *)
143.92 - (* val e_listReal : term *)
143.93 - val e_ori : ori
143.94 - val e_ori_ : ori
143.95 - val empty_ppc : item ppc
143.96 - (* val empty_ppc_ct' : cterm' ppc *)
143.97 - (* val getval : term * term list -> term * term *)
143.98 - (*val head_precond :
143.99 - domID * pblID * 'a ->
143.100 - term option ->
143.101 - rls ->
143.102 - term list ->
143.103 - itm list -> 'b -> term * (bool * term) list*)
143.104 - (* val init_item : string -> item *)
143.105 - (* val is_matches : match -> bool *)
143.106 - (* val is_matches_ : match_ -> bool *)
143.107 - val is_var : term -> bool
143.108 - (* val item_ppc :
143.109 - string ppc -> item ppc *)
143.110 - val itemppc2str : item ppc -> string
143.111 - (* val matches_pblID : match -> pblID *)
143.112 - val max2 : ('a * int) list -> 'a * int
143.113 - val max_vt : itm list -> int
143.114 - val mk_e : itm_ -> (term * term) list
143.115 - val mk_en : int -> itm -> (term * term) list
143.116 - val mk_env : itm list -> (term * term) list
143.117 - val mkval : 'a -> term list -> term
143.118 - val mkval' : term list -> term
143.119 - (* val pblID_of_match : match -> pblID *)
143.120 - val pbl_ids : Proof.context -> term -> term -> term list
143.121 - val pbl_ids' : 'a -> term -> term list -> term list
143.122 - (* val pen2str : theory -> term * term list -> string *)
143.123 - val penvval_in : itm_ -> term list
143.124 - val refined : match list -> pblID
143.125 - val refined_ :
143.126 - match_ list -> match_ option
143.127 - (* val refined_IDitms :
143.128 - match list -> match option *)
143.129 - val split_dts : 'a -> term -> term * term list
143.130 - val split_dts' : term * term -> term list
143.131 - (* val take_apart : term -> term list *)
143.132 - (* val take_apart_inv : term list -> term *)
143.133 - val ts_in : itm_ -> term list
143.134 - (* val unique : term *)
143.135 - val untouched : itm list -> bool
143.136 - val upd :
143.137 - Proof.context ->
143.138 - (''a * (''b * term list) list) list ->
143.139 - term ->
143.140 - ''b * term -> ''a -> ''a * (''b * term list) list
143.141 - val upd_envv :
143.142 - Proof.context ->
143.143 - envv ->
143.144 - vats ->
143.145 - term -> term -> term -> envv
143.146 - val upd_penv :
143.147 - Proof.context ->
143.148 - (''a * term list) list ->
143.149 - term -> ''a * term -> (''a * term list) list
143.150 - (* val upds_envv :
143.151 - Proof.context ->
143.152 - envv ->
143.153 - (vats * term * term * term) list ->
143.154 - envv *)
143.155 - val vts_cnt : int list -> itm list -> (int * int) list
143.156 - val vts_in : itm list -> int list
143.157 - (* val w_itms2str_ : Proof.context -> itm list -> unit *)
143.158 - end
143.159 -
143.160 -(*----------------------------------------------------------*)
143.161 -structure SpecifyTools : SPECIFY_TOOLS =
143.162 -struct
143.163 -(*----------------------------------------------------------*)
143.164 -val e_listReal = (term_of o the o (parse (theory "Script"))) "[]::(real list)";
143.165 -val e_listBool = (term_of o the o (parse (theory "Script"))) "[]::(bool list)";
143.166 -
143.167 -(*.take list-term apart w.r.t. handling elementwise input.*)
143.168 -fun take_apart t =
143.169 - let val elems = isalist2list t
143.170 - in map ((list2isalist (type_of (hd elems))) o single) elems end;
143.171 -(*val t = str2term "[a, b]";
143.172 -> val ts = take_apart t; writeln (terms2str ts);
143.173 -["[a]","[b]"]
143.174 -
143.175 -> t = (take_apart_inv o take_apart) t;
143.176 -true*)
143.177 -fun take_apart_inv ts =
143.178 - let val elems = (flat o (map isalist2list)) ts;
143.179 - in list2isalist (type_of (hd elems)) elems end;
143.180 -(*val ts = [str2term "[a]", str2term "[b]"];
143.181 -> val t = take_apart_inv ts; term2str t;
143.182 -"[a, b]"
143.183 -
143.184 -ts = (take_apart o take_apart_inv) ts;
143.185 -true*)
143.186 -
143.187 -
143.188 -
143.189 -
143.190 -(*.revert split_dts only for ts; compare comp_dts.*)
143.191 -fun comp_ts (d, ts) =
143.192 - if is_list_dsc d
143.193 - then if is_list (hd ts)
143.194 - then if is_unl d
143.195 - then (hd ts) (*e.g. someList [1,3,2]*)
143.196 - else (take_apart_inv ts)
143.197 - (* SML[ [a], [b] ]SML --> [a,b] *)
143.198 - else (hd ts) (*a variable or metavariable for a list*)
143.199 - else (hd ts);
143.200 -(*.revert split_.
143.201 - WN050903 we do NOT know which is from subtheory, description or term;
143.202 - typecheck thus may lead to TYPE-error 'unknown constant';
143.203 - solution: typecheck with Isac.thy; i.e. arg 'thy' superfluous*)
143.204 -(*fun comp_dts thy (d,[]) =
143.205 - cterm_of (*(sign_of o assoc_thy) "Isac.thy"*)
143.206 - (theory "Isac")
143.207 - (*comp_dts:FIXXME stay with term for efficiency !!!*)
143.208 - (if is_reall_dsc d then (d $ e_listReal)
143.209 - else if is_booll_dsc d then (d $ e_listBool)
143.210 - else d)
143.211 - | comp_dts thy (d,ts) =
143.212 - (cterm_of (*(sign_of o assoc_thy) "Isac.thy"*)
143.213 - (theory "Isac")
143.214 - (*comp_dts:FIXXME stay with term for efficiency !!*)
143.215 - (d $ (comp_ts (d, ts)))
143.216 - handle _ => raise error ("comp_dts: "^(term2str d)^
143.217 - " $ "^(term2str (hd ts))));*)
143.218 -fun comp_dts thy (d,[]) =
143.219 - (if is_reall_dsc d then (d $ e_listReal)
143.220 - else if is_booll_dsc d then (d $ e_listBool)
143.221 - else d)
143.222 - | comp_dts thy (d,ts) =
143.223 - (d $ (comp_ts (d, ts)))
143.224 - handle _ => raise error ("comp_dts: "^(term2str d)^
143.225 - " $ "^(term2str (hd ts)));
143.226 -(*25.8.03*)
143.227 -fun comp_dts' (d,[]) =
143.228 - if is_reall_dsc d then (d $ e_listReal)
143.229 - else if is_booll_dsc d then (d $ e_listBool)
143.230 - else d
143.231 - | comp_dts' (d,ts) = (d $ (comp_ts (d, ts)))
143.232 - handle _ => raise error ("comp_dts': "^(term2str d)^
143.233 - " $ "^(term2str (hd ts)));
143.234 -(*val t = str2term "maximum A";
143.235 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.236 -val it = "maximum A" : cterm
143.237 -> val t = str2term "fixedValues [r=Arbfix]";
143.238 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.239 -"fixedValues [r = Arbfix]"
143.240 -> val t = str2term "valuesFor [a]";
143.241 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.242 -"valuesFor [a]"
143.243 -> val t = str2term "valuesFor [a,b]";
143.244 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.245 -"valuesFor [a, b]"
143.246 -> val t = str2term "relations [A=a*b, (a/2)^^^2 + (b/2)^^^2 = r^^^2]";
143.247 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.248 -relations [A = a * b, (a / 2) ^^^ 2 + (b / 2) ^^^ 2 = r ^^^ 2]"
143.249 -> val t = str2term "boundVariable a";
143.250 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.251 -"boundVariable a"
143.252 -> val t = str2term "interval {x::real. 0 <= x & x <= 2*r}";
143.253 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.254 -"interval {x. 0 <= x & x <= 2 * r}"
143.255 -
143.256 -> val t = str2term "equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))";
143.257 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.258 -"equality (sqrt (9 + 4 * x) = sqrt x + sqrt (5 + x))"
143.259 -> val t = str2term "solveFor x";
143.260 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.261 -"solveFor x"
143.262 -> val t = str2term "errorBound (eps=0)";
143.263 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.264 -"errorBound (eps = 0)"
143.265 -> val t = str2term "solutions L";
143.266 -> val (d,ts) = split_dts thy t; comp_dts thy (d,ts);
143.267 -"solutions L"
143.268 -
143.269 -before 6.5.03:
143.270 -> val t = (term_of o the o (parse thy)) "testdscforlist [#1]";
143.271 -> val (d,ts) = split_dts t;
143.272 -> comp_dts thy (d,ts);
143.273 -val it = "testdscforlist [#1]" : cterm
143.274 -
143.275 -> val t = (term_of o the o (parse thy)) "(A::real)";
143.276 -> val (d,ts) = split_dts t;
143.277 -val d = Const ("empty","empty") : term
143.278 -val ts = [Free ("A","RealDef.real")] : term list
143.279 -> val t = (term_of o the o (parse thy)) "[R=(R::real)]";
143.280 -> val (d,ts) = split_dts t;
143.281 -val d = Const ("empty","empty") : term
143.282 -val ts = [Const # $ Free # $ Free (#,#)] : term list
143.283 -> val t = (term_of o the o (parse thy)) "[#1,#2]";
143.284 -> val (d,ts) = split_dts t;
143.285 -val ts = [Free ("#1","'a"),Free ("#2","'a")] : NOT WANTED
143.286 -*)
143.287 -
143.288 -(*for input_icalhd 11.03*)
143.289 -fun comp_dts'' (d,[]) =
143.290 - if is_reall_dsc d then term2str (d $ e_listReal)
143.291 - else if is_booll_dsc d then term2str (d $ e_listBool)
143.292 - else term2str d
143.293 - | comp_dts'' (d,ts) = term2str (d $ (comp_ts (d, ts)))
143.294 - handle _ => raise error ("comp_dts'': "^(term2str d)^
143.295 - " $ "^(term2str (hd ts)));
143.296 -
143.297 -
143.298 -
143.299 -
143.300 -
143.301 -
143.302 -(* this may decompose an object-language isa-list;
143.303 - use only, if description is not available, eg. not input ?WN:14.5.03 ??!?*)
143.304 -fun dest_list' t = if is_list t then isalist2list t else [t];
143.305 -
143.306 -(*fun is_metavar (Free (str, _)) =
143.307 - if (last_elem o explode) str = "_" then true else false
143.308 - | is_metavar _ = false;*)
143.309 -fun is_var (Free _) = true
143.310 - | is_var _ = false;
143.311 -
143.312 -(*.special handling for lists. ?WN:14.5.03 ??!?*)
143.313 -fun dest_list (d,ts) =
143.314 - let fun dest t =
143.315 - if is_list_dsc d andalso not (is_unl d)
143.316 - andalso not (is_var t) (*..for pbt*)
143.317 - then isalist2list t else [t]
143.318 - in (flat o (map dest)) ts end;
143.319 -
143.320 -
143.321 -(*.decompose an input into description, terms (ev. elems of lists),
143.322 - and the value for the problem-environment; inv to comp_dts .*)
143.323 -(*WN.8.6.03: corrected with minimal effort,
143.324 -fn : theory -> term ->
143.325 - term * description
143.326 - term list * lists decomposed for elementwise input
143.327 - term list pbl_ids not _HERE_: dont know which list-elems input*)
143.328 -fun split_dts thy (t as d $ arg) =
143.329 - if is_dsc d
143.330 - then if is_list_dsc d
143.331 - then if is_list arg
143.332 - then if is_unl d
143.333 - then (d, [arg]) (*e.g. someList [1,3,2]*)
143.334 - else (d, take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*)
143.335 - else (d, [arg]) (*a variable or metavariable for a list*)
143.336 - else (d, [arg])
143.337 - else (e_term, dest_list' t(*9.01 ???*))
143.338 - | split_dts thy t = (*either dsc or term*)
143.339 - let val (h,argl) = strip_comb t
143.340 - in if (not o is_dsc) h then (e_term, dest_list' t)
143.341 - else (h, dest_list (h,argl))
143.342 - end;
143.343 -(* tests see fun comp_dts
143.344 -
143.345 -> val t = str2term "someList []";
143.346 -> val (_,ts) = split_dts thy t; writeln (terms2str ts);
143.347 -["[]"]
143.348 -> val t = str2term "valuesFor []";
143.349 -> val (_,ts) = split_dts thy t; writeln (terms2str ts);
143.350 -["[]"]*)
143.351 -
143.352 -(*.version returning ts only.*)
143.353 -fun split_dts' (d, arg) =
143.354 - if is_dsc d
143.355 - then if is_list_dsc d
143.356 - then if is_list arg
143.357 - then if is_unl d
143.358 - then ([arg]) (*e.g. someList [1,3,2]*)
143.359 - else (take_apart arg)(*[a,b] --> SML[ [a], [b] ]SML*)
143.360 - else ([arg]) (*a variable or metavariable for a list*)
143.361 - else ([arg])
143.362 - else (dest_list' arg(*9.01 ???*))
143.363 - | split_dts' (d, t) = (*either dsc or term; 14.5.03 only copied*)
143.364 - let val (h,argl) = strip_comb t
143.365 - in if (not o is_dsc) h then (dest_list' t)
143.366 - else (dest_list (h,argl))
143.367 - end;
143.368 -
143.369 -
143.370 -
143.371 -
143.372 -
143.373 -(*27.8.01: problem-environment
143.374 -WN.6.5.03: FIXXME reconsider if penv is worth the effort --
143.375 - -- just rerun a whole expl with num/var may show the same ?!
143.376 -WN.9.5.03: penv-concept stalled, immediately generate script env !
143.377 - but [#0, epsilon] only outcommented for eventual reconsideration
143.378 -*)
143.379 -type penv = (term (*err_*)
143.380 - * (term list) (*[#0, epsilon] 9.5.03 outcommented*)
143.381 - ) list;
143.382 -fun pen2str ctxt (t, ts) =
143.383 - pair2str(Syntax.string_of_term ctxt t,
143.384 - (strs2str' o map (Syntax.string_of_term ctxt)) ts);
143.385 -fun penv2str_ thy (penv:penv) = (strs2str' o (map (pen2str thy))) penv;
143.386 -
143.387 -(*
143.388 - 9.5.03: still unused, but left for eventual future development*)
143.389 -type envv = (int * penv) list; (*over variants*)
143.390 -
143.391 -(*. 14.9.01: not used after putting penv-values into itm_
143.392 - make the result of split_* a value of problem-environment .*)
143.393 -fun mkval dsc [] = raise error "mkval called with []"
143.394 - | mkval dsc [t] = t
143.395 - | mkval dsc ts = list2isalist ((type_of o hd) ts) ts;
143.396 -(*WN.12.12.03*)
143.397 -fun mkval' x = mkval e_term x;
143.398 -
143.399 -
143.400 -
143.401 -(*. get the constant value from a penv .*)
143.402 -fun getval (id, values) =
143.403 - case values of
143.404 - [] => raise error ("penv_value: no values in '"^
143.405 - (Syntax.string_of_term (thy2ctxt' "Tools") id))
143.406 - | [v] => (id, v)
143.407 - | (v1::v2::_) => (case v1 of
143.408 - Const ("Script.Arbfix",_) => (id, v2)
143.409 - | _ => (id, v1));
143.410 -(*
143.411 - val e_ = (term_of o the o (parse thy)) "e_::bool";
143.412 - val ev = (term_of o the o (parse thy)) "#4 + #3 * x^^^#2 = #0";
143.413 - val v_ = (term_of o the o (parse thy)) "v_";
143.414 - val vv = (term_of o the o (parse thy)) "x";
143.415 - val r_ = (term_of o the o (parse thy)) "err_::bool";
143.416 - val rv1 = (term_of o the o (parse thy)) "#0";
143.417 - val rv2 = (term_of o the o (parse thy)) "eps";
143.418 -
143.419 - val penv = [(e_,[ev]),(v_,[vv]),(r_,[rv2,rv2])]:penv;
143.420 - map getval penv;
143.421 -[(Free ("e_","bool"),
143.422 - Const (#,#) $ (# $ # $ (# $ #)) $ Free ("#0","RealDef.real")),
143.423 - (Free ("v_","RealDef.real"),Free ("x","RealDef.real")),
143.424 - (Free ("err_","bool"),Free ("#0","RealDef.real"))] : (term * term) list
143.425 -*)
143.426 -
143.427 -
143.428 -(*23.3.02 TODO: ideas on redesign of type itm_,type item,type ori,type item ppc
143.429 -(1) kinds of itms:
143.430 - (1.1) untouched: for modeling only dsc displayed(impossible after match_itms)
143.431 - =(presently) Mis (? should be Inc initially, and Mis after match_itms?)
143.432 - (1.2) Syn,Typ,Sup: not related to oris
143.433 - Syn, Typ (presently) should be accepted in appl_add (instead Error')
143.434 - Sup (presently) should be accepted in appl_add (instead Error')
143.435 - _could_ be w.r.t current vat (and then _is_ related to vat
143.436 - Mis should _not_ be made Inc ((presently, by appl_add & match_itms)
143.437 -- dsc in itm_ is timeconsuming -- keep id for respective queries ?
143.438 -- order of items in ppc should be stable w.r.t order of itms
143.439 -
143.440 -- stepwise input of itms --- match_itms (in one go) ..not coordinated
143.441 - - unify code
143.442 - - match_itms / match_itms_oris ..2 versions ?!
143.443 - (fast, for refine / slow, for modeling)
143.444 -
143.445 -- clarify: efficiency <--> simplicity !!!
143.446 - ?: shift dsc itm_ -> itm | discard int in ori,itm | take int instead dsc
143.447 - | take int for perserving order of item ppc in itms
143.448 - | make all(!?) handling of itms stable against reordering(?)
143.449 - | field in ori ?? (not from fmz!) -- meant for efficiency (not doc!???)
143.450 - -"- "#undef" ?= not touched ?= (id,..)
143.451 ------------------------------------------------------------------
143.452 -27.3.02:
143.453 -def: type pbt = (field, (dsc, pid))
143.454 -
143.455 -(1) fmz + pbt -> oris
143.456 -(2) input + oris -> itm
143.457 -(3) match_itms : schnell(?) f"ur refine
143.458 - match_itms_oris : r"uckmeldung f"ur item ppc
143.459 -
143.460 -(1.1) in oris fehlt daher pid: (i,v,f,d,ts,pid)
143.461 ----------- ^^^^^ --- dh. pbt meist als argument zu viel !!!
143.462 -
143.463 -(3.1) abwarten, wie das matchen mehr unterschiedlicher pbt's sich macht;
143.464 - wenn Problem pbt v"ollig neue, dann w"are eigentlich n"otig ????:
143.465 - (a) (_,_,d1,ts,_):ori + pbt -> (i,vt,d2,ts,pid) dh.vt neu ????
143.466 - (b)
143.467 -*)
143.468 -
143.469 -
143.470 -
143.471 -
143.472 -(*the internal representation of a models' item
143.473 -
143.474 - 4.9.01: not consistent:
143.475 - after Init_Proof 'Inc', but after copy_probl 'Mis' - for same situation
143.476 - (involves 'is_error');
143.477 - bool in itm really necessary ???*)
143.478 -datatype itm_ =
143.479 - Cor of (term * (* description *)
143.480 - (term list)) * (* for list: elem-wise input *)
143.481 - (*split_dts <-> comp_dts*)
143.482 - (term * (term list)) (* elem of penv *)
143.483 - (*9.5.03: ---- is already for script -- penv delayed to future*)
143.484 - | Syn of cterm'
143.485 - | Typ of cterm'
143.486 - | Inc of (term * (term list)) * (term * (term list)) (*lists,
143.487 - + init_pbl WN.11.03 FIXXME: empty penv .. bad
143.488 - init_pbl should return Mis !!!*)
143.489 - | Sup of (term * (term list)) (* user-input not found in pbt(+?oris?11.03)*)
143.490 - | Mis of (term * term) (* after re-specification pbt-item not found
143.491 - in pbl: only dsc, pid_*)
143.492 - | Par of cterm'; (*internal state from fun parsitm*)
143.493 -
143.494 -type vats = int list; (*variants in formalizations*)
143.495 -
143.496 -(*.data-type for working on pbl/met-ppc:
143.497 - in pbl initially holds descriptions (only) for user guidance.*)
143.498 -type itm =
143.499 - int * (* id =0 .. untouched - descript (only) from init
143.500 - 23.3.02: seems to correspond to ori (fun insert_ppc)
143.501 - <> maintain order in item ppc?*)
143.502 - vats * (* variants - copy from ori *)
143.503 - bool * (* input on this item is not/complete *)
143.504 - string * (* #Given | #Find | #Relate *)
143.505 - itm_; (* *)
143.506 -(* use"ME/sequent.sml";
143.507 - *)
143.508 -val e_itm = (0,[],false,"e_itm",Syn"e_itm"):itm;
143.509 -(*in CalcTree/Subproblem an 'untouched' model is created
143.510 - FIXME.WN.9.03 model should be filled to 'untouched' by Model/Refine_Problem*)
143.511 -fun untouched (itms: itm list) =
143.512 - foldl and_ (true ,map ((curry op= 0) o #1) itms);
143.513 -(*> untouched [];
143.514 -val it = true : bool
143.515 -> untouched [e_itm];
143.516 -val it = true : bool
143.517 -> untouched [e_itm, (1,[],false,"e_itm",Syn "e_itm")];
143.518 -val it = false : bool*)
143.519 -
143.520 -
143.521 -
143.522 -
143.523 -
143.524 -(* find most frequent variant v in itms *)
143.525 -
143.526 -fun vts_in itms = (distinct o flat o (map #2)) (itms:itm list);
143.527 -
143.528 -fun cnt itms v = (v,(length o (filter (curry op= v)) o
143.529 - flat o (map #2)) (itms:itm list));
143.530 -fun vts_cnt vts itms = map (cnt itms) vts;
143.531 -fun max2 [] = raise error "max2 of []"
143.532 - | max2 (y::ys) =
143.533 - let fun mx (a,x) [] = (a,x)
143.534 - | mx (a,x) ((b,y)::ys) =
143.535 - if x < y then mx (b,y) ys else mx (a,x) ys;
143.536 -in mx y ys end;
143.537 -
143.538 -(*. find the variant with most items already input .*)
143.539 -fun max_vt itms =
143.540 - let val vts = (vts_cnt (vts_in itms)) itms;
143.541 - in if vts = [] then 0 else (fst o max2) vts end;
143.542 -
143.543 -
143.544 -(* TODO ev. make more efficient by avoiding flat *)
143.545 -fun mk_e (Cor (_, iv)) = [getval iv]
143.546 - | mk_e (Syn _) = []
143.547 - | mk_e (Typ _) = []
143.548 - | mk_e (Inc (_, iv)) = [getval iv]
143.549 - | mk_e (Sup _) = []
143.550 - | mk_e (Mis _) = [];
143.551 -fun mk_en vt ((i,vts,b,f,itm_):itm) =
143.552 - if member op = vts vt then mk_e itm_ else [];
143.553 -(*. extract the environment from an item list;
143.554 - takes the variant with most items .*)
143.555 -fun mk_env itms =
143.556 - let val vt = max_vt itms
143.557 - in (flat o (map (mk_en vt))) itms end;
143.558 -
143.559 -
143.560 -
143.561 -(*. example as provided by an author, complete w.r.t. pbt specified
143.562 - not touched by any user action .*)
143.563 -type ori = (int * (* id: 10.3.00ff impl. only <>0 .. touched
143.564 - 21.3.02: insert_ppc needs it ! ?:purpose maintain
143.565 - order in item ppc ???*)
143.566 - vats * (* variants 21.3.02: related to pbt..discard ?*)
143.567 - string * (* #Given | #Find | #Relate 21.3.02: discard ?*)
143.568 - term * (* description *)
143.569 - term list (* isalist2list t | [t] *)
143.570 - );
143.571 -val e_ori_ = (0,[],"",e_term,[e_term]):ori;
143.572 -val e_ori = (0,[],"",e_term,[e_term]):ori;
143.573 -
143.574 -fun ori2str ((i,vs,fi,t,ts):ori) =
143.575 - "("^(string_of_int i)^", "^((strs2str o (map string_of_int)) vs)^", "^fi^","^
143.576 - (term2str t)^", "^((strs2str o (map term2str)) ts)^")";
143.577 -val oris2str =
143.578 - let val s = !show_types
143.579 - val _ = show_types:= true
143.580 - val str = (strs2str' o (map (linefeed o ori2str)))
143.581 - val _ = show_types:= s
143.582 - in str end;
143.583 -
143.584 -(*.an or without leading integer.*)
143.585 -type preori = (vats *
143.586 - string *
143.587 - term *
143.588 - term list);
143.589 -fun preori2str ((vs,fi,t,ts):preori) =
143.590 - "("^((strs2str o (map string_of_int)) vs)^", "^fi^", "^
143.591 - (term2str t)^", "^((strs2str o (map term2str)) ts)^")";
143.592 -val preoris2str = (strs2str' o (map (linefeed o preori2str)));
143.593 -
143.594 -(*. given the input value (from split_dts)
143.595 - make the value in a problem-env according to description-type .*)
143.596 -(*28.8.01: .nam and .una impl. properly, others copied .. TODO*)
143.597 -fun pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) v =
143.598 - if is_list v
143.599 - then [v] (*eg. [r=Arbfix]*)
143.600 - else (case v of (*eg. eps=#0*)
143.601 - (Const ("op =",_) $ l $ r) => [r,l]
143.602 - | _ => raise error ("pbl_ids Tools.nam: no equality "
143.603 - ^(Syntax.string_of_term ctxt v)))
143.604 - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.una",_)]))) v = [v]
143.605 - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) v = [v]
143.606 - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.str",_)]))) v = [v]
143.607 - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) v = [v]
143.608 - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))v = [v]
143.609 - | pbl_ids ctxt (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))v = [v]
143.610 - | pbl_ids ctxt _ v = raise error ("pbl_ids: not implemented for "
143.611 - ^(Syntax.string_of_term ctxt v));
143.612 -(*
143.613 -val t as t1 $ t2 = str2term "antiDerivativeName M_b";
143.614 -pbl_ids ctxt t1 t2;
143.615 -
143.616 - val t = (term_of o the o (parse thy)) "fixedValues [r=Arbfix]";
143.617 - val (d,argl) = strip_comb t;
143.618 - is_dsc d; (*see split_dts*)
143.619 - dest_list (d,argl);
143.620 - val (_ $ v) = t;
143.621 - is_list v;
143.622 - pbl_ids ctxt d v;
143.623 -[Const ("List.list.Cons","[bool, bool List.list] => bool List.list") $
143.624 - (Const # $ Free # $ Const (#,#)) $ Const ("List.list.Nil","bool List..
143.625 -
143.626 - val (dsc,vl) = (split_dts o term_of o the o (parse thy)) "solveFor x";
143.627 -val dsc = Const ("Descript.solveFor","RealDef.real => Tools.una") : term
143.628 -val vl = Free ("x","RealDef.real") : term
143.629 -
143.630 - val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_";
143.631 - pbl_ids ctxt dsc vl;
143.632 -val it = [Free ("x","RealDef.real")] : term list
143.633 -
143.634 - val (dsc,vl) = (split_dts o term_of o the o(parse thy))
143.635 - "errorBound (eps=#0)";
143.636 - val (dsc,id) = (split_did o term_of o the o(parse thy)) "errorBound err_";
143.637 - pbl_ids ctxt dsc vl;
143.638 -val it = [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")] : term list *)
143.639 -
143.640 -(*. given an already input itm, ((14.9.01: no difference to pbl_ids jet!!))
143.641 - make the value in a problem-env according to description-type .*)
143.642 -(*28.8.01: .nam and .una impl. properly, others copied .. TODO*)
143.643 -fun pbl_ids' (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) vs =
143.644 - (case vs of
143.645 - [] => raise error ("pbl_ids' Tools.nam called with []")
143.646 - | [t] => (case t of (*eg. eps=#0*)
143.647 - (Const ("op =",_) $ l $ r) => [r,l]
143.648 - | _ => raise error ("pbl_ids' Tools.nam: no equality "
143.649 - ^(Syntax.string_of_term (thy2ctxt' "Isac")t)))
143.650 - | vs' => vs (*14.9.01: ???TODO *))
143.651 - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.una",_)]))) vs = vs
143.652 - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) vs = vs
143.653 - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.str",_)]))) vs = vs
143.654 - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) vs = vs
143.655 - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))vs = vs
143.656 - | pbl_ids' (Const(_,Type("fun",[_,Type("Tools.unknown",_)])))vs = vs
143.657 - | pbl_ids' _ vs =
143.658 - raise error ("pbl_ids': not implemented for "
143.659 - ^(terms2str vs));
143.660 -(*9.5.03 penv postponed: pbl_ids'*)
143.661 -fun pbl_ids' thy d vs = [comp_ts (d, vs)];
143.662 -
143.663 -
143.664 -(*14.9.01: not used after putting values for penv into itm_
143.665 - WN.5.5.03: used in upd .. upd_envv*)
143.666 -fun upd_penv ctxt penv dsc (id, vl) =
143.667 -(writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!";
143.668 - writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!";
143.669 - writeln"### upd_penv used !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!";
143.670 - overwrite (penv, (id, pbl_ids ctxt dsc vl))
143.671 -);
143.672 -(*
143.673 - val penv = [];
143.674 - val (dsc,vl) = (split_did o term_of o the o (parse thy)) "solveFor x";
143.675 - val (dsc,id) = (split_did o term_of o the o (parse thy)) "solveFor v_";
143.676 - val penv = upd_penv thy penv dsc (id, vl);
143.677 -[(Free ("v_","RealDef.real"),
143.678 - [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")])]
143.679 -: (term * term list) list
143.680 -
143.681 - val (dsc,vl) = (split_did o term_of o the o(parse thy))"errorBound (eps=#0)";
143.682 - val (dsc,id) = (split_did o term_of o the o(parse thy))"errorBound err_";
143.683 - upd_penv thy penv dsc (id, vl);
143.684 -[(Free ("v_","RealDef.real"),
143.685 - [Const (#,#) $ Free (#,#) $ Free ("#0","RealDef.real")]),
143.686 - (Free ("err_","bool"),
143.687 - [Free ("#0","RealDef.real"),Free ("eps","RealDef.real")])]
143.688 -: (term * term list) list ^.........!!!!
143.689 -*)
143.690 -
143.691 -(*WN.9.5.03: not reconsidered; looks strange !!!*)
143.692 -fun upd thy envv dsc (id, vl) i =
143.693 - let val penv = case assoc (envv, i) of
143.694 - SOME e => e
143.695 - | NONE => [];
143.696 - val penv' = upd_penv thy penv dsc (id, vl);
143.697 - in (i, penv') end;
143.698 -(*
143.699 - val i = 2;
143.700 - val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv;
143.701 - val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b";
143.702 - val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_";
143.703 - upd thy envv dsc (id, vl) i;
143.704 -val it = (2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])
143.705 - : int * (term * term list) list*)
143.706 -
143.707 -
143.708 -(*14.9.01: not used after putting pre-penv into itm_*)
143.709 -fun upd_envv thy (envv:envv) (vats:vats) dsc id vl =
143.710 - let val vats = if length vats = 0
143.711 - then (*unknown id to _all_ variants*)
143.712 - if length envv = 0 then [1]
143.713 - else (intsto o length) envv
143.714 - else vats
143.715 - fun isin vats (i,_) = member op = vats i;
143.716 - val envs_notin_vat = filter_out (isin vats) envv;
143.717 - in ((map (upd thy envv dsc (id, vl)) vats) @ envs_notin_vat):envv end;
143.718 -(*
143.719 - val envv = [(1,[]:penv),(2,[]:penv),(3,[]:penv)]:envv;
143.720 -
143.721 - val vats = [2]
143.722 - val (dsc,vl) = (split_did o term_of o the o(parse thy))"boundVariable b";
143.723 - val (dsc,id) = (split_did o term_of o the o(parse thy))"boundVariable v_";
143.724 - val envv = upd_envv thy envv vats dsc id vl;
143.725 -val envv = [(2,[(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")])])]
143.726 - : (int * (term * term list) list) list
143.727 -
143.728 - val vats = [1,2,3];
143.729 - val (dsc,vl) = (split_did o term_of o the o(parse thy))"maximum A";
143.730 - val (dsc,id) = (split_did o term_of o the o(parse thy))"maximum m_";
143.731 - upd_envv thy envv vats dsc id vl;
143.732 -[(1,[(Free ("m_","bool"),[Free ("A","bool")])]),
143.733 - (2,
143.734 - [(Free ("v_","RealDef.real"),[Free ("b","RealDef.real")]),
143.735 - (Free ("m_","bool"),[Free ("A","bool")])]),
143.736 - (3,[(Free ("m_","bool"),[Free ("A","bool")])])]
143.737 -: (int * (term * term list) list) list
143.738 -
143.739 -
143.740 - val env = []:envv;
143.741 - val (d,ts) = (split_dts o term_of o the o (parse thy))
143.742 - "fixedValues [r=Arbfix]";
143.743 - val (_,id) = (split_did o term_of o the o (parse thy))"fixedValues fix_";
143.744 - val vats = [1,2,3];
143.745 - val env = upd_envv thy env vats d id (mkval ts);
143.746 -*)
143.747 -
143.748 -(*. update envv by folding from a list of arguments .*)
143.749 -fun upds_envv thy envv [] = envv
143.750 - | upds_envv thy envv ((vs, dsc, id, vl)::ps) =
143.751 - upds_envv thy (upd_envv thy envv vs dsc id vl) ps;
143.752 -(* eval test-maximum.sml until Specify_Method ...
143.753 - val PblObj{probl=(_,pbl),origin=(_,(_,_,mI),_),...} = get_obj I pt [];
143.754 - val met = (#ppc o get_met) mI;
143.755 -
143.756 - val envv = [];
143.757 - val eargs = flat eargs;
143.758 - val (vs, dsc, id, vl) = hd eargs;
143.759 - val envv = upds_envv thy envv [(vs, dsc, id, vl)];
143.760 -
143.761 - val (vs, dsc, id, vl) = hd (tl eargs);
143.762 - val envv = upds_envv thy envv [(vs, dsc, id, vl)];
143.763 -
143.764 - val (vs, dsc, id, vl) = hd (tl (tl eargs));
143.765 - val envv = upds_envv thy envv [(vs, dsc, id, vl)];
143.766 -
143.767 - val (vs, dsc, id, vl) = hd (tl (tl (tl eargs)));
143.768 - val envv = upds_envv thy envv [(vs, dsc, id, vl)];
143.769 -[(1,
143.770 - [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
143.771 - (Free ("m_","bool"),[Free (#,#)]),
143.772 - (Free ("vs_","bool List.list"),[# $ # $ Const #]),
143.773 - (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
143.774 - (2,
143.775 - [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
143.776 - (Free ("m_","bool"),[Free (#,#)]),
143.777 - (Free ("vs_","bool List.list"),[# $ # $ Const #]),
143.778 - (Free ("rs_","bool List.list"),[# $ # $ (# $ #)])]),
143.779 - (3,
143.780 - [(Free ("fix_","bool List.list"),[Const (#,#),Free (#,#)]),
143.781 - (Free ("m_","bool"),[Free (#,#)]),
143.782 - (Free ("vs_","bool List.list"),[# $ # $ Const #])])] : envv *)
143.783 -
143.784 -(*for _output_ of the items of a Model*)
143.785 -datatype item =
143.786 - Correct of cterm' (*labels a correct formula (type cterm')*)
143.787 - | SyntaxE of string (**)
143.788 - | TypeE of string (**)
143.789 - | False of cterm' (*WN050618 notexistent in itm_: only used in Where*)
143.790 - | Incompl of cterm' (**)
143.791 - | Superfl of string (**)
143.792 - | Missing of cterm';
143.793 -fun item2str (Correct s) ="Correct " ^ s
143.794 - | item2str (SyntaxE s) ="SyntaxE " ^ s
143.795 - | item2str (TypeE s) ="TypeE " ^ s
143.796 - | item2str (False s) ="False " ^ s
143.797 - | item2str (Incompl s) ="Incompl " ^ s
143.798 - | item2str (Superfl s) ="Superfl " ^ s
143.799 - | item2str (Missing s) ="Missing " ^ s;
143.800 -(*make string for error-msgs*)
143.801 -fun itm_2str_ ctxt (Cor ((d,ts), penv)) =
143.802 - "Cor " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ,"
143.803 - ^ pen2str ctxt penv
143.804 - | itm_2str_ ctxt (Syn c) = "Syn " ^ c
143.805 - | itm_2str_ ctxt (Typ c) = "Typ " ^ c
143.806 - | itm_2str_ ctxt (Inc ((d,ts), penv)) =
143.807 - "Inc " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts)) ^ " ,"
143.808 - ^ pen2str ctxt penv
143.809 - | itm_2str_ ctxt (Sup (d,ts)) =
143.810 - "Sup " ^ Syntax.string_of_term ctxt (comp_dts ctxt (d,ts))
143.811 - | itm_2str_ ctxt (Mis (d,pid))=
143.812 - "Mis "^ Syntax.string_of_term ctxt d ^
143.813 - " "^ Syntax.string_of_term ctxt pid
143.814 - | itm_2str_ ctxt (Par s) = "Trm "^s;
143.815 -fun itm_2str t = itm_2str_ (thy2ctxt' "Isac") t;
143.816 -fun itm2str_ ctxt ((i,is,b,s,itm_):itm) =
143.817 - "("^(string_of_int i)^" ,"^(ints2str' is)^" ,"^(bool2str b)^" ,"^
143.818 - s^" ,"^(itm_2str_ ctxt itm_)^")";
143.819 -fun itms2str_ ctxt itms = strs2str' (map (linefeed o (itm2str_ ctxt)) itms);
143.820 -fun w_itms2str_ ctxt itms = writeln (itms2str_ ctxt itms);
143.821 -
143.822 -fun init_item str = SyntaxE str;
143.823 -
143.824 -
143.825 -
143.826 -
143.827 -type 'a ppc =
143.828 - {Given : 'a list,
143.829 - Where: 'a list,
143.830 - Find : 'a list,
143.831 - With : 'a list,
143.832 - Relate: 'a list};
143.833 -fun ppc2str {Given=Given,Where=Where,Find=Find,With=With,Relate=Relate}=
143.834 - ("{Given =" ^ (strs2str Given ) ^
143.835 - ",Where=" ^ (strs2str Where) ^
143.836 - ",Find =" ^ (strs2str Find ) ^
143.837 - ",With =" ^ (strs2str With ) ^
143.838 - ",Relate=" ^ (strs2str Relate) ^ "}");
143.839 -
143.840 -
143.841 -
143.842 -
143.843 -fun item_ppc ({Given = gi,Where= wh,
143.844 - Find = fi,With = wi,Relate= re}: string ppc) =
143.845 - {Given = map init_item gi,Where= map init_item wh,
143.846 - Find = map init_item fi,With = map init_item wi,
143.847 - Relate= map init_item re}:item ppc;
143.848 -fun itemppc2str ({Given=Given,Where=Where,
143.849 - Find=Find,With=With,Relate=Relate}:item ppc)=
143.850 - ("{Given =" ^ ((strs2str' o (map item2str)) Given ) ^
143.851 - ",Where=" ^ ((strs2str' o (map item2str)) Where) ^
143.852 - ",Find =" ^ ((strs2str' o (map item2str)) Find ) ^
143.853 - ",With =" ^ ((strs2str' o (map item2str)) With ) ^
143.854 - ",Relate=" ^ ((strs2str' o (map item2str)) Relate) ^ "}");
143.855 -
143.856 -fun de_item (Correct x) = x
143.857 - | de_item (SyntaxE x) = x
143.858 - | de_item (TypeE x) = x
143.859 - | de_item (False x) = x
143.860 - | de_item (Incompl x) = x
143.861 - | de_item (Superfl x) = x
143.862 - | de_item (Missing x) = x;
143.863 -val empty_ppc ={Given = [],
143.864 - Where= [],
143.865 - Find = [],
143.866 - With = [],
143.867 - Relate= []}:item ppc;
143.868 -val empty_ppc_ct' ={Given = [],
143.869 - Where = [],
143.870 - Find = [],
143.871 - With = [],
143.872 - Relate= []}:cterm' ppc;
143.873 -
143.874 -
143.875 -datatype match =
143.876 - Matches of pblID * item ppc
143.877 -| NoMatch of pblID * item ppc;
143.878 -fun match2str (Matches (pI, ppc)) =
143.879 - "Matches ("^(strs2str pI)^", "^(itemppc2str ppc)^")"
143.880 - | match2str(NoMatch (pI, ppc)) =
143.881 - "NoMatch ("^(strs2str pI)^", "^(itemppc2str ppc)^")";
143.882 -fun matchs2str ms = (strs2str o (map match2str)) ms;
143.883 -fun pblID_of_match (Matches (pI,_)) = pI
143.884 - | pblID_of_match (NoMatch (pI,_)) = pI;
143.885 -
143.886 -(*10.03 for Refine_Problem*)
143.887 -datatype match_ =
143.888 - Match_ of pblID * ((itm list) * ((bool * term) list))
143.889 -| NoMatch_;
143.890 -
143.891 -(*. the refined pbt is the last_element Matches in the list .*)
143.892 -fun is_matches (Matches _) = true
143.893 - | is_matches _ = false;
143.894 -fun matches_pblID (Matches (pI,_)) = pI;
143.895 -fun refined ms = ((matches_pblID o the o (find_first is_matches) o rev) ms)
143.896 - handle _ => []:pblID;
143.897 -fun refined_IDitms ms = ((find_first is_matches) o rev) ms;
143.898 -
143.899 -(*. the refined pbt is the last_element Matches in the list,
143.900 - for Refine_Problem, tryrefine .*)
143.901 -fun is_matches_ (Match_ _) = true
143.902 - | is_matches_ _ = false;
143.903 -fun refined_ ms = ((find_first is_matches_) o rev) ms;
143.904 -
143.905 -
143.906 -fun ts_in (Cor ((_,ts),_)) = ts
143.907 - | ts_in (Syn (c)) = []
143.908 - | ts_in (Typ (c)) = []
143.909 - | ts_in (Inc ((_,ts),_)) = ts
143.910 - | ts_in (Sup (_,ts)) = ts
143.911 - | ts_in (Mis _) = [];
143.912 -(*WN050629 unused*)
143.913 -fun all_ts_in itm_s = (flat o (map ts_in)) itm_s;
143.914 -val unique = (term_of o the o (parse (theory "Real"))) "UnIqE_tErM";
143.915 -fun d_in (Cor ((d,_),_)) = d
143.916 - | d_in (Syn (c)) = (writeln("*** d_in: Syn ("^c^")"); unique)
143.917 - | d_in (Typ (c)) = (writeln("*** d_in: Typ ("^c^")"); unique)
143.918 - | d_in (Inc ((d,_),_)) = d
143.919 - | d_in (Sup (d,_)) = d
143.920 - | d_in (Mis (d,_)) = d;
143.921 -
143.922 -fun dts2str (d,ts) = pair2str (term2str d, terms2str ts);
143.923 -fun penvval_in (Cor ((d,_),(_,ts))) = [comp_ts (d,ts)]
143.924 - | penvval_in (Syn (c)) = (writeln("*** penvval_in: Syn ("^c^")"); [])
143.925 - | penvval_in (Typ (c)) = (writeln("*** penvval_in: Typ ("^c^")"); [])
143.926 - | penvval_in (Inc (_,(_,ts))) = ts
143.927 - | penvval_in (Sup dts) = (writeln("*** penvval_in: Sup "^(dts2str dts)); [])
143.928 - | penvval_in (Mis (d,t)) = (writeln("*** penvval_in: Mis "^
143.929 - (pair2str(term2str d, term2str t))); []);
143.930 -
143.931 -
143.932 -(*. check a predicate labelled with indication of incomplete substitution;
143.933 -rls -> (*for eval_true*)
143.934 -bool * (*have _all_ variables(Free) from the model-pattern
143.935 - been substituted by a value from the pattern's environment ?*)
143.936 -term (*the precondition*)
143.937 -->
143.938 -bool * (*has the precondition evaluated to true*)
143.939 -term (*the precondition (for map)*)
143.940 -.*)
143.941 -fun evalprecond prls (false, pre) =
143.942 - (*NOT ALL Free's have been substituted, eg. because of incomplete model*)
143.943 - (false, pre)
143.944 - | evalprecond prls (true, pre) =
143.945 -(* val (prls, pre) = (prls, hd pres');
143.946 - val (prls, pre) = (prls, hd (tl pres'));
143.947 - *)
143.948 - if eval_true (assoc_thy "Isac.thy") (*for Pattern.match *)
143.949 - [pre] prls (*pre parsed, prls.thy*)
143.950 - then (true , pre)
143.951 - else (false , pre);
143.952 -
143.953 -fun pre2str (b, t) = pair2str(bool2str b, term2str t);
143.954 -fun pres2str pres = strs2str' (map (linefeed o pre2str) pres);
143.955 -
143.956 -(*. check preconditions, return true if all true .*)
143.957 -fun check_preconds' _ [] _ _ = [] (*empty preconditions are true*)
143.958 - | check_preconds' prls pres pbl _(*FIXME.WN0308 mvat re-introduce*) =
143.959 -(* val (prls, pres, pbl, _) = (prls, where_, probl, 0);
143.960 - val (prls, pres, pbl, _) = (prls, pre, itms, mvat);
143.961 - *)
143.962 - let val env = mk_env pbl;
143.963 - val pres' = map (subst_atomic_all env) pres;
143.964 - in map (evalprecond prls) pres' end;
143.965 -
143.966 -fun check_preconds thy prls pres pbl =
143.967 - check_preconds' prls pres pbl (max_vt pbl);
143.968 -
143.969 -(*----------------------------------------------------------*)
143.970 -end
143.971 -open SpecifyTools;
143.972 -(*----------------------------------------------------------*)
144.1 --- a/src/Tools/isac/ME/ptyps.sml Wed Aug 25 15:15:01 2010 +0200
144.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
144.3 @@ -1,1279 +0,0 @@
144.4 -(* the problems and methods as stored in hierarchies
144.5 - author Walther Neuper 1998
144.6 - (c) due to copyright terms
144.7 -
144.8 -use"ME/ptyps.sml";
144.9 -use"ptyps.sml";
144.10 -*)
144.11 -
144.12 -(*-----------------------------------------vvv-(1) aus modspec.sml 23.3.02*)
144.13 -val dsc_unknown = (term_of o the o (parseold @{theory Script}))
144.14 - "unknown::'a => unknow";
144.15 -(*-----------------------------------------^^^-(1) aus modspec.sml 23.3.02*)
144.16 -
144.17 -
144.18 -(*-----------------------------------------vvv-(2) aus modspec.sml 23.3.02*)
144.19 -
144.20 -fun itm_2item thy (Cor ((d,ts),_)) =
144.21 - Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts)))
144.22 - | itm_2item _ (Syn c) = SyntaxE c
144.23 - | itm_2item _ (Typ c) = TypeE c
144.24 - | itm_2item thy (Inc ((d,ts),_)) =
144.25 - Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts)))
144.26 - | itm_2item thy (Sup (d,ts)) =
144.27 - Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy (d,ts)))
144.28 - | itm_2item _ (Mis (d,pid)) =
144.29 - Missing (Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^
144.30 - Syntax.string_of_term (thy2ctxt' "Isac") pid);
144.31 -
144.32 -
144.33 -(* --- 8.3.00
144.34 -fun get_dsc_in dscppc sel = ((the (assoc (dscppc, sel))):term list)
144.35 - handle _ => error ("get_dsc_in not for "^sel);
144.36 -
144.37 -fun dscs_in dscppc =
144.38 - ((get_dsc_in dscppc "#Given") @
144.39 - (get_dsc_in dscppc "#Find") @
144.40 - (get_dsc_in dscppc "#Relate")):term list;
144.41 -
144.42 - --- 26.1.88
144.43 -fun get_dsc_of pblID sel = (the (assoc((snd o get_pbt) pblID, sel)));
144.44 -fun get_dsc pblID =
144.45 - (get_dsc_of pblID "#Given") @
144.46 - (get_dsc_of pblID "#Find") @
144.47 - (get_dsc_of pblID "#Relate");
144.48 - --- *)
144.49 -
144.50 -fun mappc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) =
144.51 - {Given=map f gi, Where=map f wh,
144.52 - Find=map f fi, With=map f wi, Relate=map f re}:'b ppc;
144.53 -fun appc f ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) =
144.54 - {Given=f gi, Where=f wh,
144.55 - Find=f fi, With=f wi, Relate=f re}:'b ppc;
144.56 -
144.57 -(*for ppc of changing type*)
144.58 -fun sel_ppc sel ppc =
144.59 - case sel of
144.60 - "#Given" => #Given (ppc:'a ppc)
144.61 - | "#Where" => #Where (ppc:'a ppc)
144.62 - | "#Find" => #Find (ppc:'a ppc)
144.63 - | "#With" => #With (ppc:'a ppc)
144.64 - | "#Relate" => #Relate (ppc:'a ppc)
144.65 - | _ => raise error ("sel_ppc tried to select by '"^sel^"'");
144.66 -
144.67 -fun repl_sel_ppc sel
144.68 - ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x =
144.69 - case sel of
144.70 - "#Given" => ({Given= x,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc)
144.71 - | "#Where" => {Given=gi,Where= x,Find=fi,With=wi,Relate=re}
144.72 - | "#Find" => {Given=gi,Where=wh,Find= x,With=wi,Relate=re}
144.73 - | "#With" => {Given=gi,Where=wh,Find=fi,With= x,Relate=re}
144.74 - | "#Relate" => {Given=gi,Where=wh,Find=fi,With=wi,Relate= x}
144.75 - | _ => raise error ("repl_sel_ppc tried to select by '"^sel^"'");
144.76 -
144.77 -fun add_sel_ppc thy sel
144.78 - ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc) x =
144.79 - case sel of
144.80 - "#Given" => ({Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}:'a ppc)
144.81 - | "#Where" => {Given=gi,Where=wh@[x],Find=fi,With=wi,Relate=re}
144.82 - | "#Find" => {Given=gi,Where=wh,Find=fi@[x],With=wi,Relate=re}
144.83 - | "#Relate"=> {Given=gi,Where=wh,Find=fi,With=wi,Relate=re@[x]}
144.84 - | "#undef" => {Given=gi@[x],Where=wh,Find=fi,With=wi,Relate=re}(*ori2itmSup*)
144.85 - | _ => raise error ("add_sel_ppc tried to select by '"^sel^"'");
144.86 -fun add_where ({Given=gi,Find=fi,With=wi,Relate=re,...}:'a ppc) wh =
144.87 - ({Given=gi,Where=wh,Find=fi,With=wi,Relate=re}:'a ppc);
144.88 -
144.89 -(*-----------------------------------------^^^-(2) aus modspec.sml 23.3.02*)
144.90 -
144.91 -
144.92 -(*-----------------------------------------vvv-(3) aus modspec.sml 23.3.02*)
144.93 -
144.94 -
144.95 -
144.96 -(*decompose a problem-type into description and identifier
144.97 - FIXME split_dsc: no term list !!! (just for quick redoing prep_ori) *)
144.98 -fun split_dsc thy t =
144.99 - (let val (hd,args) = strip_comb t
144.100 - in if is_dsc hd
144.101 - then (hd, args)
144.102 - else (e_term, [t]) (*??? 9.01 just copied*)
144.103 - end)
144.104 - handle _ => raise error ("split_dsc: called with "^
144.105 - (Syntax.string_of_term (thy2ctxt' "Isac") t));
144.106 -(*
144.107 -> val t1 = (term_of o the o (parse thy)) "errorBound err_";
144.108 -> split_dsc t1;
144.109 -(Const ("Descript.errorBound","bool => Tools.nam"),Free ("err_","bool"))
144.110 - : term * term
144.111 -> val t3 = (term_of o the o (parse thy)) "valuesFor vs_";
144.112 -> split_dsc t3;
144.113 -(Const ("Descript.valuesFor","bool List.list => Tools.toreall"),
144.114 - Free ("vs_","bool List.list")) : term * term*)
144.115 -
144.116 -
144.117 -
144.118 -(*. take the first two return-values; for prep_ori .*)
144.119 -(*WN.13.5.03fun split_dts' thy t =
144.120 - let val (d, ts, _) = split_dts thy t
144.121 - in (d, ts) end;*)
144.122 -(*WN.8.12.03 quick for prep_ori'*)
144.123 -fun split_dsc' t =
144.124 - (let val dsc $ var = t
144.125 - in var end)
144.126 - handle _ => raise error ("split_dsc': called with "^term2str t);
144.127 -
144.128 -(*9.3.00*)
144.129 -(* split a term into description and (id | structured variable)
144.130 - for pbt, met.ppc *)
144.131 -fun split_did t =
144.132 - (let val (hd,[arg]) = strip_comb t
144.133 - in (hd,arg) end)
144.134 - handle _ => raise error ("split_did: doesn't match (hd,[arg]) for t = "
144.135 - ^(Syntax.string_of_term (thy2ctxt' "Script") t));
144.136 -
144.137 -
144.138 -
144.139 -(*create output-string for itm_*)
144.140 -fun itm_out thy (Cor ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
144.141 - | itm_out thy (Syn c) = c
144.142 - | itm_out thy (Typ c) = c
144.143 - | itm_out thy (Inc ((d,ts),_)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
144.144 - | itm_out thy (Sup (d,ts)) = (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
144.145 - | itm_out thy (Mis (d,pid)) =
144.146 - Syntax.string_of_term (thy2ctxt' "Isac") d ^" "^
144.147 - Syntax.string_of_term (thy2ctxt' "Isac") pid;
144.148 -
144.149 -(*22.11.00 unused
144.150 -fun itm_ppc2str thy ipc = (ppc2str o (mappc (itm__2str thy))) ipc;*)
144.151 -
144.152 -
144.153 -(*--3.3.
144.154 -fun itms2dts itms =
144.155 - let
144.156 - fun coll itms' [] = itms'
144.157 - | coll itms' (i::itms) =
144.158 - case i of
144.159 - (Cor (d,ts)) => coll (itms' @ [(d,ts)]) itms
144.160 - | (Syn c) => coll (itms' ) itms
144.161 - | (Typ c) => coll (itms' ) itms
144.162 - | (Fal (d,ts)) => coll (itms' @ [(d,ts)]) itms
144.163 - | (Inc (d,ts)) => coll (itms' @ [(d,ts)]) itms
144.164 - | (Sup (d,ts)) => coll (itms' @ [(d,ts)]) itms
144.165 - in coll [] itms end;
144.166 -*)
144.167 -(*--3.3.00
144.168 -fun itm2item ((_,_,_,_,Cor (d,ts)):itm) =
144.169 - Correct (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
144.170 - | itm2item (_,_,_,_,Syn (c)) = SyntaxE c
144.171 - | itm2item (_,_,_,_,Typ (c)) = TypeE c
144.172 - | itm2item (_,_,_,_,Fal (d,ts)) =
144.173 - False (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
144.174 - | itm2item (_,_,_,_,Inc (d,ts)) =
144.175 - Incompl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)))
144.176 - | itm2item (_,_,_,_,Sup (d,ts)) =
144.177 - Superfl (Syntax.string_of_term (thy2ctxt' "Isac") (comp_dts thy(d,ts)));
144.178 -*)
144.179 -
144.180 -fun boolterm2item (true, term) = Correct (term2str term)
144.181 - | boolterm2item (false, term) = False (term2str term);
144.182 -
144.183 -(* use"ME/modspec.sml";
144.184 - *)
144.185 -fun itms2itemppc thy (itms:itm list) (pre:(bool * term) list) =
144.186 - let
144.187 - fun coll ppc [] = ppc
144.188 - | coll ppc ((_,_,_,field,itm_)::itms) =
144.189 - coll (add_sel_ppc thy field ppc (itm_2item thy itm_)) itms;
144.190 - val gfr = coll empty_ppc itms;
144.191 - in add_where gfr (map boolterm2item pre) end;
144.192 -(*-----------------------------------------^^^-(3) aus modspec.sml 23.3.02*)
144.193 -
144.194 -(*-----------------------------------------vvv-(4) aus modspec.sml 23.3.02*)
144.195 -
144.196 -(* --- 9.3.fun add_field dscs (d,ts) =
144.197 - if d mem (get_dsc_in dscs "#Given")
144.198 - then ("#Given",d,ts:term list)
144.199 - else if d mem (get_dsc_in dscs "#Find")
144.200 - then ("#Find",d,ts)
144.201 - else if d mem (get_dsc_in dscs "#Relate")
144.202 - then ("#Relate",d,ts)
144.203 - else ("#undef",d,ts);
144.204 -(* 28.1.00 raise error ("add_field: '"^
144.205 - (Syntax.string_of_term (thy2ctxt' "Isac") d)^
144.206 - "' not in ppc-description "); *)
144.207 - ------9.3. *)
144.208 -
144.209 -(* 9.3.00
144.210 - compare d and dsc in pbt and transfer field to pre-ori *)
144.211 -fun add_field thy pbt (d,ts) =
144.212 - let fun eq d pt = (d = (fst o snd) pt);
144.213 - in case filter (eq d) pbt of
144.214 - [(fi,(dsc,_))] => (fi,d,ts)
144.215 - | [] => ("#undef",d,ts) (*may come with met.ppc*)
144.216 - | _ => raise error ("add_field: "^
144.217 - (Syntax.string_of_term (thy2ctxt' "Isac") d)^
144.218 - " more than once in pbt")
144.219 - end;
144.220 -
144.221 -(*. take over field from met.ppc at 'Specify_Method' into ori,
144.222 - i.e. also removes "#undef" fields .*)
144.223 -(* val (mpc, ori) = ((#ppc o get_met) mID, oris);
144.224 - *)
144.225 -fun add_field' thy mpc (ori:ori list) =
144.226 - let fun eq d pt = (d = (fst o snd) pt);
144.227 - fun repl mpc (i,v,_,d,ts) =
144.228 - case filter (eq d) mpc of
144.229 - [(fi,(dsc,_))] => [(i,v,fi,d,ts)]
144.230 - | [] => [] (*25.2.02: dsc in ori, but not in met -> superfluous*)
144.231 - (*raise error ("add_field': "^
144.232 - (Syntax.string_of_term (thy2ctxt' "Isac") d)^
144.233 - " not in met"*)
144.234 - | _ => raise error ("add_field': "^
144.235 - (Syntax.string_of_term (thy2ctxt' "Isac") d)^
144.236 - " more than once in met");
144.237 - in (flat ((map (repl mpc)) ori)):ori list end;
144.238 -
144.239 -
144.240 -(*.mark an element with the position within a plateau;
144.241 - a plateau with length 1 is marked with 0 .*)
144.242 -fun mark eq [] = raise error "mark []"
144.243 - | mark eq xs =
144.244 - let
144.245 - fun mar xx eq [x] n = xx @ [(if n=1 then 0 else n,x)]
144.246 - | mar xx eq (x::x'::xs) n =
144.247 - if eq(x,x') then mar (xx @ [(n,x)]) eq (x'::xs) (n+1)
144.248 - else mar (xx @ [(if n=1 then 0 else n,x)]) eq (x'::xs) 1;
144.249 - in mar [] eq xs 1 end;
144.250 -(*
144.251 -> val xs = [1,1,1,2,4,4,5];
144.252 -> mark (op=) xs;
144.253 -val it = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)]
144.254 -*)
144.255 -
144.256 -(*.assumes equal descriptions to be in adjacent 'plateaus',
144.257 - items at a certain position within the plateaus form a variant;
144.258 - length = 1 ... marked with 0: covers all variants .*)
144.259 -fun add_variants fdts =
144.260 - let
144.261 - fun eq (a,b) = curry op= (snd3 a) (snd3 b);
144.262 - in mark eq fdts end;
144.263 -
144.264 -(* collect equal elements: the model for coll_variants *)
144.265 -fun coll eq xs =
144.266 - let
144.267 - fun col xs eq x [] = xs @ [x]
144.268 - | col xs eq x (y::ys) =
144.269 - if eq(x,y) then col xs eq x ys
144.270 - else col (xs @ [x]) eq y ys;
144.271 - in col [] eq (hd xs) xs end;
144.272 -(*
144.273 -> val xs = [1,1,1,2,4,4,4];
144.274 -> coll (op=) xs;
144.275 -val it = [1,2,4] : int list
144.276 -*)
144.277 -
144.278 -fun max [] = raise error "max of []"
144.279 - | max (y::ys) =
144.280 - let fun mx x [] = x
144.281 - | mx x (y::ys) = if x < y then mx y ys else mx x ys;
144.282 -in mx y ys end;
144.283 -fun gen_max _ [] = raise error "gen_max of []"
144.284 - | gen_max ord (y::ys) =
144.285 - let fun mx x [] = x
144.286 - | mx x (y::ys) = if ord (x, y) then mx y ys else mx x ys;
144.287 -in mx y ys end;
144.288 -
144.289 -
144.290 -
144.291 -(* assumes *)
144.292 -fun coll_variants (((v,x)::vxs)) =
144.293 - let
144.294 - fun col xs (vs,x) [] = xs @ [(vs,x)]
144.295 - | col xs (vs,x) ((v',x')::vxs') =
144.296 - if x=x' then col xs (vs @ [v'], x') vxs'
144.297 - else col (xs @ [(vs,x)]) ([v'], x') vxs';
144.298 - in col [] ([v],x) vxs end;
144.299 -(* val xs = [(1,1),(2,1),(3,1),(0,2),(1,4),(2,4),(0,5)];
144.300 -> col [] ([(fst o hd) xs],(snd o hd) xs) (tl xs);
144.301 -val it = [([1,2,3],1),([0],2),([1,2],4),([0],5)] *)
144.302 -
144.303 -
144.304 -fun replace_0 vm [0] = intsto vm
144.305 - | replace_0 vm vs = vs;
144.306 -
144.307 -fun add_id [] = raise error "add_id []"
144.308 - | add_id xs =
144.309 - let fun add n [] = []
144.310 - | add n (x::xs) = (n,x) :: add (n+1) xs;
144.311 -in add 1 xs end;
144.312 -(*
144.313 -> val xs = [([1,2,3],1),([0],2),([1,2],4),([0],5)];
144.314 -> add_id xs;
144.315 -val it = [(1,([#,#,#],1)),(2,([#],2)),(3,([#,#],4)),(4,([#],5))]
144.316 - *)
144.317 -
144.318 -fun flattup (a,(b,(c,d,e))) = (a,b,c,d,e);
144.319 -fun flattup' (a,(b,((c,d),e))) = (a,b,c,d,e);
144.320 -fun flat3 (a,(b,c)) = (a,b,c);
144.321 -(*
144.322 - val pI = pI';
144.323 - !pbts;
144.324 -*)
144.325 -(* in root (only!) fmz may be empty: fill with ..,dsc,[]
144.326 -fun init_ori fmz thy pI =
144.327 - if fmz <> [] then prep_ori fmz thy pI (*fmz assumed complete*)
144.328 - else
144.329 - let
144.330 - val fds = map (cons2 (fst, fst o snd)) (get_pbt pI);
144.331 - val vfds = map ((pair [1]) o (rpair [])) fds;
144.332 - val ivfds = add_id vfds
144.333 - in (map flattup' ivfds):ori list end; 10.3.00---*)
144.334 -(* val fmz = ctl; val pI=["sqroot-test","univariate","equation"];
144.335 - val (thy,pbt) = (assoc_thy dI',(#ppc o get_pbt) pI');
144.336 - val (fmz, thy, pbt) = (fmz, thy, ((#ppc o get_pbt) pI));
144.337 - *)
144.338 -fun prep_ori [] _ _ = []
144.339 - | prep_ori fmz thy pbt =
144.340 - let
144.341 - val ctopts = map (parse thy) fmz
144.342 - val _= (*FIXME.WN060916 improve error report*)
144.343 - if null (filter is_none ctopts) then ()
144.344 - else raise error ("prep_ori: SYNTAX ERROR in " ^ strs2str' fmz)
144.345 - val dts = map ((split_dts thy) o term_of o the) ctopts
144.346 - val ori = map (add_field thy pbt) dts;
144.347 -(* val ori = map (flat3 o (pair "#undef")) dts; *)
144.348 - val ori' = add_variants ori;
144.349 - val maxv = max (map fst ori');
144.350 - val maxv = if maxv = 0 then 1(*only 1 variant*) else maxv;
144.351 - val ori'' = coll_variants ori';
144.352 - val ori''' = map (apfst (replace_0 maxv)) ori'';
144.353 - val ori'''' = add_id ori'''
144.354 - in (map flattup ori''''):ori list end;
144.355 -
144.356 -
144.357 -(*-----------------------------------------^^^-(4) aus modspec.sml 23.3.02*)
144.358 -
144.359 -(*.the pattern for an item of a problems model or a methods guard.*)
144.360 -type pat = (string * (*field*)
144.361 - (term * (*description*)
144.362 - term)) (*id | struct-var*);
144.363 -fun pat2str ((field, (dsc, id)):pat) =
144.364 - pair2str (field, pair2str (term2str dsc, term2str id));
144.365 -fun pats2str pats = (strs2str o (map pat2str)) pats;
144.366 -
144.367 -(* data for methods stored in 'methods'-database *)
144.368 -type met =
144.369 - {guh : guh, (*unique within this isac-knowledge *)
144.370 - mathauthors: string list,(*copyright *)
144.371 - init : pblID, (*WN060721 introduced mistakenly--TODO.REMOVE!*)
144.372 - rew_ord' : rew_ord', (*for rules in Detail
144.373 - TODO.WN0509 store fun itself, see 'type pbt'*)
144.374 - erls : rls, (*the eval_rls for cond. in rules FIXME "rls'
144.375 - instead erls in "fun prep_met" *)
144.376 - srls : rls, (*for evaluating list expressions in scr *)
144.377 - prls : rls, (*for evaluating predicates in modelpattern *)
144.378 - crls : rls, (*for check_elementwise, ie. formulae in calc.*)
144.379 - nrls : rls, (*canonical simplifier specific for this met *)
144.380 - calc : calc list, (*040207: <--- calclist' in fun prep_met *)
144.381 - (*branch : TransitiveB set in append_problem at generation ob pblobj
144.382 - FIXXXME.8.03: set branch from met in Apply_Method *)
144.383 -
144.384 - (* compare type pbt:*)
144.385 - ppc: pat list,
144.386 - (*.items in given, find, relate;
144.387 - items (in "#Find") which need not occur in the arg-list of a SubProblem
144.388 - are 'copy-named' with an identifier "*_!_".
144.389 - copy-named items are 'generating' if they are NOT "*___"
144.390 - see ME/calchead.sml 'fun is_copy_named'.*)
144.391 - pre: term list, (*preconditions in where*)
144.392 - (*script*)
144.393 - scr: scr (*prep_met requires either script or string "empty_script"*)
144.394 - };
144.395 -(* ------- template ------------------------------------------------------
144.396 -store_met
144.397 - (prep_met *.thy
144.398 - ([(*"EqSystem","normalize"*)],
144.399 - [("#Given" ,[ (*"equalities es_", "solveForVars vs_"*)]),
144.400 - ("#Find" ,[ (*dont forget typing non-reals *)]),
144.401 - ("#Relate",[])(*may be omitted *) ],
144.402 - {calc = [], (*filled autom. in prep_met *)
144.403 - crls = Erls, (*for check_elementwise *)
144.404 - prls = Erls, (*for evaluating preds in guard *)
144.405 - nrls = Erls, (*can.simplifier for all formulae*)
144.406 - rew_ord'="tless_true", (*for rules in Detail *)
144.407 - rls' = Erls, (*erls, the eval_rls for cond. in rules*)
144.408 - srls = Erls}, (*for evaluating list expr in scr*)
144.409 - "empty_script"
144.410 - ));
144.411 ----------- template ----------------------------------------------------*)
144.412 -val e_met = {guh="met_empty",mathauthors=[],init=e_metID,
144.413 - rew_ord' = "e_rew_ord'": rew_ord',
144.414 - erls = e_rls, srls = e_rls, prls = e_rls,
144.415 - calc = [], crls = e_rls, nrls = e_rls,
144.416 - (*asm_thm = []: thm' list,
144.417 - asm_rls = []: rls' list,*)
144.418 - ppc = []: (string * (term * term)) list,
144.419 - pre = []: term list,
144.420 - scr = EmptyScr: scr}:met;
144.421 -
144.422 -
144.423 -(** problem-types stored in format for usage in specify **)
144.424 -(*25.8.01 ----
144.425 -val pbltypes = ref ([(e_pblID,[])]:(pblID * ((string * (* field "#Given",..*)
144.426 - (term * (* description *)
144.427 - term)) (* id | struct-var *)
144.428 - list)
144.429 - ) list);*)
144.430 -
144.431 -(*deprecated due to 'type pat'*)
144.432 -type pbt_ = (string * (* field "#Given",..*)
144.433 - (term * (* description *)
144.434 - term)); (* id | struct-var *)
144.435 -val e_pbt_ = ("#Undef", (e_term, e_term)):pbt_;
144.436 -type pbt =
144.437 - {guh : guh, (*unique within this isac-knowledge*)
144.438 - mathauthors: string list, (*copyright*)
144.439 - init : pblID, (*to start refinement with*)
144.440 - thy : theory, (* which allows to compile that pbt
144.441 - TODO: search generalized for subthy (ref.p.69*)
144.442 - (*^^^ WN050912 NOT used during application of the problem,
144.443 - because applied terms may be from 'subthy' as well as from super;
144.444 - thus we take 'maxthy'; see match_ags !*)
144.445 - cas : term option,(*'CAS-command'*)
144.446 - prls : rls, (* for preds in where_*)
144.447 - where_: term list, (* where - predicates*)
144.448 - ppc : pat list,
144.449 - (*this is the model-pattern;
144.450 - it contains "#Given","#Where","#Find","#Relate"-patterns*)
144.451 - met : metID list}; (* methods solving the pbt*)
144.452 -val e_pbt = {guh="pbl_empty",mathauthors=[],init=e_pblID,thy=theory "Pure",
144.453 - cas=NONE,prls=Erls,where_=[],ppc=[],met=[]}:pbt;
144.454 -fun pbt2 (str, (t1, t2)) =
144.455 - pair2str (str, pair2str (term2str t1, term2str t2));
144.456 -fun pbt2str pbt = (strs2str o (map (linefeed o pbt2))) pbt;
144.457 -
144.458 -
144.459 -val e_Ptyp = Ptyp ("e_pblID",[e_pbt],[]);
144.460 -val e_Mets = Ptyp ("e_metID",[e_met],[]);
144.461 -
144.462 -type ptyps = (pbt ptyp) list;
144.463 -val ptyps = ref ([e_Ptyp]:ptyps);
144.464 -
144.465 -type mets = (met ptyp) list;
144.466 -val mets = ref ([e_Mets]:mets);
144.467 -
144.468 -
144.469 -(**+ breadth-first search on hierarchy of problem-types +**)
144.470 -
144.471 -type pblRD = pblID;(*pblID are Reverted _on calling_ the retrieve-funs*)
144.472 - (* eg. ["equations","univariate","normalize"] while
144.473 - ["normalize","univariate","equations"] is the related pblID
144.474 - WN.24.4.03: also used for metID*)
144.475 -
144.476 -fun get_py thy d _ [] =
144.477 - error ("get_pbt not found: "^(strs2str d))
144.478 - | get_py thy d [k] ((Ptyp (k',[py],_))::pys) =
144.479 - if k=k' then py
144.480 - else get_py thy d ([k]:pblRD) pys
144.481 - | get_py thy d (k::ks) ((Ptyp (k',_,pys))::pys') =
144.482 - if k=k' then get_py thy d ks pys
144.483 - else get_py thy d (k::ks) pys';
144.484 -(*> ptyps:=
144.485 -[Ptyp ("1",[("ptyp 1",([],[]))],
144.486 - [Ptyp ("11",[("ptyp 11",([],[]))],
144.487 - [])
144.488 - ]),
144.489 - Ptyp ("2",[("ptyp 2",([],[]))],
144.490 - [Ptyp ("21",[("ptyp 21",([],[]))],
144.491 - [])
144.492 - ])
144.493 - ];
144.494 -> get_py SqRoot.thy ["1"] ["1"] (!ptyps);
144.495 -> get_py SqRoot.thy ["2","21"] ["2","21"] (!ptyps);
144.496 - _REVERSE_ .......... !!!!!!!!!!*)
144.497 -
144.498 -(*TODO: search generalized for subthy*)
144.499 -fun get_pbt (pblID:pblID) =
144.500 - let val pblRD = rev pblID;
144.501 - in get_py (theory "Pure") pblID pblRD (!ptyps) end;
144.502 -(* get_pbt thy ["1"];
144.503 - get_pbt thy ["21","2"];
144.504 - *)
144.505 -
144.506 -(*TODO: throws exn 'get_pbt not found: ' ... confusing !!
144.507 - take 'ketype' as an argument !!!!!*)
144.508 -fun get_met (metID:metID) = get_py (theory "Pure") metID metID (!mets);
144.509 -fun get_the (theID:theID) = get_py (theory "Pure") theID theID (!thehier);
144.510 -
144.511 -
144.512 -
144.513 -fun del_eq k ptyps =
144.514 -let fun del k ptyps [] = ptyps
144.515 - | del k ptyps ((Ptyp (k', [p], ps))::pys) =
144.516 - if k=k' then del k ptyps pys
144.517 - else del k (ptyps @ [Ptyp (k', [p], ps)]) pys;
144.518 -in del k [] ptyps end;
144.519 -
144.520 -fun insrt d pbt [k] [] = [Ptyp (k, [pbt],[])]
144.521 -
144.522 - | insrt d pbt [k] ((Ptyp (k', [p], ps))::pys) =
144.523 -((*writeln("### insert 1: ks = "^(strs2str [k])^" k'= "^k');*)
144.524 - if k=k'
144.525 - then ((Ptyp (k', [pbt], ps))::pys)
144.526 - else (*ev.newly added pbt is free _only_ with 'last_elem pblID'*)
144.527 - ((Ptyp (k', [p], ps))::(insrt d pbt [k] pys))
144.528 -)
144.529 - | insrt d pbt (k::ks) ((Ptyp (k', [p], ps))::pys) =
144.530 -((*writeln("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*)
144.531 - if k=k'
144.532 - then ((Ptyp (k', [p], insrt d pbt ks ps))::pys)
144.533 - else
144.534 - if length pys = 0
144.535 - then error ("insert: not found "^(strs2str (d:pblID)))
144.536 - else ((Ptyp (k', [p], ps))::(insrt d pbt (k::ks) pys))
144.537 -);
144.538 -
144.539 -
144.540 -fun coll_pblguhs pbls =
144.541 - let fun node coll (Ptyp (_,[n],ns)) =
144.542 - [(#guh : pbt -> guh) n] @ (nodes coll ns)
144.543 - and nodes coll [] = coll
144.544 - | nodes coll (n::ns) = (node coll n) @ (nodes coll ns);
144.545 - in nodes [] pbls end;
144.546 -fun coll_metguhs mets =
144.547 - let fun node coll (Ptyp (_,[n],ns)) =
144.548 - [(#guh : met -> guh) n]
144.549 - and nodes coll [] = coll
144.550 - | nodes coll (n::ns) = (node coll n) @ (nodes coll ns);
144.551 - in nodes [] mets end;
144.552 -
144.553 -(*.lookup a guh in hierarchy or methods depending on fst chars in guh.*)
144.554 -fun guh2kestoreID (guh:guh) =
144.555 - case (implode o (take_fromto 1 4) o explode) guh of
144.556 - "pbl_" =>
144.557 - let fun node ids gu (Ptyp (id,[n as {guh,...} : pbt], ns)) =
144.558 - if gu = guh
144.559 - then SOME ((ids@[id]) : kestoreID)
144.560 - else nodes (ids@[id]) gu ns
144.561 - and nodes _ _ [] = NONE
144.562 - | nodes ids gu (n::ns) =
144.563 - case node ids gu n of SOME id => SOME id
144.564 - | NONE => nodes ids gu ns
144.565 - in case nodes [] guh (!ptyps) of
144.566 - SOME id => rev id
144.567 - | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^
144.568 - "not found in (!ptyps)")
144.569 - end
144.570 - | "met_" =>
144.571 - let fun node ids gu (Ptyp (id,[n as {guh,...} : met], ns)) =
144.572 - if gu = guh
144.573 - then SOME ((ids@[id]) : kestoreID)
144.574 - else nodes (ids@[id]) gu ns
144.575 - and nodes _ _ [] = NONE
144.576 - | nodes ids gu (n::ns) =
144.577 - case node ids gu n of SOME id => SOME id
144.578 - | NONE => nodes ids gu ns
144.579 - in case nodes [] guh (!mets) of
144.580 - SOME id => id
144.581 - | NONE => error ("guh2kestoreID: '" ^ guh ^ "' " ^
144.582 - "not found in (!mets)") end
144.583 - | _ => error ("guh2kestoreID called with '" ^ guh ^ "'");
144.584 -(*> guh2kestoreID "pbl_equ_univ_lin";
144.585 -val it = ["linear", "univariate", "equation"] : string list*)
144.586 -
144.587 -
144.588 -fun check_pblguh_unique (guh:guh) (pbls: (pbt ptyp) list) =
144.589 - if member op = (coll_pblguhs pbls) guh
144.590 - then error ("check_guh_unique failed with '"^guh^"';\n"^
144.591 - "use 'sort_pblguhs()' for a list of guhs;\n"^
144.592 - "consider setting 'check_guhs_unique := false'")
144.593 - else ();
144.594 -(* val (guh, mets) = ("met_test", !mets);
144.595 - *)
144.596 -fun check_metguh_unique (guh:guh) (mets: (met ptyp) list) =
144.597 - if member op = (coll_metguhs mets) guh
144.598 - then error ("check_guh_unique failed with '"^guh^"';\n"^
144.599 - "use 'sort_metguhs()' for a list of guhs;\n"^
144.600 - "consider setting 'check_guhs_unique := false'")
144.601 - else ();
144.602 -
144.603 -
144.604 -
144.605 -(*.the pblID has the leaf-element as first; better readability achieved;.*)
144.606 -fun store_pbt (pbt as {guh,...}, pblID) =
144.607 - (if (!check_guhs_unique) then check_pblguh_unique guh (!ptyps) else ();
144.608 - ptyps:= insrt pblID pbt (rev pblID) (!ptyps));
144.609 -
144.610 -(*.the metID has the root-element as first; compare 'fun store_pbt'.*)
144.611 -(* val (met as {guh,...}, metID) =
144.612 - ((prep_met EqSystem.thy "met_eqsys" [] e_metID
144.613 - (["EqSystem"],
144.614 - [],
144.615 - {rew_ord'="tless_true", rls' = Erls, calc = [],
144.616 - srls = Erls, prls = Erls, crls = Erls, nrls = Erls},
144.617 - "empty_script"
144.618 - )));
144.619 - *)
144.620 -fun store_met (met as {guh,...}, metID) =
144.621 - (if (!check_guhs_unique) then check_metguh_unique guh (!mets) else ();
144.622 - mets:= insrt metID met metID (!mets));
144.623 -
144.624 -
144.625 -(*. prepare problem-types before storing in pbltypes;
144.626 - dont forget to 'check_guh_unique' before ins.*)
144.627 -fun prep_pbt thy guh maa init
144.628 - (pblID, dsc_dats: (string * (string list)) list,
144.629 - ev:rls, ca: string option, metIDs:metID list) =
144.630 -(* val (thy, (pblID, dsc_dats: (string * (string list)) list,
144.631 - ev:rls, ca: string option, metIDs:metID list)) =
144.632 - ((EqSystem.thy, (["system"],
144.633 - [("#Given" ,["equalities es_", "solveForVars vs_"]),
144.634 - ("#Find" ,["solution ss___"](*___ is copy-named*))
144.635 - ],
144.636 - append_rls "e_rls" e_rls [(*for preds in where_*)],
144.637 - SOME "solveSystem es_ vs_",
144.638 - [])));
144.639 - *)
144.640 - let fun eq f (f', _) = f = f';
144.641 - val gi = filter (eq "#Given") dsc_dats;
144.642 -(*val gi = [("#Given",["equality e_","solveFor v_"])]
144.643 - : (string * string list) list*)
144.644 - val gi = (case gi of
144.645 - [] => []
144.646 - | ((_,gi')::[]) =>
144.647 - ((map (split_did o term_of o the o (parse thy)) gi')
144.648 - handle _ => error
144.649 - ("prep_pbt: syntax error in '#Given' of "^
144.650 - (strs2str pblID)))
144.651 - | _ =>
144.652 - (error ("prep_pbt: more than one '#Given' in "^
144.653 - (strs2str pblID))));
144.654 -(*val gi =
144.655 - [(Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool")),
144.656 - (Const ("Descript.solveFor","RealDef.real => Tools.una"),
144.657 - Free ("v_","RealDef.real"))] : (term * term) list *)
144.658 - val gi = map (pair "#Given") gi;
144.659 -(*val gi =
144.660 - [("#Given",
144.661 - (Const ("Descript.equality","bool => Tools.una"),Free ("e_","bool"))),
144.662 - ("#Given",
144.663 - (Const ("Descript.solveFor","RealDef.real => Tools.una"),
144.664 - Free ("v_","RealDef.real")))] : (string * (term * term)) list*)
144.665 -
144.666 - val fi = filter (eq "#Find") dsc_dats;
144.667 - val fi = (case fi of
144.668 - [] => [](*28.8.01: ["tool"] ...// raise error
144.669 - ("prep_pbt: no '#Find' in "^(strs2str pblID))*)
144.670 -(* val ((_,fi')::[]) = fi;
144.671 - *)
144.672 - | ((_,fi')::[]) =>
144.673 - ((map (split_did o term_of o the o (parse thy)) fi')
144.674 - handle _ => raise error
144.675 - ("prep_pbt: syntax error in '#Find' of "^
144.676 - (strs2str pblID)))
144.677 - | _ =>
144.678 - (raise error ("prep_pbt: more than one '#Find' in "^
144.679 - (strs2str pblID))));
144.680 - val fi = map (pair "#Find") fi;
144.681 -
144.682 - val re = filter (eq "#Relate") dsc_dats;
144.683 - val re = (case re of
144.684 - [] => []
144.685 - | ((_,re')::[]) =>
144.686 - ((map (split_did o term_of o the o (parse thy)) re')
144.687 - handle _ => raise error
144.688 - ("prep_pbt: syntax error in '#Relate' of "^
144.689 - (strs2str pblID)))
144.690 - | _ =>
144.691 - (raise error ("prep_pbt: more than one '#Relate' in "^
144.692 - (strs2str pblID))));
144.693 - val re = map (pair "#Relate") re;
144.694 -
144.695 - val wh = filter (eq "#Where") dsc_dats;
144.696 - val wh = (case wh of
144.697 - [] => []
144.698 - | ((_,wh')::[]) =>
144.699 - ((map (term_of o the o (parse thy)) wh')
144.700 - handle _ => raise error
144.701 - ("prep_pbt: syntax error in '#Where' of "^
144.702 - (strs2str pblID)))
144.703 - | _ =>
144.704 - (raise error ("prep_pbt: more than one '#Where' in "^
144.705 - (strs2str pblID))));
144.706 - in ({guh=guh,mathauthors=maa,init=init,
144.707 - thy=thy,cas= case ca of NONE => NONE
144.708 - | SOME s =>
144.709 - SOME ((term_of o the o (parse thy)) s),
144.710 - prls=ev,where_=wh,ppc= gi @ fi @ re,
144.711 - met=metIDs}, pblID):pbt * pblID end;
144.712 -(* prep_pbt thy (pblID, dsc_dats, metIDs);
144.713 - val it =
144.714 - ({met=[],
144.715 - ppc=[("#Given",(Const (#,#),Free (#,#))),
144.716 - ("#Given",(Const (#,#),Free (#,#))),
144.717 - ("#Find",(Const (#,#),Free (#,#)))],
144.718 - thy={ProtoPure, ..., Atools, RatArith},
144.719 - where_=[Const ("Descript.solutions","bool List.list => Tools.toreall") $
144.720 - Free ("v_i_","bool List.list")]},["equation"]) : pbt * pblID *)
144.721 -
144.722 -
144.723 -
144.724 -
144.725 -(*. prepare met for storage analogous to pbt .*)
144.726 -fun prep_met thy guh maa init
144.727 - (metID, ppc: (string * string list) list (*'#Where' -> #pre*),
144.728 - {rew_ord'=ro, rls'=rls, srls=srls, prls=prls,
144.729 - calc = scr_isa_fns(*FIXME.040207: del - auto-done*),
144.730 - crls=cr, nrls=nr}, scr) =
144.731 - let fun eq f (f', _) = f = f';
144.732 - (*val thy = (assoc_thy o fst) metID*)
144.733 - val gi = filter (eq "#Given") ppc;
144.734 - val gi = (case gi of
144.735 - [] => []
144.736 - | ((_,gi')::[]) =>
144.737 - ((map (split_did o term_of o the o (parse thy)) gi')
144.738 - handle _ => raise error
144.739 - ("prep_pbt: syntax error in '#Given' of "^
144.740 - (strs2str metID)))
144.741 - | _ =>
144.742 - (raise error ("prep_pbt: more than one '#Given' in "^
144.743 - (strs2str metID))));
144.744 - val gi = map (pair "#Given") gi;
144.745 -
144.746 - val fi = filter (eq "#Find") ppc;
144.747 - val fi = (case fi of
144.748 - [] => [](*28.8.01: ["tool"] ...// raise error
144.749 - ("prep_pbt: no '#Find' in "^(strs2str metID))*)
144.750 - | ((_,fi')::[]) =>
144.751 - ((map (split_did o term_of o the o (parse thy)) fi')
144.752 - handle _ => raise error
144.753 - ("prep_pbt: syntax error in '#Find' of "^
144.754 - (strs2str metID)))
144.755 - | _ =>
144.756 - (raise error ("prep_pbt: more than one '#Find' in "^
144.757 - (strs2str metID))));
144.758 - val fi = map (pair "#Find") fi;
144.759 -
144.760 - val re = filter (eq "#Relate") ppc;
144.761 - val re = (case re of
144.762 - [] => []
144.763 - | ((_,re')::[]) =>
144.764 - ((map (split_did o term_of o the o (parse thy)) re')
144.765 - handle _ => raise error
144.766 - ("prep_pbt: syntax error in '#Relate' of "^
144.767 - (strs2str metID)))
144.768 - | _ =>
144.769 - (raise error ("prep_pbt: more than one '#Relate' in "^
144.770 - (strs2str metID))));
144.771 - val re = map (pair "#Relate") re;
144.772 -
144.773 - val wh = filter (eq "#Where") ppc;
144.774 - val wh = (case wh of
144.775 - [] => []
144.776 - | ((_,wh')::[]) =>
144.777 - ((map (term_of o the o (parse thy)) wh')
144.778 - handle _ => raise error
144.779 - ("prep_pbt: syntax error in '#Where' of "^
144.780 - (strs2str metID)))
144.781 - | _ =>
144.782 - (raise error ("prep_pbt: more than one '#Where' in "^
144.783 - (strs2str metID))));
144.784 - val sc = (((inst_abs thy) o term_of o the o (parse thy)) scr)
144.785 - in ({guh=guh,mathauthors=maa,init=init,
144.786 - ppc=gi@fi@re, pre=wh, rew_ord'=ro, erls=rls, srls=srls, prls=prls,
144.787 - calc = if scr = "empty_script" then []
144.788 - else ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
144.789 - (filter is_calc) o stacpbls) sc,
144.790 - crls=cr, nrls=nr, scr=Script sc}:met,
144.791 - metID:metID)
144.792 - end;
144.793 -
144.794 -
144.795 -(**. get pblIDs of all entries in mat3D .**)
144.796 -
144.797 -
144.798 -fun format_pblID strl = enclose " [" "]" (commas_quote strl);
144.799 -fun format_pblIDl strll = enclose "[\n" "\n]\n"
144.800 - (space_implode ",\n" (map format_pblID strll));
144.801 -
144.802 -fun scan _ [] = [] (* no base case, for empty doms only *)
144.803 - | scan id ((Ptyp ((i,_,[])))::[]) = [id@[i]]
144.804 - | scan id ((Ptyp ((i,_,pl)))::[]) = scan (id@[i]) pl
144.805 - | scan id ((Ptyp ((i,_,[])))::ps) = [id@[i]] @(scan id ps)
144.806 - | scan id ((Ptyp ((i,_,pl)))::ps) =(scan (id@[i]) pl)@(scan id ps);
144.807 -
144.808 -fun show_ptyps () = (writeln o format_pblIDl o (scan [])) (!ptyps);
144.809 -(* ptyps:=[];
144.810 - show_ptyps();
144.811 - *)
144.812 -fun show_mets () = (writeln o format_pblIDl o (scan [])) (!mets);
144.813 -
144.814 -
144.815 -
144.816 -(*vvvvv---------- preparational work 8.01. UNUSED *)
144.817 -(**+ instantiate a problem-type +**)
144.818 -
144.819 -(*+ transform oris +*)
144.820 -
144.821 -fun coll_vats (vats, ((_,vs,_,_,_):ori)) = union op = vats vs;
144.822 -(*> coll_vats [11,22] (hd oris);
144.823 -val it = [22,11,1,2,3] : int list
144.824 -
144.825 -> foldl coll_vats ([],oris);
144.826 -val it = [1,2,3] : int list
144.827 -
144.828 -> val i=1;
144.829 -> filter ((curry (op mem) i) o #2) oris;
144.830 -val it =
144.831 - [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
144.832 - (2,[1,2,3],"#Find",Const (#,#),[Free #]),
144.833 - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
144.834 - (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
144.835 - (6,[1],"#undef",Const (#,#),[Free #]),
144.836 - (9,[1,2],"#undef",Const (#,#),[# $ #]),
144.837 - (11,[1,2,3],"#undef",Const (#,#),[# $ #])] : ori list *)
144.838 -
144.839 -local infix mem; (*from Isabelle2002*)
144.840 -fun x mem [] = false
144.841 - | x mem (y :: ys) = x = y orelse x mem ys;
144.842 -in
144.843 -fun filter_vat oris i =
144.844 - filter ((curry (op mem) i) o (#2 : ori -> int list)) oris;
144.845 -end;
144.846 -(*> map (filter_vat oris) [1,2,3];
144.847 -val it =
144.848 - [[(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
144.849 - (2,[1,2,3],"#Find",Const (#,#),[Free #]),
144.850 - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
144.851 - (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
144.852 - (6,[1],"#undef",Const (#,#),[Free #]),
144.853 - (9,[1,2],"#undef",Const (#,#),[# $ #]),
144.854 - (11,[1,2,3],"#undef",Const (#,#),[# $ #])],
144.855 - [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
144.856 - (2,[1,2,3],"#Find",Const (#,#),[Free #]),
144.857 - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
144.858 - (4,[1,2],"#Relate",Const (#,#),[# $ #,# $ #]),
144.859 - (7,[2],"#undef",Const (#,#),[Free #]),
144.860 - (9,[1,2],"#undef",Const (#,#),[# $ #]),
144.861 - (11,[1,2,3],"#undef",Const (#,#),[# $ #])],
144.862 - [(1,[1,2,3],"#Given",Const (#,#),[# $ #]),
144.863 - (2,[1,2,3],"#Find",Const (#,#),[Free #]),
144.864 - (3,[1,2,3],"#Find",Const (#,#),[# $ #,# $ #]),
144.865 - (5,[3],"#Relate",Const (#,#),[# $ #,# $ #,# $ #]),
144.866 - (8,[3],"#undef",Const (#,#),[Free #]),
144.867 - (10,[3],"#undef",Const (#,#),[# $ #]),
144.868 - (11,[1,2,3],"#undef",Const (#,#),[# $ #])]] : ori list list*)
144.869 -
144.870 -fun separate_vats oris =
144.871 - let val vats = foldl coll_vats ([] : int list, oris);
144.872 - in map (filter_vat oris) vats end;
144.873 -(*^^^ end preparational work 8.01.*)
144.874 -
144.875 -
144.876 -
144.877 -(**. check a problem (ie. itm list) for matching a problemtype .**)
144.878 -
144.879 -fun eq1 d (_,(d',_)) = (d = d');
144.880 -fun itm_id ((i,_,_,_,_):itm) = i;
144.881 -fun ori_id ((i,_,_,_,_):ori) = i;
144.882 -fun ori2itmSup ((i,v,_,d,ts):ori) = ((i,v,true,"#Given",Sup(d,ts)):itm);
144.883 -(*see + add_sel_ppc ~~~~~~~*)
144.884 -fun field_eq f ((_,_,f',_,_):ori) = f = f';
144.885 -
144.886 -(*. check an item (with arbitrary itm_ from previous matchings)
144.887 - for matching a problemtype; returns true only for itms found in pbt .*)
144.888 -fun chk_ thy pbt ((i,vats,b,f,Cor ((d,vs),_)):itm) =
144.889 - (case find_first (eq1 d) pbt of
144.890 - SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
144.891 - (id, pbl_ids' thy d vs))):itm)
144.892 - | NONE => (i,vats,false,f,Sup (d,vs)))
144.893 - | chk_ thy pbt ((i,vats,b,f,Inc ((d,vs),_)):itm) =
144.894 - (case find_first (eq1 d) pbt of
144.895 - SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
144.896 - (id, pbl_ids' thy d vs))):itm)
144.897 - | NONE => (i,vats,false,f,Sup (d,vs)))
144.898 -
144.899 - | chk_ thy pbt (itm as (i,vats,b,f,Syn ct):itm) = itm
144.900 - | chk_ thy pbt (itm as (i,vats,b,f,Typ ct):itm) = itm
144.901 -
144.902 - | chk_ thy pbt ((i,vats,b,f,Sup (d,vs)):itm) =
144.903 - (case find_first (eq1 d) pbt of
144.904 - SOME (_,(_,id)) => ((i,vats,b,f,Cor ((d,vs),
144.905 - (id, pbl_ids' thy d vs))):itm)
144.906 - | NONE => (i,vats,false,f,Sup (d,vs)))
144.907 -(* val (i,vats,b,f,Mis (d,vs)) = i4;
144.908 - *)
144.909 - | chk_ thy pbt ((i,vats,b,f,Mis (d,vs)):itm) =
144.910 - (case find_first (eq1 d) pbt of
144.911 -(* val SOME (_,(_,id)) = find_first (eq1 d) pbt;
144.912 - *)
144.913 - SOME (_,(_,id)) => raise error "chk_: ((i,vats,b,f,Cor ((d,vs),\
144.914 - \(id, pbl_ids' d vs))):itm)"
144.915 - | NONE => (i,vats,false,f,Sup (d,[vs])));
144.916 -
144.917 -(* chk_ thy pbt i
144.918 - *)
144.919 -
144.920 -fun eq2 (_,(d,_)) ((_,_,_,_,itm_):itm) = d = d_in itm_;
144.921 -fun eq2' (_,(d,_)) ((_,_,_,d',_):ori) = d = d';
144.922 -fun eq0 ((0,_,_,_,_):itm) = true
144.923 - | eq0 _ = false;
144.924 -fun max_i i [] = i
144.925 - | max_i i ((id,_,_,_,_)::is) =
144.926 - if i > id then max_i i is else max_i id is;
144.927 -fun max_id [] = 0
144.928 - | max_id ((id,_,_,_,_)::is) = max_i id is;
144.929 -fun add_idvat itms _ _ [] = itms
144.930 - | add_idvat itms i mvat (((_,_,b,f,itm_):itm)::its) =
144.931 - add_idvat (itms @ [(i,[(*mvat ...meaningless with pbl-identifier *)
144.932 - ],b,f,itm_):itm]) (i+1) mvat its;
144.933 -
144.934 -
144.935 -(*. find elements of pbt not contained in itms;
144.936 - if such one is untouched, return this one, otherwise create new itm .*)
144.937 -fun chk_m (itms:itm list) untouched (p as (f,(d,id))) =
144.938 - case find_first (eq2 p) itms of
144.939 - SOME _ => []
144.940 - | NONE => (case find_first (eq2 p) untouched of
144.941 - SOME itm => [itm]
144.942 - | NONE => [(0,[],false,f,Mis (d,id)):itm]);
144.943 -(* val itms = itms'';
144.944 - *)
144.945 -fun chk_mis mvat itms untouched pbt =
144.946 - let val mis = (flat o (map (chk_m itms untouched))) pbt;
144.947 - val mid = max_id itms;
144.948 - in add_idvat [] (mid + 1) mvat mis end;
144.949 -
144.950 -(*. check a problem (ie. itm list) for matching a problemtype,
144.951 - takes the max_vt for concluding completeness (could be another!) .*)
144.952 -(* val itms = itms'; val (pbt,pre) = (ppc, pre);
144.953 - val itms = itms; val (pbt,pre) = (ppc, pre);
144.954 - *)
144.955 -fun match_itms thy itms (pbt,pre,prls) =
144.956 - (let fun okv mvat (_,vats,b,_,_) = member op = vats mvat
144.957 - andalso b;
144.958 - val itms' = map (chk_ thy pbt) itms; (*all found are #3 true*)
144.959 - val mvat = max_vt itms';
144.960 - val itms'' = filter (okv mvat) itms';
144.961 - val untouched = filter eq0 itms;(*i.e. dsc only (from init)*)
144.962 - val mis = chk_mis mvat itms'' untouched pbt;
144.963 - val pre' = check_preconds' prls pre itms'' mvat
144.964 - val pb = foldl and_ (true, map fst pre')
144.965 - in (length mis = 0 andalso pb, (itms'@ mis, pre')) end);
144.966 -
144.967 -(*. check a problem pbl (ie. itm list) for matching a problemtype pbt,
144.968 - for missing items get data from formalization (ie. ori list);
144.969 - takes the max_vt for concluding completeness (could be another!) .*)
144.970 -(* (0) determine the most frequent variant mv in pbl
144.971 - ALL pbt. (1) dsc(pbt) notmem dsc(pbls) =>
144.972 - (2) filter (dsc(pbt) = dsc(oris)) oris; -> news;
144.973 - (3) newitms = filter (mv mem vat(news)) news
144.974 - (4) pbt @ newitms *)
144.975 -(* val (pbl, pbt, pre) = (met, mtt, pre);
144.976 - val (pbl, pbt, pre) = (itms, #ppc pbt, #where_ pbt);
144.977 - val (pbl, pbt, pre) = (itms, ppc, where_);
144.978 - *)
144.979 -fun match_itms_oris thy (pbl:itm list) (pbt, pre, prls) oris =
144.980 - let
144.981 - (*0*)val mv = max_vt pbl;
144.982 -
144.983 - fun eqdsc_pbt_itm ((_,(d,_))) ((_,_,_,_,itm_):itm) = d = d_in itm_;
144.984 - fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of
144.985 - SOME _ => false | NONE => true;
144.986 - (*1*)val mis = (*(map (cons2 (fst, fst o snd)))o*) (filter (notmem pbl)) pbt;
144.987 -
144.988 - fun eqdsc_ori (_,(d,_)) ((_,_,_,d',_):ori) = d = d';
144.989 - fun ori2itmMis (f,(d,pid)) ((i,v,_,_,ts):ori) =
144.990 - (i,v,false,f,Mis (d,pid)):itm;
144.991 - (*2*)fun oris2itms oris mis1 =
144.992 - ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris;
144.993 - val news = (flat o (map (oris2itms oris))) mis;
144.994 - (*3*)fun mem_vat (_,vats,b,_,_) = member op = vats mv;
144.995 - val newitms = filter mem_vat news;
144.996 - (*4*)val itms' = pbl @ newitms;
144.997 - val pre' = check_preconds' prls pre itms' mv
144.998 - val pb = foldl and_ (true, map fst pre')
144.999 - in (length mis = 0 andalso pb, (itms', pre')) end;
144.1000 - (*handle _ => (false,([],[]))*);
144.1001 -
144.1002 -
144.1003 -(*vvv--- doubled 20.9.01: ... 7.3.02 itms --> oris, because oris
144.1004 - allow for faster access to descriptions and terms *)
144.1005 -(**. check a problem (ie. itm list) for matching a problemtype .**)
144.1006 -
144.1007 -(*. check an ori for matching a problemtype by description;
144.1008 - returns true only for itms found in pbt .*)
144.1009 -fun chk1_ thy pbt ((i,vats,f,d,vs):ori) =
144.1010 - case find_first (eq1 d) pbt of
144.1011 - SOME (_,(_,id)) => [(i,vats,true,f,
144.1012 - Cor ((d,vs), (id, pbl_ids' thy d vs))):itm]
144.1013 - | NONE => [];
144.1014 -
144.1015 -(* elem 'p' of pbt contained in itms ? *)
144.1016 -fun chk1_m (itms:itm list) p =
144.1017 - case find_first (eq2 p) itms of
144.1018 - SOME _ => true | NONE => false;
144.1019 -fun chk1_m' (oris: ori list) (p as (f,(d,t))) =
144.1020 - case find_first (eq2' p) oris of
144.1021 - SOME _ => []
144.1022 - | NONE => [(f, Mis (d, t))];
144.1023 -fun pair0vatsfalse (f,itm_) = (0,[],false,f,itm_):itm;
144.1024 -
144.1025 -fun chk1_mis mvat itms ppc = foldl and_ (true, map (chk1_m itms) ppc);
144.1026 -fun chk1_mis' oris ppc =
144.1027 - map pair0vatsfalse ((flat o (map (chk1_m' oris))) ppc);
144.1028 -
144.1029 -
144.1030 -(*. check a problem (ie. ori list) for matching a problemtype,
144.1031 - takes the max_vt for concluding completeness (FIXME could be another!) .*)
144.1032 -(* val (prls,oris,pbt,pre)=(#prls py, ori, #ppc py, #where_ py);
144.1033 - *)
144.1034 -fun match_oris thy prls oris (pbt,pre) =
144.1035 - let val itms = (flat o (map (chk1_ thy pbt))) oris;
144.1036 - val mvat = max_vt itms;
144.1037 - val complete = chk1_mis mvat itms pbt;
144.1038 - val pre' = check_preconds' prls pre itms mvat
144.1039 - val pb = foldl and_ (true, map fst pre')
144.1040 - in if complete andalso pb then true else false end;
144.1041 -(*run subp-rooteq.sml 'root-eq + subpbl: solve_linear'
144.1042 - until 'val nxt = ("Model_Problem",Model_Problem ["linear","univariate"...
144.1043 -> val Nd(PblObj _,[_,_,_,_,_,_,_,_,_,_,_,
144.1044 - Nd(PblObj{origin=(oris,_,_),...},[])]) = pt;
144.1045 -> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"],
144.1046 - (#where_ o get_pbt) ["linear","univariate","equation"]);
144.1047 -> match_oris oris (pbt,pre);
144.1048 -val it = true : bool
144.1049 -
144.1050 -
144.1051 -> val (pbt,pre) =((#ppc o get_pbt) ["plain_square","univariate","equation"],
144.1052 - (#where_ o get_pbt)["plain_square","univariate","equation"]);
144.1053 -> match_oris oris (pbt,pre);
144.1054 -val it = false : bool
144.1055 -
144.1056 -
144.1057 - ---------------------------------------------------
144.1058 - run subp-rooteq.sml 'root-eq + subpbl: solve_plain_square'
144.1059 - until 'val nxt = ("Model_Problem",Model_Problem ["plain_square","univ...
144.1060 -> val Nd (PblObj _, [_,_,_,_,_,_,_,Nd (PrfObj _,[]),
144.1061 - Nd (PblObj {origin=(oris,_,_),...},[])]) = pt;
144.1062 -> val (pbt,pre) = ((#ppc o get_pbt) ["linear","univariate","equation"],
144.1063 - (#where_ o get_pbt) ["linear","univariate","equation"]);
144.1064 -> match_oris oris (pbt,pre);
144.1065 -val it = false : bool
144.1066 -
144.1067 -
144.1068 -> val (pbt,pre)=((#ppc o get_pbt) ["plain_square","univariate","equation"],
144.1069 - (#where_ o get_pbt) ["plain_square","univariate","equation"]);
144.1070 -> match_oris oris (pbt,pre);
144.1071 -val it = true : bool
144.1072 -*)
144.1073 -(*^^^--- doubled 20.9.01 *)
144.1074 -
144.1075 -
144.1076 -(*. check a problem (ie. ori list) for matching a problemtype,
144.1077 - returns items for output to math-experts .*)
144.1078 -(* val (ppc,pre) = (#ppc py, #where_ py);
144.1079 - *)
144.1080 -fun match_oris' thy oris (ppc,pre,prls) =
144.1081 -(* val (thy, oris, (ppc,pre,prls)) = (thy, oris, (ppc, where_, prls));
144.1082 - *)
144.1083 - let val itms = (flat o (map (chk1_ thy ppc))) oris;
144.1084 - val sups = ((map ori2itmSup) o (filter(field_eq "#undef")))oris;
144.1085 - val mvat = max_vt itms;
144.1086 - val miss = chk1_mis' oris ppc;
144.1087 - val pre' = check_preconds' prls pre itms mvat
144.1088 - val pb = foldl and_ (true, map fst pre')
144.1089 - in (miss = [] andalso pb, (itms @ miss @ sups, pre')) end;
144.1090 -
144.1091 -(*. for the user .*)
144.1092 -datatype match' =
144.1093 - Matches' of item ppc
144.1094 -| NoMatch' of item ppc;
144.1095 -
144.1096 -(*. match a formalization with a problem type .*)
144.1097 -fun match_pbl (fmz:fmz_) ({thy=thy,where_=pre,ppc,prls=er,...}:pbt) =
144.1098 - let val oris = prep_ori fmz thy ppc;
144.1099 - val (bool, (itms, pre')) = match_oris' thy oris (ppc,pre,er);
144.1100 - in if bool then Matches' (itms2itemppc thy itms pre')
144.1101 - else NoMatch' (itms2itemppc thy itms pre') end;
144.1102 -(*
144.1103 -val fmz = ["equality (sqrt(9+4*x)=sqrt x + sqrt(5+x))",
144.1104 - "solveFor x","errorBound (eps=0)","solutions L"];
144.1105 -val pbt as {thy = thy, where_ = pre, ppc = ppc,...} =
144.1106 - get_pbt ["univariate","equation"];
144.1107 -match_pbl fmz pbt;
144.1108 -*)
144.1109 -
144.1110 -
144.1111 -(*. refine a problem; construct pblRD while scanning .*)
144.1112 -(* val (pblRD,ori)=("xxx",oris);
144.1113 - val py = get_pbt ["equation"];
144.1114 - val py = get_pbt ["univariate","equation"];
144.1115 - val py = get_pbt ["linear","univariate","equation"];
144.1116 - val py = get_pbt ["root","univariate","equation"];
144.1117 - match_oris (#prls py) ori (#ppc py, #where_ py);
144.1118 -
144.1119 - *)
144.1120 -fun refin (pblRD:pblRD) ori
144.1121 -((Ptyp (pI,[py],[])):pbt ptyp) =
144.1122 - if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py)
144.1123 - then SOME ((pblRD @ [pI]):pblRD)
144.1124 - else NONE
144.1125 - | refin pblRD ori (Ptyp (pI,[py],pys)) =
144.1126 - if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py)
144.1127 - then (case refins (pblRD @ [pI]) ori pys of
144.1128 - SOME pblRD' => SOME pblRD'
144.1129 - | NONE => SOME (pblRD @ [pI]))
144.1130 - else NONE
144.1131 -and refins pblRD ori [] = NONE
144.1132 - | refins pblRD ori ((p as Ptyp (pI,_,_))::pts) =
144.1133 - (case refin pblRD ori p of
144.1134 - SOME pblRD' => SOME pblRD'
144.1135 - | NONE => refins pblRD ori pts);
144.1136 -
144.1137 -(*. refine a problem; version providing output for math-experts .*)
144.1138 -fun refin' (pblRD:pblRD) fmz pbls ((Ptyp (pI,[py],[])):pbt ptyp) =
144.1139 -(* val ((pblRD:pblRD), fmz, pbls, ((Ptyp (pI,[py],[])):pbt ptyp)) =
144.1140 - (rev ["linear","system"], fmz, [(*match list*)],
144.1141 - ((Ptyp ("2x2",[get_pbt ["2x2","linear","system"]],[])):pbt ptyp));
144.1142 - *)
144.1143 - let val _ = (writeln o ((curry op^)"*** pass ") o strs2str)(pblRD @ [pI])
144.1144 - val {thy,ppc,where_,prls,...} = py
144.1145 - val oris = prep_ori fmz thy ppc
144.1146 - (*8.3.02: itms!: oris ev. are _not_ complete here*)
144.1147 - val (b, (itms, pre')) = match_oris' thy oris (ppc, where_, prls)
144.1148 - in if b then pbls @ [Matches (rev (pblRD @ [pI]),
144.1149 - itms2itemppc thy itms pre')]
144.1150 - else pbls @ [NoMatch (rev (pblRD @ [pI]),
144.1151 - itms2itemppc thy itms pre')]
144.1152 - end
144.1153 -(* val pblRD = ["pbla"]; val fmz = fmz1; val pbls = [];
144.1154 - val Ptyp (pI,[py],pys) = hd (!ptyps);
144.1155 - refin' pblRD fmz pbls (Ptyp (pI,[py],pys));
144.1156 -*)
144.1157 - | refin' pblRD fmz pbls (Ptyp (pI,[py],pys)) =
144.1158 - let val _ = (writeln o ((curry op^)"*** pass ") o strs2str) (pblRD @ [pI])
144.1159 - val {thy,ppc,where_,prls,...} = py
144.1160 - val oris = prep_ori fmz thy ppc;
144.1161 - (*8.3.02: itms!: oris ev. are _not_ complete here*)
144.1162 - val(b, (itms, pre')) = match_oris' thy oris (ppc,where_,prls);
144.1163 - in if b
144.1164 - then let val pbl = Matches (rev (pblRD @ [pI]),
144.1165 - itms2itemppc thy itms pre')
144.1166 - in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end
144.1167 - else (pbls @ [NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')])
144.1168 - end
144.1169 -and refins' pblRD fmz pbls [] = pbls
144.1170 - | refins' pblRD fmz pbls ((p as Ptyp (pI,_,_))::pts) =
144.1171 - let val pbls' = refin' pblRD fmz pbls p
144.1172 - in case last_elem pbls' of
144.1173 - Matches _ => pbls'
144.1174 - | NoMatch _ => refins' pblRD fmz pbls' pts end;
144.1175 -
144.1176 -(*. refine a problem; version for tactic Refine_Problem .*)
144.1177 -fun refin'' thy (pblRD:pblRD) itms pbls ((Ptyp (pI,[py],[])):pbt ptyp) =
144.1178 - let (*val _ = writeln("### refin''1: pI="^pI);*)
144.1179 - val {thy,ppc,where_,prls,...} = py
144.1180 - val (b, (itms', pre')) = match_itms thy itms (ppc,where_,prls);
144.1181 - in if b then pbls @ [Match_ (rev (pblRD @ [pI]), (itms', pre'))]
144.1182 - else pbls @ [NoMatch_]
144.1183 - end
144.1184 -(* val pblRD = (rev o tl) pblID; val pbls = [];
144.1185 - val Ptyp (pI,[py],pys) = app_ptyp I pblID (rev pblID) (!ptyps);
144.1186 - *)
144.1187 - | refin'' thy pblRD itms pbls (Ptyp (pI,[py],pys)) =
144.1188 - let (*val _ = writeln("### refin''2: pI="^pI);*)
144.1189 - val {thy,ppc,where_,prls,...} = py
144.1190 - val(b, (itms', pre')) = match_itms thy itms (ppc,where_,prls);
144.1191 - in if b
144.1192 - then let val pbl = Match_ (rev (pblRD @ [pI]), (itms', pre'))
144.1193 - in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end
144.1194 - else (pbls @ [NoMatch_])
144.1195 - end
144.1196 -and refins'' thy pblRD itms pbls [] = pbls
144.1197 - | refins'' thy pblRD itms pbls ((p as Ptyp (pI,_,_))::pts) =
144.1198 - let val pbls' = refin'' thy pblRD itms pbls p
144.1199 - in case last_elem pbls' of
144.1200 - Match_ _ => pbls'
144.1201 - | NoMatch_ => refins'' thy pblRD itms pbls' pts end;
144.1202 -
144.1203 -
144.1204 -(*. apply a fun to a ptyps node; copied from get_py .*)
144.1205 -fun app_ptyp f (d:pblID) _ [] =
144.1206 - raise error ("app_ptyp not found: "^(strs2str d))
144.1207 - | app_ptyp f d (k::[]) ((p as Ptyp (k',[py],_))::pys) =
144.1208 - if k=k' then f p
144.1209 - else app_ptyp f d ([k]:pblRD) pys
144.1210 - | app_ptyp f d (k::ks) ((Ptyp (k',_,pys))::pys') =
144.1211 - if k=k' then app_ptyp f d ks pys
144.1212 - else app_ptyp f d (k::ks) pys';
144.1213 -
144.1214 -(*. for tactic Refine_Tacitly .*)
144.1215 -(*!!! oris are already created wrt. some pbt; pbt contains thy for parsing*)
144.1216 -(* val (thy,pblID) = (assoc_thy dI',pI);
144.1217 - *)
144.1218 -fun refine_ori oris (pblID:pblID) =
144.1219 - let val opt = app_ptyp (refin ((rev o tl) pblID) oris)
144.1220 - pblID (rev pblID) (!ptyps);
144.1221 - in case opt of
144.1222 - SOME pblRD => let val (pblID':pblID) =(rev pblRD)
144.1223 - in if pblID' = pblID then NONE
144.1224 - else SOME pblID' end
144.1225 - | NONE => NONE end;
144.1226 -fun refine_ori' oris pI = (the (refine_ori oris pI)) handle _ => pI;
144.1227 -
144.1228 -(*. for tactic Refine_Problem .*);
144.1229 -(* 10.03: returnvalue -> (pIrefined, itm list) would be sufficient *)
144.1230 -(* val pblID = pI; app_ptyp I pblID (rev pblID) (!ptyps);
144.1231 - *)
144.1232 -fun refine_pbl thy (pblID:pblID) itms =
144.1233 - case refined_ (app_ptyp (refin'' thy ((rev o tl) pblID) itms [])
144.1234 - pblID (rev pblID) (!ptyps)) of
144.1235 - NONE => NONE
144.1236 - | SOME (Match_ (rfd as (pI',_))) =>
144.1237 - if pblID = pI' then NONE else SOME rfd;
144.1238 -
144.1239 -
144.1240 -(*. for math-experts .*)
144.1241 -(*19.10.02FIXME: needs thy for parsing fmz*)
144.1242 -(* val fmz = fmz1; val pblID = ["pbla"]; val pblRD = (rev o tl) pblID;
144.1243 - val pbls = []; val ptys = !ptyps;
144.1244 - *)
144.1245 -fun refine (fmz:fmz_) (pblID:pblID) =
144.1246 - app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID) (!ptyps);
144.1247 -
144.1248 -
144.1249 -(*.make a guh from a reference to an element in the kestore;
144.1250 - EXCEPT theory hierarchy ... compare 'fun keref2xml'.*)
144.1251 -fun pblID2guh (pblID:pblID) =
144.1252 - (((#guh o get_pbt) pblID)
144.1253 - handle _ => raise error ("pblID2guh: not for '"^strs2str' pblID ^ "'"));
144.1254 -fun metID2guh (metID:metID) =
144.1255 - (((#guh o get_met) metID)
144.1256 - handle _ => raise error ("metID2guh: no 'Met_' for '"^
144.1257 - strs2str' metID ^ "'"));
144.1258 -fun kestoreID2guh Pbl_ (kestoreID:kestoreID) = pblID2guh kestoreID
144.1259 - | kestoreID2guh Met_ (kestoreID:kestoreID) = metID2guh kestoreID
144.1260 - | kestoreID2guh ketype kestoreID =
144.1261 - raise error ("kestoreID2guh: '" ^ ketype2str ketype ^ "' not for '" ^
144.1262 - strs2str' kestoreID ^ "'");
144.1263 -
144.1264 -fun show_pblguhs () =
144.1265 - (print_depth 999;
144.1266 - (writeln o strs2str o (map linefeed)) (coll_pblguhs (!ptyps));
144.1267 - print_depth 3);
144.1268 -fun sort_pblguhs () =
144.1269 - (print_depth 999;
144.1270 - (writeln o strs2str o (map linefeed))
144.1271 - (((sort string_ord) o coll_pblguhs) (!ptyps));
144.1272 - print_depth 3);
144.1273 -
144.1274 -fun show_metguhs () =
144.1275 - (print_depth 999;
144.1276 - (writeln o strs2str o (map linefeed)) (coll_metguhs (!mets));
144.1277 - print_depth 3);
144.1278 -fun sort_metguhs () =
144.1279 - (print_depth 999;
144.1280 - (writeln o strs2str o (map linefeed))
144.1281 - (((sort string_ord) o coll_metguhs) (!mets));
144.1282 - print_depth 3);
145.1 --- a/src/Tools/isac/ME/rewtools.sml Wed Aug 25 15:15:01 2010 +0200
145.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
145.3 @@ -1,845 +0,0 @@
145.4 -(* tools for rewriting, reverse rewriting, context to thy concerning rewriting
145.5 - authors: Walther Neuper 2002, 2006
145.6 - (c) due to copyright terms
145.7 -
145.8 -use"ME/rewtools.sml";
145.9 -use"rewtools.sml";
145.10 -*)
145.11 -
145.12 -
145.13 -
145.14 -(***.reverse rewriting.***)
145.15 -
145.16 -(*.derivation for insertin one level of nodes into the calctree.*)
145.17 -type deriv = (term * rule * (term *term list)) list;
145.18 -
145.19 -fun trta2str (t,r,(t',a)) = "\n("^(term2str t)^", "^(rule2str' r)^", ("^
145.20 - (term2str t')^", "^(terms2str a)^"))";
145.21 -fun trtas2str trtas = (strs2str o (map trta2str)) trtas;
145.22 -val deriv2str = trtas2str;
145.23 -fun rta2str (r,(t,a)) = "\n("^(rule2str' r)^", ("^
145.24 - (term2str t)^", "^(terms2str a)^"))";
145.25 -fun rtas2str rtas = (strs2str o (map rta2str)) rtas;
145.26 -val deri2str = rtas2str;
145.27 -
145.28 -
145.29 -(*.A1==>...==>An==>(Lhs = Rhs) goes to A1==>...==>An==>(Rhs = Lhs).*)
145.30 -fun sym_thm thm =
145.31 - let
145.32 - val (deriv, {thy_ref = thy_ref, tags = tags, maxidx = maxidx,
145.33 - shyps = shyps, hyps = hyps, tpairs = tpairs,
145.34 - prop = prop}) =
145.35 - rep_thm_G thm;
145.36 - val (lhs,rhs) = (dest_equals' o strip_trueprop
145.37 - o Logic.strip_imp_concl) prop;
145.38 - val prop' = case strip_imp_prems' prop of
145.39 - NONE => Trueprop $ (mk_equality (rhs, lhs))
145.40 - | SOME cs =>
145.41 - ins_concl cs (Trueprop $ (mk_equality (rhs, lhs)));
145.42 - in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end;
145.43 -(*
145.44 - (sym RS real_mult_div_cancel1) handle e => print_exn e;
145.45 -Exception THM 1 raised:
145.46 -RSN: no unifiers
145.47 -"?s = ?t ==> ?t = ?s"
145.48 -"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n"
145.49 -
145.50 - val thm = real_mult_div_cancel1;
145.51 - val prop = (#prop o rep_thm) thm;
145.52 - atomt prop;
145.53 - val ppp = Logic.strip_imp_concl prop;
145.54 - atomt ppp;
145.55 - ((#prop o rep_thm o sym_thm o sym_thm) thm) = (#prop o rep_thm) thm;
145.56 -val it = true : bool
145.57 - ((sym_thm o sym_thm) thm) = thm;
145.58 -val it = true : bool
145.59 -
145.60 - val thm = real_le_anti_sym;
145.61 - ((sym_thm o sym_thm) thm) = thm;
145.62 -val it = true : bool
145.63 -
145.64 - val thm = real_minus_zero;
145.65 - ((sym_thm o sym_thm) thm) = thm;
145.66 -val it = true : bool
145.67 -*)
145.68 -
145.69 -
145.70 -
145.71 -(*.derive normalform of a rls, or derive until SOME goal,
145.72 - and record rules applied and rewrites.
145.73 -val it = fn
145.74 - : theory
145.75 - -> rls
145.76 - -> rule list
145.77 - -> rew_ord : the order of this rls, which 1 theorem of is used
145.78 - for rewriting 1 single step (?14.4.03)
145.79 - -> term option : 040214 ??? nonsense ???
145.80 - -> term
145.81 - -> (term * : to this term ...
145.82 - rule * : ... this rule is applied yielding ...
145.83 - (term * : ... this term ...
145.84 - term list)) : ... under these assumptions.
145.85 - list :
145.86 -returns empty list for a normal form
145.87 -FIXME.WN040214: treats rules as in Rls, _not_ as in Seq
145.88 -
145.89 -WN060825 too complicated for the intended use by cancel_, common_nominator_
145.90 -and unreflectedly adapted to extion of rules by Rls_: returns Rls_("sym_simpl..
145.91 - -- replaced below*)
145.92 -(* val (thy, erls, rs, ro, goal, tt) = (thy, erls, rs, ro, goal, t);
145.93 - val (thy, erls, rs, ro, goal, tt) = (thy, Atools_erls, rules, ro, NONE, tt);
145.94 - *)
145.95 -fun make_deriv thy erls (rs:rule list) ro(*rew_ord*) goal tt =
145.96 - let datatype switch = Appl | Noap
145.97 - fun rew_once lim rts t Noap [] =
145.98 - (case goal of
145.99 - NONE => rts
145.100 - | SOME g =>
145.101 - raise error ("make_deriv: no derivation for "^(term2str t)))
145.102 - | rew_once lim rts t Appl [] =
145.103 - (*(case rs of Rls _ =>*) rew_once lim rts t Noap rs
145.104 - (*| Seq _ => rts) FIXXXXXME 14.3.03*)
145.105 - | rew_once lim rts t apno rs' =
145.106 - (case goal of
145.107 - NONE => rew_or_calc lim rts t apno rs'
145.108 - | SOME g =>
145.109 - if g = t then rts
145.110 - else rew_or_calc lim rts t apno rs')
145.111 - and rew_or_calc lim rts t apno (rrs' as (r::rs')) =
145.112 - if lim < 0
145.113 - then (writeln ("make_deriv exceeds " ^ int2str (!lim_deriv) ^
145.114 - "with deriv =\n"); writeln (deriv2str rts); rts)
145.115 - else
145.116 - case r of
145.117 - Thm (thmid, tm) =>
145.118 - (if not (!trace_rewrite) then () else
145.119 - writeln ("### trying thm '" ^ thmid ^ "'");
145.120 - case rewrite_ thy ro erls true tm t of
145.121 - NONE => rew_once lim rts t apno rs'
145.122 - | SOME (t',a') =>
145.123 - (if ! trace_rewrite
145.124 - then writeln ("### rewrites to: "^(term2str t')) else();
145.125 - rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs'))
145.126 - | Calc (c as (op_,_)) =>
145.127 - let val _ = if not (!trace_rewrite) then () else
145.128 - writeln ("### trying calc. '" ^ op_ ^ "'")
145.129 - val t = uminus_to_string t
145.130 - in case get_calculation_ thy c t of
145.131 - NONE => rew_once lim rts t apno rs'
145.132 - | SOME (thmid, tm) =>
145.133 - (let val SOME (t',a') = rewrite_ thy ro erls true tm t
145.134 - val _ = if not (!trace_rewrite) then () else
145.135 - writeln("### calc. to: " ^ (term2str t'))
145.136 - val r' = Thm (thmid, tm)
145.137 - in rew_once (lim-1) (rts@[(t,r',(t',a'))]) t' Appl rrs'
145.138 - end)
145.139 - handle _ => raise error "derive_norm, Calc: no rewrite"
145.140 - end
145.141 -(* TODO.WN080222: see rewrite__set_
145.142 - @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
145.143 - | Cal1 (cc as (op_,_)) =>
145.144 - (let val _= if !trace_rewrite andalso i < ! depth then
145.145 - writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else ();
145.146 - val ct = uminus_to_string ct
145.147 - in case get_calculation_ thy cc ct of
145.148 - NONE => (ct, asm)
145.149 - | SOME (thmid, thm') =>
145.150 - let
145.151 - val pairopt =
145.152 - rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
145.153 - ((#erls o rep_rls) rls) put_asm thm' ct;
145.154 - val _ = if pairopt <> NONE then ()
145.155 - else raise error("rewrite_set_, rewrite_ \""^
145.156 - (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE")
145.157 - val _ = if ! trace_rewrite andalso i < ! depth
145.158 - then writeln((idt"="(i+1))^" cal1. to: "^
145.159 - (term2str ((fst o the) pairopt)))
145.160 - else()
145.161 - in the pairopt end
145.162 - end)
145.163 -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
145.164 - | Rls_ rls =>
145.165 - (case rewrite_set_ thy true rls t of
145.166 - NONE => rew_once lim rts t apno rs'
145.167 - | SOME (t',a') =>
145.168 - rew_once (lim-1) (rts @ [(t,r,(t',a'))]) t' Appl rrs');
145.169 -(*WN060829 | Rls_ rls =>
145.170 - (case rewrite_set_ thy true rls t of
145.171 - NONE => rew_once lim rts t apno rs'
145.172 - | SOME (t',a') =>
145.173 - if ro [] (t, t') then rew_once lim rts t apno rs'
145.174 - else rew_once (lim-1) (rts@[(t,r,(t',a'))]) t' Appl rrs');
145.175 -...lead to deriv = [] with make_polynomial.
145.176 -THERE IS SOMETHING DIFFERENT beetween rewriting with the code above
145.177 -and between rewriting with rewrite_set: with rules from make_polynomial and
145.178 -t = "(a^^^2 + -1*b^^^2) / (a^^^2 + -2*a*b + b^^^2)" the actual code
145.179 -leads to cycling Rls_ order_mult_rls_..Rls_ discard_parentheses_..Rls_ order..
145.180 -*)
145.181 - in rew_once (!lim_deriv) [] tt Noap rs end;
145.182 -
145.183 -
145.184 -(*.toggles the marker for 'fun sym_thm'.*)
145.185 -fun sym_thmID (thmID : thmID) =
145.186 - case explode thmID of
145.187 - "s"::"y"::"m"::"_"::id => implode id : thmID
145.188 - | id => "sym_"^thmID;
145.189 -(*
145.190 -> val thmID = "sym_real_mult_2";
145.191 -> sym_thmID thmID;
145.192 -val it = "real_mult_2" : string
145.193 -> val thmID = "real_num_collect";
145.194 -> sym_thmID thmID;
145.195 -val it = "sym_real_num_collect" : string*)
145.196 -fun sym_drop (thmID : thmID) =
145.197 - case explode thmID of
145.198 - "s"::"y"::"m"::"_"::id => implode id : thmID
145.199 - | id => thmID;
145.200 -fun is_sym (thmID : thmID) =
145.201 - case explode thmID of
145.202 - "s"::"y"::"m"::"_"::id => true
145.203 - | id => false;
145.204 -
145.205 -
145.206 -(*FIXXXXME.040219: detail has to handle Rls id="sym_..."
145.207 - by applying make_deriv, rev_deriv'; see concat_deriv*)
145.208 -fun sym_rls Erls = Erls
145.209 - | sym_rls (Rls {id, scr, calc, erls, srls, rules, rew_ord, preconds}) =
145.210 - Rls {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls,
145.211 - rules=rules, rew_ord=rew_ord, preconds=preconds}
145.212 - | sym_rls (Seq {id, scr, calc, erls, srls, rules, rew_ord, preconds}) =
145.213 - Seq {id="sym_"^id, scr=scr, calc=calc, erls=erls, srls=srls,
145.214 - rules=rules, rew_ord=rew_ord, preconds=preconds}
145.215 - | sym_rls (Rrls {id, scr, calc, erls, prepat, rew_ord}) =
145.216 - Rrls {id="sym_"^id, scr=scr, calc=calc, erls=erls, prepat=prepat,
145.217 - rew_ord=rew_ord};
145.218 -
145.219 -fun sym_Thm (Thm (thmID, thm)) = Thm (sym_thmID thmID, sym_thm thm)
145.220 - | sym_Thm (Rls_ rls) = Rls_ (*WN060825?!?*) (sym_rls rls)
145.221 - | sym_Thm r = raise error ("sym_Thm: not for "^(rule2str r));
145.222 -(*
145.223 - val th = Thm ("real_one_collect",num_str real_one_collect);
145.224 - sym_Thm th;
145.225 -val th =
145.226 - Thm ("real_one_collect","?m is_const ==> ?n + ?m * ?n = (1 + ?m) * ?n")
145.227 - : rule
145.228 -ML> val it =
145.229 - Thm ("sym_real_one_collect","?m is_const ==> (1 + ?m) * ?n = ?n + ?m * ?n")*)
145.230 -
145.231 -
145.232 -(*version for reverse rewrite used before 040214*)
145.233 -fun rev_deriv (t, r, (t', a)) = (sym_Thm r, (t, a));
145.234 -(* val (thy, erls, rs, ro, goal, t) = (thy, eval_rls, rules, ro, NONE, t');
145.235 - *)
145.236 -fun reverse_deriv thy erls (rs:rule list) ro(*rew_ord*) goal t =
145.237 - (rev o (map rev_deriv)) (make_deriv thy erls (rs:rule list) ro goal t);
145.238 -(*
145.239 - val rev_rew = reverse_deriv thy e_rls ;
145.240 - writeln(rtas2str rev_rew);
145.241 -*)
145.242 -
145.243 -fun eq_Thm (Thm (id1,_), Thm (id2,_)) = id1 = id2
145.244 - | eq_Thm (Thm (id1,_), _) = false
145.245 - | eq_Thm (Rls_ r1, Rls_ r2) = id_rls r1 = id_rls r2
145.246 - | eq_Thm (Rls_ r1, _) = false
145.247 - | eq_Thm (r1, r2) = raise error ("eq_Thm: called with '"^
145.248 - (rule2str r1)^"' '"^(rule2str r2)^"'");
145.249 -fun distinct_Thm r = gen_distinct eq_Thm r;
145.250 -
145.251 -fun eq_Thms thmIDs thm = (member op = thmIDs (id_of_thm thm))
145.252 - handle _ => false;
145.253 -
145.254 -
145.255 -(***. context to thy concerning rewriting .***)
145.256 -
145.257 -(*.create the unique handles and filenames for the theory-data.*)
145.258 -fun part2guh ([str]:theID) =
145.259 - (case str of
145.260 - "Isabelle" => "thy_isab_" ^ str ^ "-part" : guh
145.261 - | "IsacScripts" => "thy_scri_" ^ str ^ "-part"
145.262 - | "IsacKnowledge" => "thy_isac_" ^ str ^ "-part"
145.263 - | str => raise error ("thy2guh: called with '"^str^"'"))
145.264 - | part2guh theID = raise error ("part2guh called with theID = "
145.265 - ^ theID2str theID);
145.266 -fun part2filename str = part2guh str ^ ".xml" : filename;
145.267 -
145.268 -
145.269 -fun thy2guh ([part, thyID]:theID) =
145.270 - (case part of
145.271 - "Isabelle" => "thy_isab_" ^ thyID : guh
145.272 - | "IsacScripts" => "thy_scri_" ^ thyID
145.273 - | "IsacKnowledge" => "thy_isac_" ^ thyID
145.274 - | str => raise error ("thy2guh: called with '"^str^"'"))
145.275 - | thy2guh theID = raise error ("thy2guh called with '"^strs2str' theID^"'");
145.276 -fun thy2filename thy' = thy2guh thy' ^ ".xml" : filename;
145.277 -fun thypart2guh ([part, thyID, thypart]:theID) =
145.278 - case part of
145.279 - "Isabelle" => "thy_isab_" ^ thyID ^ "-" ^ thypart : guh
145.280 - | "IsacScripts" => "thy_scri_" ^ thyID ^ "-" ^ thypart
145.281 - | "IsacKnowledge" => "thy_isac_" ^ thyID ^ "-" ^ thypart
145.282 - | str => raise error ("thypart2guh: called with '"^str^"'");
145.283 -fun thypart2filename thy' = thypart2guh thy' ^ ".xml" : filename;
145.284 -
145.285 -(*.convert the data got via contextToThy to a globally unique handle
145.286 - there is another way to get the guh out of the 'theID' in the hierarchy.*)
145.287 -fun thm2guh (isa, thyID:thyID) (thmID:thmID) =
145.288 - case isa of
145.289 - "Isabelle" =>
145.290 - "thy_isab_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID : guh
145.291 - | "IsacKnowledge" =>
145.292 - "thy_isac_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
145.293 - | "IsacScripts" =>
145.294 - "thy_scri_" ^ theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
145.295 - | str => raise error ("thm2guh called with isa = '"^isa^
145.296 - "' for thm = "^thmID^"'");
145.297 -fun thm2filename (isa_thyID: string * thyID) thmID =
145.298 - (thm2guh isa_thyID thmID) ^ ".xml" : filename;
145.299 -
145.300 -fun rls2guh (isa, thyID:thyID) (rls':rls') =
145.301 - case isa of
145.302 - "Isabelle" =>
145.303 - "thy_isab_" ^ theory'2thyID thyID ^ "-rls-" ^ rls' : guh
145.304 - | "IsacKnowledge" =>
145.305 - "thy_isac_" ^ theory'2thyID thyID ^ "-rls-" ^ rls'
145.306 - | "IsacScripts" =>
145.307 - "thy_scri_" ^ theory'2thyID thyID ^ "-rls-" ^ rls'
145.308 - | str => raise error ("rls2guh called with isa = '"^isa^
145.309 - "' for rls = '"^rls'^"'");
145.310 - fun rls2filename (isa, thyID) rls' =
145.311 - rls2guh (isa, thyID) rls' ^ ".xml" : filename;
145.312 -
145.313 -fun cal2guh (isa, thyID:thyID) calID =
145.314 - case isa of
145.315 - "Isabelle" =>
145.316 - "thy_isab_" ^ theory'2thyID thyID ^ "-cal-" ^ calID : guh
145.317 - | "IsacKnowledge" =>
145.318 - "thy_isac_" ^ theory'2thyID thyID ^ "-cal-" ^ calID
145.319 - | "IsacScripts" =>
145.320 - "thy_scri_" ^ theory'2thyID thyID ^ "-cal-" ^ calID
145.321 - | str => raise error ("cal2guh called with isa = '"^isa^
145.322 - "' for cal = '"^calID^"'");
145.323 -fun cal2filename (isa, thyID:thyID) calID =
145.324 - cal2guh (isa, thyID:thyID) calID ^ ".xml" : filename;
145.325 -
145.326 -fun ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') =
145.327 - case isa of
145.328 - "Isabelle" =>
145.329 - "thy_isab_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord' : guh
145.330 - | "IsacKnowledge" =>
145.331 - "thy_isac_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord'
145.332 - | "IsacScripts" =>
145.333 - "thy_scri_" ^ theory'2thyID thyID ^ "-ord-" ^ rew_ord'
145.334 - | str => raise error ("ord2guh called with isa = '"^isa^
145.335 - "' for ord = '"^rew_ord'^"'");
145.336 -fun ord2filename (isa, thyID:thyID) (rew_ord':rew_ord') =
145.337 - ord2guh (isa, thyID:thyID) (rew_ord':rew_ord') ^ ".xml" : filename;
145.338 -
145.339 -
145.340 -(**.set up isab_thm_thy in Isac.ML.**)
145.341 -
145.342 -fun rearrange (thyID, (thmID, thm)) = (thmID, (thyID, thm));
145.343 -fun rearrange_inv (thmID, (thyID, thm)) = (thyID, (thmID, thm));
145.344 -
145.345 -(*.lookup the missing theorems in some thy (of Isabelle).*)
145.346 -fun make_isa missthms thy =
145.347 - map (pair (theory2thyID thy))
145.348 - ((inter eq_thmI) missthms (PureThy.all_thms_of thy))
145.349 - : (thyID * (thmID * Thm.thm)) list;
145.350 -
145.351 -(*.separate handling of sym_thms.*)
145.352 -fun make_isab rlsthmsNOTisac isab_thys =
145.353 - let fun les ((s1,_), (s2,_)) = (s1 : string) < s2
145.354 - val notsym = filter_out (is_sym o #1) rlsthmsNOTisac
145.355 - val notsym_isab = (flat o (map (make_isa notsym))) isab_thys
145.356 -
145.357 - val sym = filter (is_sym o #1) rlsthmsNOTisac
145.358 -
145.359 - val symsym = map ((apfst sym_drop) o (apsnd sym_thm)) sym
145.360 - val symsym_isab = (flat o (map (make_isa symsym))) isab_thys
145.361 -
145.362 - val sym_isab = map (((apsnd o apfst) sym_drop) o
145.363 - ((apsnd o apsnd) sym_thm)) symsym_isab
145.364 -
145.365 - val isab = notsym_isab @ symsym_isab @ sym_isab
145.366 - in ((map rearrange) o (gen_sort les)) isab
145.367 - : (thmID * (thyID * Thm.thm)) list
145.368 - end;
145.369 -
145.370 -(*.which theory below thy' contains a theorem; this can be in isabelle !
145.371 -get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*)
145.372 -(* val (str, (_, thy)) = ("real_diff_minus", ("Root.thy", Root.thy));
145.373 - val (str, (_, thy)) = ("real_diff_minus", ("Poly.thy", Poly.thy));
145.374 - *)
145.375 -fun thy_contains_thm (str:xstring) (_, thy) =
145.376 - member op = (map (strip_thy o fst) (PureThy.all_thms_of thy)) str;
145.377 -(* val (thy', str) = ("Isac.thy", "real_mult_minus1");
145.378 - val (thy', str) = ("PolyMinus.thy", "klammer_minus_plus");
145.379 - *)
145.380 -fun thy_containing_thm (thy':theory') (str:xstring) =
145.381 - let val thy' = thyID2theory' thy'
145.382 - val str = sym_drop str
145.383 - val startsearch = dropuntil ((curry op= thy') o
145.384 - (#1:theory' * theory -> theory'))
145.385 - (rev (!theory'))
145.386 - in case find_first (thy_contains_thm str) startsearch of
145.387 - SOME (thy',_) => ("IsacKnowledge", thy')
145.388 - | NONE => (case assoc (!isab_thm_thy (*see Isac.ML*), str) of
145.389 - SOME (thyID,_) => ("Isabelle", thyID)
145.390 - | NONE =>
145.391 - raise error ("thy_containing_thm: theorem '"^str^
145.392 - "' not in !theory' above thy '"^thy'^"'"))
145.393 - end;
145.394 -
145.395 -
145.396 -(*.which theory below thy' contains a ruleset;
145.397 -get the occurence _after_ in the _list_ (is up to asking TUM) theory'.*)
145.398 -(* val (thy', rls') = ("PolyEq.thy", "separate_bdv");
145.399 - *)
145.400 -local infix mem; (*from Isabelle2002*)
145.401 -fun x mem [] = false
145.402 - | x mem (y :: ys) = x = y orelse x mem ys;
145.403 -in
145.404 -fun thy_containing_rls (thy':theory') (rls':rls') =
145.405 - let val rls' = strip_thy rls'
145.406 - val thy' = thyID2theory' thy'
145.407 - (*take thys between "Isac" and thy' not to search #1#*)
145.408 - val dropthys = takewhile [] (not o (curry op= thy') o
145.409 - (#1:theory' * theory -> theory'))
145.410 - (rev (!theory'))
145.411 - val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory'))
145.412 - dropthys
145.413 - (*drop those rulesets which are generated in a theory found in #1#*)
145.414 - val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o
145.415 - ((#1 o #2) : rls' * (theory' * rls)
145.416 - -> theory'))
145.417 - (rev (!ruleset'))
145.418 - in case assoc (startsearch, rls') of
145.419 - SOME (thy', _) => ("IsacKnowledge", thyID2theory' thy')
145.420 - | _ => raise error ("thy_containing_rls : rls '"^rls'^
145.421 - "' not in !rulset' above thy '"^thy'^"'")
145.422 - end;
145.423 -(* val (thy', termop) = (thyID, termop);
145.424 - *)
145.425 -fun thy_containing_cal (thy':theory') termop =
145.426 - let val thy' = thyID2theory' thy'
145.427 - val dropthys = takewhile [] (not o (curry op= thy') o
145.428 - (#1:theory' * theory -> theory'))
145.429 - (rev (!theory'))
145.430 - val dropthy's = map (get_thy o (#1 : (theory' * theory) -> theory'))
145.431 - dropthys
145.432 - val startsearch = filter_out ((curry ((op mem) o swap) dropthy's) o
145.433 - (#1 : calc -> string)) (rev (!calclist'))
145.434 - in case assoc (startsearch, strip_thy termop) of
145.435 - SOME (th_termop, _) => ("IsacKnowledge", strip_thy th_termop)
145.436 - | _ => raise error ("thy_containing_rls : rls '"^termop^
145.437 - "' not in !calclist' above thy '"^thy'^"'")
145.438 - end
145.439 -end;
145.440 -
145.441 -(* print_depth 99; map #1 startsearch; print_depth 3;
145.442 - *)
145.443 -
145.444 -(*.packing return-values to matchTheory, contextToThy for xml-generation.*)
145.445 -datatype contthy = (*also an item from KEStore on Browser ......#*)
145.446 - EContThy (*not from KEStore ...........................*)
145.447 - | ContThm of (*a theorem in contex =============*)
145.448 - {thyID : thyID, (*for *2guh in sub-elems here .*)
145.449 - thm : guh, (*theorem in the context .*)
145.450 - applto : term, (*applied to formula ... .*)
145.451 - applat : term, (*... with lhs inserted .*)
145.452 - reword : rew_ord', (*order used for rewrite .*)
145.453 - asms : (term (*asumption instantiated .*)
145.454 - * term) list, (*asumption evaluated .*)
145.455 - lhs : term (*lhs of the theorem ... #*)
145.456 - * term, (*... instantiated .*)
145.457 - rhs : term (*rhs of the theorem ... #*)
145.458 - * term, (*... instantiated .*)
145.459 - result : term, (*resulting from the rewrite .*)
145.460 - resasms : term list, (*... with asms stored .*)
145.461 - asmrls : rls' (*ruleset for evaluating asms .*)
145.462 - }
145.463 - | ContThmInst of (*a theorem with bdvs in contex ======== *)
145.464 - {thyID : thyID, (*for *2guh in sub-elems here .*)
145.465 - thm : guh, (*theorem in the context .*)
145.466 - bdvs : subst, (*bound variables to modify....*)
145.467 - thminst : term, (*... theorem instantiated .*)
145.468 - applto : term, (*applied to formula ... .*)
145.469 - applat : term, (*... with lhs inserted .*)
145.470 - reword : rew_ord', (*order used for rewrite .*)
145.471 - asms : (term (*asumption instantiated .*)
145.472 - * term) list, (*asumption evaluated .*)
145.473 - lhs : term (*lhs of the theorem ... #*)
145.474 - * term, (*... instantiated .*)
145.475 - rhs : term (*rhs of the theorem ... #*)
145.476 - * term, (*... instantiated .*)
145.477 - result : term, (*resulting from the rewrite .*)
145.478 - resasms : term list, (*... with asms stored .*)
145.479 - asmrls : rls' (*ruleset for evaluating asms .*)
145.480 - }
145.481 - | ContRls of (*a rule set in contex ===================== *)
145.482 - {thyID : thyID, (*for *2guh in sub-elems here .*)
145.483 - rls : guh, (*rule set in the context .*)
145.484 - applto : term, (*rewrite this formula .*)
145.485 - result : term, (*resulting from the rewrite .*)
145.486 - asms : term list (*... with asms stored .*)
145.487 - }
145.488 - | ContRlsInst of (*a rule set with bdvs in contex ======= *)
145.489 - {thyID : thyID, (*for *2guh in sub-elems here .*)
145.490 - rls : guh, (*rule set in the context .*)
145.491 - bdvs : subst, (*for bound variables in thms .*)
145.492 - applto : term, (*rewrite this formula .*)
145.493 - result : term, (*resulting from the rewrite .*)
145.494 - asms : term list (*... with asms stored .*)
145.495 - }
145.496 - | ContNOrew of (*no rewrite for thm or rls ============== *)
145.497 - {thyID : thyID, (*for *2guh in sub-elems here .*)
145.498 - thm_rls : guh, (*thm or rls in the context .*)
145.499 - applto : term (*rewrite this formula .*)
145.500 - }
145.501 - | ContNOrewInst of (*no rewrite for some instantiation == *)
145.502 - {thyID : thyID, (*for *2guh in sub-elems here .*)
145.503 - thm_rls : guh, (*thm or rls in the context .*)
145.504 - bdvs : subst, (*for bound variables in thms .*)
145.505 - thminst : term, (*... theorem instantiated .*)
145.506 - applto : term (*rewrite this formula .*)
145.507 - };
145.508 -
145.509 -(*.check a rewrite-tac for bdv (RL always used *_Inst !) TODO.WN060718
145.510 - pass other tacs unchanged.*)
145.511 -fun get_tac_checked pt ((p,p_) : pos') = get_obj g_tac pt p;
145.512 -
145.513 -(*..*)
145.514 -
145.515 -
145.516 -
145.517 -(*.get the formula f at ptp rewritten by the Rewrite_* already applied to f.*)
145.518 -(* val (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) = tac';
145.519 - *)
145.520 -fun context_thy (pt, pos as (p,p_)) (tac as Rewrite (thmID,_)) =
145.521 - (case applicable_in pos pt tac of
145.522 - Appl (Rewrite' (thy', ord', erls, _, (thmID,_), f, (res,asm))) =>
145.523 - let val thy = assoc_thy thy'
145.524 - val thm = (norm o #prop o rep_thm o (PureThy.get_thm thy)) thmID
145.525 - (*WN060616 the following must be done on subterm found _IN_ rew_sub
145.526 - val (lhs,rhs) = (dest_equals' o strip_trueprop
145.527 - o Logic.strip_imp_concl) thm
145.528 - val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f)
145.529 - val thm' = ren_inst (insts, thm, lhs, f)
145.530 - val (lhs',rhs') = (dest_equals' o strip_trueprop
145.531 - o Logic.strip_imp_concl) thm'
145.532 - val asms = map strip_trueprop (Logic.strip_imp_prems thm)
145.533 - val asms' = map strip_trueprop (Logic.strip_imp_prems thm')
145.534 - *)
145.535 - in ContThm {thyID = theory'2thyID thy',
145.536 - thm = thm2guh (thy_containing_thm thy' thmID) thmID,
145.537 - applto = f,
145.538 - applat = e_term,
145.539 - reword = ord',
145.540 - asms = [](*asms ~~ asms'*),
145.541 - lhs = (e_term, e_term)(*(lhs, lhs')*),
145.542 - rhs = (e_term, e_term)(*(rhs, rhs')*),
145.543 - result = res,
145.544 - resasms = asm,
145.545 - asmrls = id_rls erls}
145.546 - end
145.547 - | Notappl _ =>
145.548 - let val pp = par_pblobj pt p
145.549 - val thy' = get_obj g_domID pt pp
145.550 - val f = case p_ of
145.551 - Frm => get_obj g_form pt p
145.552 - | Res => (fst o (get_obj g_result pt)) p
145.553 - in ContNOrew {thyID = theory'2thyID thy',
145.554 - thm_rls = thm2guh (thy_containing_thm thy' thmID) thmID,
145.555 - applto = f}
145.556 - end)
145.557 -
145.558 -(* val ((pt,p), tac as Rewrite_Inst (subs, (thmID,_))) = ((pt,pos), tac);
145.559 - *)
145.560 - | context_thy (pt, pos as (p,p_))
145.561 - (tac as Rewrite_Inst (subs, (thmID,_))) =
145.562 - (case applicable_in pos pt tac of
145.563 -(* val Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_),
145.564 - f, (res,asm))) = applicable_in p pt tac;
145.565 - *)
145.566 - Appl (Rewrite_Inst' (thy', ord', erls, _, subst, (thmID,_),
145.567 - f, (res,(*path to subterm,*)asm))) =>
145.568 - let val thm = (norm o #prop o rep_thm o
145.569 - (PureThy.get_thm (assoc_thy thy'))) thmID
145.570 - val thminst = inst_bdv subst thm
145.571 - (*WN060616 the following must be done on subterm found _IN_ rew_sub
145.572 - val (lhs,rhs) = (dest_equals' o strip_trueprop
145.573 - o Logic.strip_imp_concl) thminst
145.574 - val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs, f)
145.575 - val thm' = ren_inst (insts, thminst, lhs, f)
145.576 - val (lhs',rhs') = (dest_equals' o strip_trueprop
145.577 - o Logic.strip_imp_concl) thm'
145.578 - val asms = map strip_trueprop (Logic.strip_imp_prems thminst)
145.579 - val asms' = map strip_trueprop (Logic.strip_imp_prems thm')
145.580 - *)
145.581 - in ContThmInst {thyID = theory'2thyID thy',
145.582 - thm = thm2guh (thy_containing_thm
145.583 - thy' thmID) thmID,
145.584 - bdvs = subst,
145.585 - thminst = thminst,
145.586 - applto = f,
145.587 - applat = e_term,
145.588 - reword = ord',
145.589 - asms = [](*asms ~~ asms'*),
145.590 - lhs = (e_term, e_term)(*(lhs, lhs')*),
145.591 - rhs = (e_term, e_term)(*(rhs, rhs')*),
145.592 - result = res,
145.593 - resasms = asm,
145.594 - asmrls = id_rls erls}
145.595 - end
145.596 - | Notappl _ =>
145.597 - let val pp = par_pblobj pt p
145.598 - val thy' = get_obj g_domID pt pp
145.599 - val subst = subs2subst (assoc_thy thy') subs
145.600 - val thm = (norm o #prop o rep_thm o
145.601 - (PureThy.get_thm (assoc_thy thy'))) thmID
145.602 - val thminst = inst_bdv subst thm
145.603 - val f = case p_ of
145.604 - Frm => get_obj g_form pt p
145.605 - | Res => (fst o (get_obj g_result pt)) p
145.606 - in ContNOrewInst {thyID = theory'2thyID thy',
145.607 - thm_rls = thm2guh (thy_containing_thm
145.608 - thy' thmID) thmID,
145.609 - bdvs = subst,
145.610 - thminst = thminst,
145.611 - applto = f}
145.612 - end)
145.613 - | context_thy (pt,p) (tac as Rewrite_Set rls') =
145.614 - (case applicable_in p pt tac of
145.615 - Appl (Rewrite_Set' (thy', _, rls, f, (res,asm))) =>
145.616 - ContRls {thyID = theory'2thyID thy',
145.617 - rls = rls2guh (thy_containing_rls thy' rls') rls',
145.618 - applto = f,
145.619 - result = res,
145.620 - asms = asm})
145.621 - | context_thy (pt,p) (tac as Rewrite_Set_Inst (subs, rls')) =
145.622 - (case applicable_in p pt tac of
145.623 - Appl (Rewrite_Set_Inst' (thy', _, subst, rls, f, (res,asm))) =>
145.624 - ContRlsInst {thyID = theory'2thyID thy',
145.625 - rls = rls2guh (thy_containing_rls thy' rls') rls',
145.626 - bdvs = subst,
145.627 - applto = f,
145.628 - result = res,
145.629 - asms = asm});
145.630 -
145.631 -(*.get all theorems in a rule set (recursivley containing rule sets).*)
145.632 -fun thm_of_rule Erule = []
145.633 - | thm_of_rule (thm as Thm _) = [thm]
145.634 - | thm_of_rule (Calc _) = []
145.635 - | thm_of_rule (Cal1 _) = []
145.636 - | thm_of_rule (Rls_ rls) = thms_of_rls rls
145.637 -and thms_of_rls Erls = []
145.638 - | thms_of_rls (Rls {rules,...}) = (flat o (map thm_of_rule)) rules
145.639 - | thms_of_rls (Seq {rules,...}) = (flat o (map thm_of_rule)) rules
145.640 - | thms_of_rls (Rrls _) = [];
145.641 -(* val Hrls {thy_rls = (_, rls),...} =
145.642 - get_the ["IsacKnowledge", "Test", "Rulesets", "expand_binomtest"];
145.643 -> thms_of_rls rls;
145.644 - *)
145.645 -
145.646 -(*. check if a rule is contained in a rule-set (recursivley down in Rls_);
145.647 - this rule can even be a rule-set itself.*)
145.648 -fun contains_rule r rls =
145.649 - let fun find (r, Rls_ rls) = finds (get_rules rls)
145.650 - | find r12 = eq_rule r12
145.651 - and finds [] = false
145.652 - | finds (r1 :: rs) = if eq_rule (r, r1) then true else finds rs;
145.653 - in
145.654 - (*writeln ("### contains_rule: r = "^rule2str r^", rls = "^rls2str rls);*)
145.655 - finds (get_rules rls)
145.656 - end;
145.657 -
145.658 -(*. try if a rewrite-rule is applicable to a given formula;
145.659 - in case of rule-sets (recursivley) collect all _atomic_ rewrites .*)
145.660 -fun try_rew thy ((_, ro):rew_ord) erls (subst:subst) f (thm' as Thm(id, thm)) =
145.661 - if contains_bdv thm
145.662 - then case rewrite_inst_ thy ro erls false subst thm f of
145.663 - SOME (f',_) =>[rule2tac subst thm']
145.664 - | NONE => []
145.665 - else (case rewrite_ thy ro erls false thm f of
145.666 - SOME (f',_) => [rule2tac [] thm']
145.667 - | NONE => [])
145.668 - | try_rew thy _ _ _ f (cal as Calc c) =
145.669 - (case get_calculation_ thy c f of
145.670 - SOME (str, _) => [rule2tac [] cal]
145.671 - | NONE => [])
145.672 - | try_rew thy _ _ _ f (cal as Cal1 c) =
145.673 - (case get_calculation_ thy c f of
145.674 - SOME (str, _) => [rule2tac [] cal]
145.675 - | NONE => [])
145.676 - | try_rew thy _ _ subst f (Rls_ rls) = filter_appl_rews thy subst f rls
145.677 -and filter_appl_rews thy subst f (Rls {rew_ord = ro, erls, rules,...}) =
145.678 - distinct (flat (map (try_rew thy ro erls subst f) rules))
145.679 - | filter_appl_rews thy subst f (Seq {rew_ord = ro, erls, rules,...}) =
145.680 - distinct (flat (map (try_rew thy ro erls subst f) rules))
145.681 - | filter_appl_rews thy subst f (Rrls _) = [];
145.682 -
145.683 -(*. decide if a tactic is applicable to a given formula;
145.684 - in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*)
145.685 -(* val
145.686 - *)
145.687 -fun atomic_appl_tacs thy _ _ f (Calculate scrID) =
145.688 - try_rew thy e_rew_ordX e_rls [] f (Calc (snd(assoc1 (!calclist', scrID))))
145.689 - | atomic_appl_tacs thy ro erls f (Rewrite (thm' as (thmID, _))) =
145.690 - try_rew thy (ro, assoc_rew_ord ro) erls [] f
145.691 - (Thm (thmID, assoc_thm' thy thm'))
145.692 - | atomic_appl_tacs thy ro erls f (Rewrite_Inst (subs, thm' as (thmID, _))) =
145.693 - try_rew thy (ro, assoc_rew_ord ro) erls (subs2subst thy subs) f
145.694 - (Thm (thmID, assoc_thm' thy thm'))
145.695 -
145.696 - | atomic_appl_tacs thy _ _ f (Rewrite_Set rls') =
145.697 - filter_appl_rews thy [] f (assoc_rls rls')
145.698 - | atomic_appl_tacs thy _ _ f (Rewrite_Set_Inst (subs, rls')) =
145.699 - filter_appl_rews thy (subs2subst thy subs) f (assoc_rls rls')
145.700 - | atomic_appl_tacs _ _ _ _ tac =
145.701 - (writeln ("### atomic_appl_tacs: not impl. for tac = '"^ tac2str tac ^"'");
145.702 - []);
145.703 -
145.704 -
145.705 -
145.706 -
145.707 -
145.708 -(*.not only for thydata, but also for thy's etc.*)
145.709 -fun theID2guh (theID:theID) =
145.710 - case length theID of
145.711 - 0 => raise error ("theID2guh: called with theID = "^strs2str' theID)
145.712 - | 1 => part2guh theID
145.713 - | 2 => thy2guh theID
145.714 - | 3 => thypart2guh theID
145.715 - | 4 => let val [isa, thyID, typ, elemID] = theID
145.716 - in case typ of
145.717 - "Theorems" => thm2guh (isa, thyID) elemID
145.718 - | "Rulesets" => rls2guh (isa, thyID) elemID
145.719 - | "Calculations" => cal2guh (isa, thyID) elemID
145.720 - | "Orders" => ord2guh (isa, thyID) elemID
145.721 - | "Theorems" => thy2guh [isa, thyID]
145.722 - | str => raise error ("theID2guh: called with theID = "^
145.723 - strs2str' theID)
145.724 - end
145.725 - | n => raise error ("theID2guh called with theID = "^strs2str' theID);
145.726 -(*.filenames not only for thydata, but also for thy's etc.*)
145.727 -fun theID2filename (theID:theID) = theID2guh theID ^ ".xml" : filename;
145.728 -
145.729 -fun guh2theID (guh:guh) =
145.730 - let val guh' = explode guh
145.731 - val part = implode (take_fromto 1 4 guh')
145.732 - val isa = implode (take_fromto 5 9 guh')
145.733 - in if not (member op = ["exp_", "thy_", "pbl_", "met_"] part)
145.734 - then raise error ("guh '"^guh^"' does not begin with \
145.735 - \exp_ | thy_ | pbl_ | met_")
145.736 - else let val chap = case isa of
145.737 - "isab_" => "Isabelle"
145.738 - | "scri_" => "IsacScripts"
145.739 - | "isac_" => "IsacKnowledge"
145.740 - | _ =>
145.741 - raise error ("guh2theID: '"^guh^
145.742 - "' does not have isab_ | scri_ | \
145.743 - \isac_ at position 5..9")
145.744 - val rest = takerest (9, guh')
145.745 - val thyID = takewhile [] (not o (curry op= "-")) rest
145.746 - val rest' = dropuntil (curry op= "-") rest
145.747 - in case implode rest' of
145.748 - "-part" => [chap] : theID
145.749 - | "" => [chap, implode thyID]
145.750 - | "-Theorems" => [chap, implode thyID, "Theorems"]
145.751 - | "-Rulesets" => [chap, implode thyID, "Rulesets"]
145.752 - | "-Operations" => [chap, implode thyID, "Operations"]
145.753 - | "-Orders" => [chap, implode thyID, "Orders"]
145.754 - | _ =>
145.755 - let val sect = implode (take_fromto 1 5 rest')
145.756 - val sect' =
145.757 - case sect of
145.758 - "-thm-" => "Theorems"
145.759 - | "-rls-" => "Rulesets"
145.760 - | "-cal-" => "Operations"
145.761 - | "-ord-" => "Orders"
145.762 - | str =>
145.763 - raise error ("guh2theID: '"^guh^"' has '"^sect^
145.764 - "' instead -thm- | -rls- | \
145.765 - \-cal- | -ord-")
145.766 - in [chap, implode thyID, sect', implode
145.767 - (takerest (5, rest'))]
145.768 - end
145.769 - end
145.770 - end;
145.771 -(*> guh2theID "thy_isac_Biegelinie-Theorems";
145.772 -val it = ["IsacKnowledge", "Biegelinie", "Theorems"] : theID
145.773 -> guh2theID "thy_scri_ListG-thm-zip_Nil";
145.774 -val it = ["IsacScripts", "ListG", "Theorems", "zip_Nil"] : theID*)
145.775 -
145.776 -fun guh2filename (guh : guh) = guh ^ ".xml" : filename;
145.777 -
145.778 -
145.779 -(*..*)
145.780 -fun guh2rewtac (guh:guh) ([] : subs) =
145.781 - let val [isa, thy, sect, xstr] = guh2theID guh
145.782 - in case sect of
145.783 - "Theorems" => Rewrite (xstr, "")
145.784 - | "Rulesets" => Rewrite_Set xstr
145.785 - | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'")
145.786 - end
145.787 - | guh2rewtac (guh:guh) subs =
145.788 - let val [isa, thy, sect, xstr] = guh2theID guh
145.789 - in case sect of
145.790 - "Theorems" => Rewrite_Inst (subs, (xstr, ""))
145.791 - | "Rulesets" => Rewrite_Set_Inst (subs, xstr)
145.792 - | str => raise error ("guh2rewtac: not impl. for '"^xstr^"'")
145.793 - end;
145.794 -(*> guh2rewtac "thy_isac_Test-thm-constant_mult_square" [];
145.795 -val it = Rewrite ("constant_mult_square", "") : tac
145.796 -> guh2rewtac "thy_isac_Test-thm-risolate_bdv_add" ["(bdv, x)"];
145.797 -val it = Rewrite_Inst (["(bdv, x)"], ("risolate_bdv_add", "")) : tac
145.798 -> guh2rewtac "thy_isac_Test-rls-Test_simplify" [];
145.799 -val it = Rewrite_Set "Test_simplify" : tac
145.800 -> guh2rewtac "thy_isac_Test-rls-isolate_bdv" ["(bdv, x)"];
145.801 -val it = Rewrite_Set_Inst (["(bdv, x)"], "isolate_bdv") : tac*)
145.802 -
145.803 -
145.804 -(*.the front-end may request a context for any element of the hierarchy.*)
145.805 -(* val guh = "thy_isac_Test-rls-Test_simplify";
145.806 - *)
145.807 -fun no_thycontext (guh : guh) = (guh2theID guh; false)
145.808 - handle _ => true;
145.809 -
145.810 -(*> has_thycontext "thy_isac_Test";
145.811 -if has_thycontext "thy_isac_Test" then "OK" else "NOTOK";
145.812 - *)
145.813 -
145.814 -
145.815 -
145.816 -(*.get the substitution of bound variables for matchTheory:
145.817 - # lookup the thm|rls' in the script
145.818 - # take the [(bdv, v_),..] from the respective Rewrite_(Set_)Inst
145.819 - # instantiate this subs with the istates env to [(bdv, x),..]
145.820 - # otherwise [].*)
145.821 -(*WN060617 hack assuming that all scripts use only one bound variable
145.822 -and use 'v_' as the formal argument for this bound variable*)
145.823 -(* val (ScrState (env,_,_,_,_,_), _, guh) = (is, "dummy", guh);
145.824 - *)
145.825 -fun subs_from (ScrState (env,_,_,_,_,_)) _(*:Script sc*) (guh:guh) =
145.826 - let val theID as [isa, thyID, sect, xstr] = guh2theID guh
145.827 - in case sect of
145.828 - "Theorems" =>
145.829 - let val thm = PureThy.get_thm (assoc_thy (thyID2theory' thyID)) xstr
145.830 - in if contains_bdv thm
145.831 - then let val formal_arg = str2term "v_"
145.832 - val value = subst_atomic env formal_arg
145.833 - in ["(bdv," ^ term2str value ^ ")"]:subs end
145.834 - else []
145.835 - end
145.836 - | "Rulesets" =>
145.837 - let val rules = (get_rules o assoc_rls) xstr
145.838 - in if contain_bdv rules
145.839 - then let val formal_arg = str2term"v_"
145.840 - val value = subst_atomic env formal_arg
145.841 - in ["(bdv,"^term2str value^")"]:subs end
145.842 - else []
145.843 - end
145.844 - end;
145.845 -
145.846 -(* use"ME/rewtools.sml";
145.847 - *)
145.848 -
146.1 --- a/src/Tools/isac/ME/script.sml Wed Aug 25 15:15:01 2010 +0200
146.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
146.3 @@ -1,2031 +0,0 @@
146.4 -(* interpreter for scripts
146.5 - (c) Walther Neuper 2000
146.6 -
146.7 -use"ME/script.sml";
146.8 -use"script.sml";
146.9 -*)
146.10 -signature INTERPRETER =
146.11 -sig
146.12 - (*type ets (list of executed tactics) see sequent.sml*)
146.13 -
146.14 - datatype locate
146.15 - = NotLocatable
146.16 - | Steps of (tac_ * mout * ptree * pos' * cid * safe (* ets*)) list
146.17 -(* | ToDo of ets 28.4.02*)
146.18 -
146.19 - (*diss: next-tactic-function*)
146.20 - val next_tac : theory' -> ptree * pos' -> metID -> scr -> ets -> tac_
146.21 - (*diss: locate-function*)
146.22 - val locate_gen : theory'
146.23 - -> tac_
146.24 - -> ptree * pos' -> scr * rls -> ets -> loc_ -> locate
146.25 -
146.26 - val sel_rules : ptree -> pos' -> tac list
146.27 - val init_form : scr -> ets -> loc_ * term option (*FIXME not up to date*)
146.28 - val formal_args : term -> term list
146.29 -
146.30 - (*shift to library ...*)
146.31 - val inst_abs : theory' -> term -> term
146.32 - val itms2args : metID -> itm list -> term list
146.33 - val user_interrupt : loc_ * (tac_ * env * env * term * term * safe)
146.34 - (*val empty : term*)
146.35 -end
146.36 -
146.37 -
146.38 -
146.39 -
146.40 -(*
146.41 -structure Interpreter : INTERPRETER =
146.42 -struct
146.43 -*)
146.44 -
146.45 -(*.traces the leaves (ie. non-tactical nodes) of the script
146.46 - found by next_tac.
146.47 - a leaf is either a tactic or an 'exp' in 'let v = expr'
146.48 - where 'exp' does not contain a tactic.*)
146.49 -val trace_script = ref false;
146.50 -
146.51 -type step = (*data for creating a new node in the ptree;
146.52 - designed for use:
146.53 - fun ass* scrstate steps =
146.54 - ... case ass* scrstate steps of
146.55 - Assoc (scrstate, steps) => ... ass* scrstate steps*)
146.56 - tac_ (*transformed from associated tac*)
146.57 - * mout (*result with indentation etc.*)
146.58 - * ptree (*containing node created by tac_ + resp. scrstate*)
146.59 - * pos' (*position in ptree; ptree * pos' is the proofstate*)
146.60 - * pos' list; (*of ptree-nodes probably cut (by fst tac_)*)
146.61 -val e_step = (Empty_Tac_, EmptyMout, EmptyPtree, e_pos',[]:pos' list):step;
146.62 -
146.63 -fun rule2thm' (Thm (id, thm)) = (id, string_of_thmI thm):thm'
146.64 - | rule2thm' r = raise error ("rule2thm': not defined for "^(rule2str r));
146.65 -fun rule2rls' (Rls_ rls) = id_rls rls
146.66 - | rule2rls' r = raise error ("rule2rls': not defined for "^(rule2str r));
146.67 -
146.68 -(*.makes a (rule,term) list to a Step (m, mout, pt', p', cid) for solve;
146.69 - complicated with current t in rrlsstate.*)
146.70 -fun rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) [(r, (f', am))] =
146.71 - let val thy = assoc_thy thy'
146.72 - val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
146.73 - val is = RrlsState (f',f'',rss,rts)
146.74 - val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
146.75 - val (p', cid, mout, pt') = generate1 thy m is p pt
146.76 - in (is, (m, mout, pt', p', cid)::steps) end
146.77 - | rts2steps steps ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa))
146.78 - ((r, (f', am))::rts') =
146.79 - let val thy = assoc_thy thy'
146.80 - val m = Rewrite' (thy',ro,er,pa, rule2thm' r, f, (f', am))
146.81 - val is = RrlsState (f',f'',rss,rts)
146.82 - val p = case p of (p',Frm) => p | (p',Res) => (lev_on p',Res)
146.83 - val (p', cid, mout, pt') = generate1 thy m is p pt
146.84 - in rts2steps ((m, mout, pt', p', cid)::steps)
146.85 - ((pt',p'),(f',f'',rss,rts),(thy',ro,er,pa)) rts' end;
146.86 -
146.87 -
146.88 -(*. functions for the environment stack .*)
146.89 -fun accessenv id es = the (assoc((top es):env, id))
146.90 - handle _ => error ("accessenv: "^(free2str id)^" not in env");
146.91 -fun updateenv id vl (es:env stack) =
146.92 - (push (overwrite(top es, (id, vl))) (pop es)):env stack;
146.93 -fun pushenv id vl (es:env stack) =
146.94 - (push (overwrite(top es, (id, vl))) es):env stack;
146.95 -val popenv = pop:env stack -> env stack;
146.96 -
146.97 -
146.98 -
146.99 -fun de_esc_underscore str =
146.100 - let fun scan [] = []
146.101 - | scan (s::ss) = if s = "'" then (scan ss)
146.102 - else (s::(scan ss))
146.103 - in (implode o scan o explode) str end;
146.104 -(*
146.105 -> val str = "Rewrite_Set_Inst";
146.106 -> val esc = esc_underscore str;
146.107 -val it = "Rewrite'_Set'_Inst" : string
146.108 -> val des = de_esc_underscore esc;
146.109 - val des = de_esc_underscore esc;*)
146.110 -
146.111 -(*go at a location in a script and fetch the contents*)
146.112 -fun go [] t = t
146.113 - | go (D::p) (Abs(s,ty,t0)) = go (p:loc_) t0
146.114 - | go (L::p) (t1 $ t2) = go p t1
146.115 - | go (R::p) (t1 $ t2) = go p t2
146.116 - | go l _ = raise error ("go: no "^(loc_2str l));
146.117 -(*
146.118 -> val t = (term_of o the o (parse thy)) "a+b";
146.119 -val it = Const (#,#) $ Free (#,#) $ Free ("b","RealDef.real") : term
146.120 -> val plus_a = go [L] t;
146.121 -> val b = go [R] t;
146.122 -> val plus = go [L,L] t;
146.123 -> val a = go [L,R] t;
146.124 -
146.125 -> val t = (term_of o the o (parse thy)) "a+b+c";
146.126 -val t = Const (#,#) $ (# $ # $ Free #) $ Free ("c","RealDef.real") : term
146.127 -> val pl_pl_a_b = go [L] t;
146.128 -> val c = go [R] t;
146.129 -> val a = go [L,R,L,R] t;
146.130 -> val b = go [L,R,R] t;
146.131 -*)
146.132 -
146.133 -
146.134 -(* get a subterm t with test t, and record location *)
146.135 -fun get l test (t as Const (s,T)) =
146.136 - if test t then SOME (l,t) else NONE
146.137 - | get l test (t as Free (s,T)) =
146.138 - if test t then SOME (l,t) else NONE
146.139 - | get l test (t as Bound n) =
146.140 - if test t then SOME (l,t) else NONE
146.141 - | get l test (t as Var (s,T)) =
146.142 - if test t then SOME (l,t) else NONE
146.143 - | get l test (t as Abs (s,T,body)) =
146.144 - if test t then SOME (l:loc_,t) else get ((l@[D]):loc_) test body
146.145 - | get l test (t as t1 $ t2) =
146.146 - if test t then SOME (l,t)
146.147 - else case get (l@[L]) test t1 of
146.148 - NONE => get (l@[R]) test t2
146.149 - | SOME (l',t') => SOME (l',t');
146.150 -(*18.6.00
146.151 -> val sss = ((term_of o the o (parse thy))
146.152 - "Script Solve_root_equation (eq_::bool) (v_::real) (err_::bool) =\
146.153 - \ (let e_ = Try (Rewrite square_equation_left True eq_) \
146.154 - \ in [e_])");
146.155 - ______ compares head_of !!
146.156 -> get [] (eq_str "Let") sss; [R]
146.157 -> get [] (eq_str "Script.Try") sss; [R,L,R]
146.158 -> get [] (eq_str "Script.Rewrite") sss; [R,L,R,R]
146.159 -> get [] (eq_str "True") sss; [R,L,R,R,L,R]
146.160 -> get [] (eq_str "e_") sss; [R,R]
146.161 -*)
146.162 -
146.163 -fun test_negotiable t =
146.164 - member op = (!negotiable)
146.165 - ((strip_thy o (term_str (theory "Script")) o head_of) t);
146.166 -
146.167 -(*.get argument of first stactic in a script for init_form.*)
146.168 -fun get_stac thy (h $ body) =
146.169 -(*
146.170 - *)
146.171 - let
146.172 - fun get_t y (Const ("Script.Seq",_) $ e1 $ e2) a =
146.173 - (case get_t y e1 a of NONE => get_t y e2 a | la => la)
146.174 - | get_t y (Const ("Script.Seq",_) $ e1 $ e2 $ a) _ =
146.175 - (case get_t y e1 a of NONE => get_t y e2 a | la => la)
146.176 - | get_t y (Const ("Script.Try",_) $ e) a = get_t y e a
146.177 - | get_t y (Const ("Script.Try",_) $ e $ a) _ = get_t y e a
146.178 - | get_t y (Const ("Script.Repeat",_) $ e) a = get_t y e a
146.179 - | get_t y (Const ("Script.Repeat",_) $ e $ a) _ = get_t y e a
146.180 - | get_t y (Const ("Script.Or",_) $e1 $ e2) a =
146.181 - (case get_t y e1 a of NONE => get_t y e2 a | la => la)
146.182 - | get_t y (Const ("Script.Or",_) $e1 $ e2 $ a) _ =
146.183 - (case get_t y e1 a of NONE => get_t y e2 a | la => la)
146.184 - | get_t y (Const ("Script.While",_) $ c $ e) a = get_t y e a
146.185 - | get_t y (Const ("Script.While",_) $ c $ e $ a) _ = get_t y e a
146.186 - | get_t y (Const ("Script.Letpar",_) $ e1 $ Abs (_,_,e2)) a =
146.187 - (case get_t y e1 a of NONE => get_t y e2 a | la => la)
146.188 - (*| get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
146.189 - (writeln("get_t: Let e1= "^(term2str e1)^", e2= "^(term2str e2));
146.190 - case get_t y e1 a of NONE => get_t y e2 a | la => la)
146.191 - | get_t y (Abs (_,_,e)) a = get_t y e a*)
146.192 - | get_t y (Const ("Let",_) $ e1 $ Abs (_,_,e2)) a =
146.193 - get_t y e1 a (*don't go deeper without evaluation !*)
146.194 - | get_t y (Const ("If",_) $ c $ e1 $ e2) a = NONE
146.195 - (*(case get_t y e1 a of NONE => get_t y e2 a | la => la)*)
146.196 -
146.197 - | get_t y (Const ("Script.Rewrite",_) $ _ $ _ $ a) _ = SOME a
146.198 - | get_t y (Const ("Script.Rewrite",_) $ _ $ _ ) a = SOME a
146.199 - | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ a) _ = SOME a
146.200 - | get_t y (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ ) a = SOME a
146.201 - | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ a) _ = SOME a
146.202 - | get_t y (Const ("Script.Rewrite'_Set",_) $ _ $ _ ) a = SOME a
146.203 - | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $a)_ =SOME a
146.204 - | get_t y (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ ) a =SOME a
146.205 - | get_t y (Const ("Script.Calculate",_) $ _ $ a) _ = SOME a
146.206 - | get_t y (Const ("Script.Calculate",_) $ _ ) a = SOME a
146.207 -
146.208 - | get_t y (Const ("Script.Substitute",_) $ _ $ a) _ = SOME a
146.209 - | get_t y (Const ("Script.Substitute",_) $ _ ) a = SOME a
146.210 -
146.211 - | get_t y (Const ("Script.SubProblem",_) $ _ $ _) _ = NONE
146.212 -
146.213 - | get_t y x _ =
146.214 - ((*writeln ("### get_t yac: list-expr "^(term2str x));*)
146.215 - NONE)
146.216 -in get_t thy body e_term end;
146.217 -
146.218 -(*FIXME: get 1st stac by next_stac [] instead of ... ?? 29.7.02*)
146.219 -(* val Script sc = scr;
146.220 - *)
146.221 -fun init_form thy (Script sc) env =
146.222 - (case get_stac thy sc of
146.223 - NONE => NONE (*raise error ("init_form: no 1st stac in "^
146.224 - (Syntax.string_of_term (thy2ctxt thy) sc))*)
146.225 - | SOME stac => SOME (subst_atomic env stac))
146.226 - | init_form _ _ _ = raise error "init_form: no match";
146.227 -
146.228 -(* use"ME/script.sml";
146.229 - use"script.sml";
146.230 - *)
146.231 -
146.232 -
146.233 -
146.234 -(*the 'iteration-argument' of a stac (args not eval)*)
146.235 -fun itr_arg _ (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ v) = v
146.236 - | itr_arg _ (Const ("Script.Rewrite",_) $ _ $ _ $ v) = v
146.237 - | itr_arg _ (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ v) = v
146.238 - | itr_arg _ (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ v) = v
146.239 - | itr_arg _ (Const ("Script.Calculate",_) $ _ $ v) = v
146.240 - | itr_arg _ (Const ("Script.Check'_elementwise",_) $ consts $ _) = consts
146.241 - | itr_arg _ (Const ("Script.Or'_to'_List",_) $ _) = e_term
146.242 - | itr_arg _ (Const ("Script.Tac",_) $ _) = e_term
146.243 - | itr_arg _ (Const ("Script.SubProblem",_) $ _ $ _) = e_term
146.244 - | itr_arg thy t = raise error
146.245 - ("itr_arg not impl. for "^
146.246 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));
146.247 -(* val t = (term_of o the o (parse thy))"Rewrite rroot_square_inv False e_";
146.248 -> itr_arg "Script.thy" t;
146.249 -val it = Free ("e_","RealDef.real") : term
146.250 -> val t = (term_of o the o (parse thy))"xxx";
146.251 -> itr_arg "Script.thy" t;
146.252 -*** itr_arg not impl. for xxx
146.253 -uncaught exception ERROR
146.254 - raised at: library.ML:1114.35-1114.40*)
146.255 -
146.256 -
146.257 -(*.get the arguments of the script out of the scripts parsetree.*)
146.258 -fun formal_args scr = (fst o split_last o snd o strip_comb) scr;
146.259 -(*
146.260 -> formal_args scr;
146.261 - [Free ("f_","RealDef.real"),Free ("v_","RealDef.real"),
146.262 - Free ("eqs_","bool List.list")] : term list
146.263 -*)
146.264 -
146.265 -(*.get the identifier of the script out of the scripts parsetree.*)
146.266 -fun id_of_scr sc = (id_of o fst o strip_comb) sc;
146.267 -
146.268 -
146.269 -(*WN020526: not clear, when a is available in ass_up for eva-_true*)
146.270 -(*WN060906: in "fun handle_leaf" eg. uses "SOME M__"(from some PREVIOUS
146.271 - curried Rewrite) for CURRENT value (which may be different from PREVIOUS);
146.272 - thus "NONE" must be set at the end of currying (ill designed anyway)*)
146.273 -fun upd_env_opt env (SOME a, v) = upd_env env (a,v)
146.274 - | upd_env_opt env (NONE, v) =
146.275 - (writeln("*** upd_env_opt: (NONE,"^(term2str v)^")");env);
146.276 -
146.277 -
146.278 -type dsc = typ; (*<-> nam..unknow in Descript.thy*)
146.279 -fun typ_str (Type (s,_)) = s
146.280 - | typ_str (TFree(s,_)) = s
146.281 - | typ_str (TVar ((s,i),_)) = s^(string_of_int i);
146.282 -
146.283 -(*get the _result_-type of a description*)
146.284 -fun dsc_valT (Const (_,(Type (_,[_,T])))) = (strip_thy o typ_str) T;
146.285 -(*> val t = (term_of o the o (parse thy)) "equality";
146.286 -> val T = type_of t;
146.287 -val T = "bool => Tools.una" : typ
146.288 -> val dsc = dsc_valT t;
146.289 -val dsc = "una" : string
146.290 -
146.291 -> val t = (term_of o the o (parse thy)) "fixedValues";
146.292 -> val T = type_of t;
146.293 -val T = "bool List.list => Tools.nam" : typ
146.294 -> val dsc = dsc_valT t;
146.295 -val dsc = "nam" : string*)
146.296 -
146.297 -(*.from penv in itm_ make args for script depending on type of description.*)
146.298 -(*6.5.03 TODO: push penv into script -- and drop mk_arg here || drop penv
146.299 - 9.5.03 penv postponed: penv = env for script at the moment, (*mk_arg*)*)
146.300 -fun mk_arg thy d [] = raise error ("mk_arg: no data for "^
146.301 - (Syntax.string_of_term (thy2ctxt thy) d))
146.302 - | mk_arg thy d [t] =
146.303 - (case dsc_valT d of
146.304 - "una" => [t]
146.305 - | "nam" =>
146.306 - [case t of
146.307 - r as (Const ("op =",_) $ _ $ _) => r
146.308 - | _ => raise error
146.309 - ("mk_arg: dsc-typ 'nam' applied to non-equality "^
146.310 - (Syntax.string_of_term (thy2ctxt thy) t))]
146.311 - | s => raise error ("mk_arg: not impl. for "^s))
146.312 -
146.313 - | mk_arg thy d (t::ts) = (mk_arg thy d [t]) @ (mk_arg thy d ts);
146.314 -(*
146.315 - val d = d_in itm_;
146.316 - val [t] = ts_in itm_;
146.317 -mk_arg thy
146.318 -*)
146.319 -
146.320 -
146.321 -
146.322 -
146.323 -(*.create the actual parameters (args) of script: their order
146.324 - is given by the order in met.pat .*)
146.325 -(*WN.5.5.03: ?: does this allow for different descriptions ???
146.326 - ?: why not taken from formal args of script ???
146.327 -!: FIXXXME penv: push it here in itms2args into script-evaluation*)
146.328 -(* val (thy, mI, itms) = (thy, metID, itms);
146.329 - *)
146.330 -fun itms2args thy mI (itms:itm list) =
146.331 - let val mvat = max_vt itms
146.332 - fun okv mvat (_,vats,b,_,_) = member op = vats mvat andalso b
146.333 - val itms = filter (okv mvat) itms
146.334 - fun test_dsc d (_,_,_,_,itm_) = (d = d_in itm_)
146.335 - fun itm2arg itms (_,(d,_)) =
146.336 - case find_first (test_dsc d) itms of
146.337 - NONE =>
146.338 - raise error ("itms2args: '"^term2str d^"' not in itms")
146.339 - (*| SOME (_,_,_,_,itm_) => mk_arg thy (d_in itm_) (ts_in itm_);
146.340 - penv postponed; presently penv holds already env for script*)
146.341 - | SOME (_,_,_,_,itm_) => penvval_in itm_
146.342 - fun sel_given_find (s,_) = (s = "#Given") orelse (s = "#Find")
146.343 - val pats = (#ppc o get_met) mI
146.344 - in (flat o (map (itm2arg itms))) pats end;
146.345 -(*
146.346 -> val sc = ... Solve_root_equation ...
146.347 -> val mI = ("Script.thy","sqrt-equ-test");
146.348 -> val PblObj{meth={ppc=itms,...},...} = get_obj I pt [];
146.349 -> val ts = itms2args thy mI itms;
146.350 -> map (Syntax.string_of_term (thy2ctxt thy)) ts;
146.351 -["sqrt (#9 + #4 * x) = sqrt x + sqrt (#5 + x)","x","#0"] : string list
146.352 -*)
146.353 -
146.354 -
146.355 -(*["bool_ (1+x=2)","real_ x"] --match_ags--> oris
146.356 - --oris2fmz_vals--> ["equality (1+x=2)","boundVariable x","solutions L"]*)
146.357 -fun oris2fmz_vals oris =
146.358 - let fun ori2fmz_vals ((_,_,_,dsc,ts):ori) =
146.359 - ((term2str o comp_dts') (dsc, ts), last_elem ts)
146.360 - handle _ => raise error ("ori2fmz_env called with "^terms2str ts)
146.361 - in (split_list o (map ori2fmz_vals)) oris end;
146.362 -
146.363 -(*detour necessary, because generate1 delivers a string-result*)
146.364 -fun mout2term thy (Form' (FormKF (_,_,_,_,res))) =
146.365 - (term_of o the o (parse (assoc_thy thy))) res
146.366 - | mout2term thy (Form' (PpcKF _)) = e_term;(*3.8.01: res of subpbl
146.367 - at time of detection in script*)
146.368 -
146.369 -(*.convert a script-tac 'stac' to a tactic 'tac'; if stac is an initac,
146.370 - then convert to a 'tac_' (as required in appy).
146.371 - arg pt:ptree for pushing the thy specified in rootpbl into subpbls.*)
146.372 -fun stac2tac_ pt thy (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f) =
146.373 -(* val (pt, thy, (Const ("Script.Rewrite",_) $ Free (thmID,_) $ _ $ f)) =
146.374 - (pt, (assoc_thy th), stac);
146.375 - *)
146.376 - let val tid = (de_esc_underscore o strip_thy) thmID
146.377 - in (Rewrite (tid, (string_of_thmI o
146.378 - (assoc_thm' thy)) (tid,"")), Empty_Tac_) end
146.379 -(* val (thy,
146.380 - mm as(Const ("Script.Rewrite'_Inst",_) $ sub $ Free(thmID,_) $ _ $ f))
146.381 - = (assoc_thy th,stac);
146.382 - stac2tac_ pt thy mm;
146.383 -
146.384 - assoc_thm' (assoc_thy "Isac.thy") (tid,"");
146.385 - assoc_thm' Isac.thy (tid,"");
146.386 - *)
146.387 - | stac2tac_ pt thy (Const ("Script.Rewrite'_Inst",_) $
146.388 - sub $ Free (thmID,_) $ _ $ f) =
146.389 - let val subML = ((map isapair2pair) o isalist2list) sub
146.390 - val subStr = subst2subs subML
146.391 - val tid = (de_esc_underscore o strip_thy) thmID (*4.10.02 unnoetig*)
146.392 - in (Rewrite_Inst
146.393 - (subStr, (tid, (string_of_thmI o
146.394 - (assoc_thm' thy)) (tid,""))), Empty_Tac_) end
146.395 -
146.396 - | stac2tac_ pt thy (Const ("Script.Rewrite'_Set",_) $ Free (rls,_) $ _ $ f)=
146.397 - (Rewrite_Set ((de_esc_underscore o strip_thy) rls), Empty_Tac_)
146.398 -
146.399 - | stac2tac_ pt thy (Const ("Script.Rewrite'_Set'_Inst",_) $
146.400 - sub $ Free (rls,_) $ _ $ f) =
146.401 - let val subML = ((map isapair2pair) o isalist2list) sub;
146.402 - val subStr = subst2subs subML;
146.403 - in (Rewrite_Set_Inst (subStr,rls), Empty_Tac_) end
146.404 -
146.405 - | stac2tac_ pt thy (Const ("Script.Calculate",_) $ Free (op_,_) $ f) =
146.406 - (Calculate op_, Empty_Tac_)
146.407 -
146.408 - | stac2tac_ pt thy (Const ("Script.Take",_) $ t) =
146.409 - (Take (term2str t), Empty_Tac_)
146.410 -
146.411 - | stac2tac_ pt thy (Const ("Script.Substitute",_) $ isasub $ arg) =
146.412 - (Substitute ((subte2sube o isalist2list) isasub), Empty_Tac_)
146.413 -(* val t = str2term"Substitute [x = L, M_b L = 0] (M_b x = q_0 * x + c)";
146.414 - val Const ("Script.Substitute", _) $ isasub $ arg = t;
146.415 - *)
146.416 -
146.417 -(*12.1.01.*)
146.418 - | stac2tac_ pt thy (Const("Script.Check'_elementwise",_) $ _ $
146.419 - (set as Const ("Collect",_) $ Abs (_,_,pred))) =
146.420 - (Check_elementwise (Syntax.string_of_term (thy2ctxt thy) pred),
146.421 - (*set*)Empty_Tac_)
146.422 -
146.423 - | stac2tac_ pt thy (Const("Script.Or'_to'_List",_) $ _ ) =
146.424 - (Or_to_List, Empty_Tac_)
146.425 -
146.426 -(*12.1.01.for subproblem_equation_dummy in root-equation *)
146.427 - | stac2tac_ pt thy (Const ("Script.Tac",_) $ Free (str,_)) =
146.428 - (Tac ((de_esc_underscore o strip_thy) str), Empty_Tac_)
146.429 - (*L_ will come from pt in appl_in*)
146.430 -
146.431 - (*3.12.03 copied from assod SubProblem*)
146.432 -(* val Const ("Script.SubProblem",_) $
146.433 - (Const ("Pair",_) $
146.434 - Free (dI',_) $
146.435 - (Const ("Pair",_) $ pI' $ mI')) $ ags' =
146.436 - str2term
146.437 - "SubProblem (EqSystem_, [linear, system], [no_met])\
146.438 - \ [bool_list_ [c_2 = 0, L * c + c_2 = q_0 * L ^^^ 2 / 2],\
146.439 - \ real_list_ [c, c_2]]";
146.440 -*)
146.441 - | stac2tac_ pt thy (stac as Const ("Script.SubProblem",_) $
146.442 - (Const ("Pair",_) $
146.443 - Free (dI',_) $
146.444 - (Const ("Pair",_) $ pI' $ mI')) $ ags') =
146.445 -(*compare "| assod _ (Subproblem'"*)
146.446 - let val dI = ((implode o drop_last(*.._*) o explode) dI')^".thy";
146.447 - val thy = maxthy (assoc_thy dI) (rootthy pt);
146.448 - val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI';
146.449 - val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI';
146.450 - val ags = isalist2list ags';
146.451 - val (pI, pors, mI) =
146.452 - if mI = ["no_met"]
146.453 - then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags)
146.454 - handle _ =>(match_ags_msg pI stac ags(*raise exn*);[])
146.455 - val pI' = refine_ori' pors pI;
146.456 - in (pI', pors (*refinement over models with diff.prec only*),
146.457 - (hd o #met o get_pbt) pI') end
146.458 - else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags)
146.459 - handle _ => (match_ags_msg pI stac ags(*raise exn*); []),
146.460 - mI);
146.461 - val (fmz_, vals) = oris2fmz_vals pors;
146.462 - val {cas,ppc,thy,...} = get_pbt pI
146.463 - val dI = theory2theory' thy (*.take dI from _refined_ pbl.*)
146.464 - val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt));
146.465 - val hdl = case cas of
146.466 - NONE => pblterm dI pI
146.467 - | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t
146.468 - val f = subpbl (strip_thy dI) pI
146.469 - in (Subproblem (dI, pI),
146.470 - Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f))
146.471 - end
146.472 -
146.473 - | stac2tac_ pt thy t = raise error
146.474 - ("stac2tac_ TODO: no match for "^
146.475 - (Syntax.string_of_term (thy2ctxt thy) t));
146.476 -(*
146.477 -> val t = (term_of o the o (parse thy))
146.478 - "Rewrite_Set_Inst [(bdv,v_::real)] isolate_bdv False (x=a+#1)";
146.479 -> stac2tac_ pt t;
146.480 -val it = Rewrite_Set_Inst ([(#,#)],"isolate_bdv") : tac
146.481 -
146.482 -> val t = (term_of o the o (parse SqRoot.thy))
146.483 -"(SubProblem (SqRoot_,[equation,univariate],(SqRoot_,solve_linear))\
146.484 - \ [bool_ e_, real_ v_])::bool list";
146.485 -> stac2tac_ pt SqRoot.thy t;
146.486 -val it = (Subproblem ("SqRoot.thy",[#,#]),Const (#,#) $ (# $ # $ (# $ #)))
146.487 -*)
146.488 -
146.489 -fun stac2tac pt thy t = (fst o stac2tac_ pt thy) t;
146.490 -
146.491 -
146.492 -
146.493 -
146.494 -(*test a term for being a _list_ (set ?) of constants; could be more rigorous*)
146.495 -fun list_of_consts (Const ("List.list.Cons",_) $ _ $ _) = true
146.496 - | list_of_consts (Const ("List.list.Nil",_)) = true
146.497 - | list_of_consts _ = false;
146.498 -(*val ttt = (term_of o the o (parse thy)) "[x=#1,x=#2,x=#3]";
146.499 -> list_of_consts ttt;
146.500 -val it = true : bool
146.501 -> val ttt = (term_of o the o (parse thy)) "[]";
146.502 -> list_of_consts ttt;
146.503 -val it = true : bool*)
146.504 -
146.505 -
146.506 -
146.507 -
146.508 -
146.509 -(* 15.1.01: evaluation of preds only works occasionally,
146.510 - but luckily for the 2 examples of root-equ:
146.511 -> val s = ((term_of o the o (parse thy)) "x",
146.512 - (term_of o the o (parse thy)) "-#5//#12");
146.513 -> val asm = (term_of o the o (parse thy))
146.514 - "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#-3 + x)";
146.515 -> val pred = subst_atomic [s] asm;
146.516 -> rewrite_set_ thy false ((cterm_of thy) pred);
146.517 -val it = NONE : (cterm * cterm list) option !!!!!!!!!!!!!!!!!!!!!!!!!!!!
146.518 -> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
146.519 -val it = false : bool
146.520 -
146.521 -> val s = ((term_of o the o (parse thy)) "x",
146.522 - (term_of o the o (parse thy)) "#4");
146.523 -> val asm = (term_of o the o (parse thy))
146.524 - "#0 <= #9 + #4 * x & #0 <= sqrt x + sqrt (#5 + x)";
146.525 -> val pred = subst_atomic [s] asm;
146.526 -> rewrite_set_ thy false ((cterm_of thy) pred);
146.527 -val it = SOME ("True & True",[]) : (cterm * cterm list) option
146.528 -> eval_true' (string_of_thy thy) "eval_rls" (subst_atomic [s] pred);
146.529 -val it = true : bool`*)
146.530 -
146.531 -(*for check_elementwise: take apart the set, ev. instantiate assumptions
146.532 -fun rep_set thy pt p (set as Const ("Collect",_) $ Abs _) =
146.533 - let val (_ $ Abs (bdv,T,pred)) = inst_abs thy set;
146.534 - val bdv = Free (bdv,T);
146.535 - val pred = if pred <> Const ("Script.Assumptions",bool)
146.536 - then pred
146.537 - else (mk_and o (map fst)) (get_assumptions_ pt (p,Res))
146.538 - in (bdv, pred) end
146.539 - | rep_set thy _ _ set =
146.540 - raise error ("check_elementwise: no set "^ (*from script*)
146.541 - (Syntax.string_of_term (thy2ctxt thy) set));
146.542 -(*> val set = (term_of o the o (parse thy)) "{(x::real). Assumptions}";
146.543 -> val p = [];
146.544 -> val pt = union_asm pt p [("#0 <= sqrt x + sqrt (#5 + x)",[11]),
146.545 - ("#0 <= #9 + #4 * x",[22]),
146.546 - ("#0 <= x ^^^ #2 + #5 * x",[33]),
146.547 - ("#0 <= #2 + x",[44])];
146.548 -> val (bdv,pred) = rep_set thy pt p set;
146.549 -val bdv = Free ("x","RealDef.real") : term
146.550 -> writeln (Syntax.string_of_term (thy2ctxt thy) pred);
146.551 -((#0 <= sqrt x + sqrt (#5 + x) & #0 <= #9 + #4 * x) &
146.552 - #0 <= x ^^^ #2 + #5 * x) &
146.553 -#0 <= #2 + x
146.554 -*)
146.555 ---------------------------------------------11.6.03--was unused*)
146.556 -
146.557 -
146.558 -
146.559 -
146.560 -datatype ass =
146.561 - Ass of tac_ * (*SubProblem gets args instantiated in assod*)
146.562 - term (*for itr_arg,result in ets*)
146.563 -| AssWeak of tac_ *
146.564 - term (*for itr_arg,result in ets*)
146.565 -| NotAss;
146.566 -
146.567 -(*.assod: tac_ associated with stac w.r.t. d
146.568 -args
146.569 - pt:ptree for pushing the thy specified in rootpbl into subpbls
146.570 -returns
146.571 - Ass : associated: e.g. thmID in stac = thmID in m
146.572 - +++ arg in stac = arg in m
146.573 - AssWeak: weakly ass.:e.g. thmID in stac = thmID in m, //arg//
146.574 - NotAss : e.g. thmID in stac/=/thmID in m (not =)
146.575 -8.01:
146.576 - tac_ SubProblem with args completed from script
146.577 -.*)
146.578 -fun assod pt d (m as Rewrite_Inst' (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) stac =
146.579 - (case stac of
146.580 - (Const ("Script.Rewrite'_Inst",_) $ subs_ $ Free (thmID_,idT) $b$f_)=>
146.581 - if thmID = thmID_ then
146.582 - if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
146.583 - else ((*writeln"3### assod ..AssWeak";*)AssWeak(m, f'))
146.584 - else ((*writeln"3### assod ..NotAss";*)NotAss)
146.585 - | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $_$f_)=>
146.586 - if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then
146.587 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.588 - else NotAss
146.589 - | _ => NotAss)
146.590 -
146.591 - | assod pt d (m as Rewrite' (thy,rod,rls,put,(thmID,thm),f,(f',asm))) stac =
146.592 - (case stac of
146.593 - (t as Const ("Script.Rewrite",_) $ Free (thmID_,idT) $ b $ f_) =>
146.594 - ((*writeln("3### assod: stac = "^
146.595 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));
146.596 - writeln("3### assod: f(m)= "^
146.597 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) f));*)
146.598 - if thmID = thmID_ then
146.599 - if f = f_ then ((*writeln"3### assod ..Ass";*)Ass (m,f'))
146.600 - else ((*writeln"### assod ..AssWeak";
146.601 - writeln("### assod: f(m) = "^
146.602 - (Sign.string_of_term (sign_of(assoc_thy thy)) f));
146.603 - writeln("### assod: f(stac)= "^
146.604 - (Sign.string_of_term(sign_of(assoc_thy thy))f_))*)
146.605 - AssWeak (m,f'))
146.606 - else ((*writeln"3### assod ..NotAss";*)NotAss))
146.607 - | (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =>
146.608 - if contains_rule (Thm (thmID, refl(*dummy*))) (assoc_rls rls_) then
146.609 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.610 - else NotAss
146.611 - | _ => NotAss)
146.612 -
146.613 -(*val f = (term_of o the o (parse thy))"#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0";
146.614 -> val f'= (term_of o the o (parse thy))"#0+(sqrt(sqrt a))^^^#2=#0";
146.615 -> val m = Rewrite'("Script.thy","tless_true","eval_rls",false,
146.616 - ("rroot_square_inv",""),f,(f',[]));
146.617 -> val stac = (term_of o the o (parse thy))
146.618 - "Rewrite rroot_square_inv False (#0+(sqrt(sqrt(sqrt a))^^^#2)^^^#2=#0)";
146.619 -> assod e_rls m stac;
146.620 -val it =
146.621 - (SOME (Rewrite' (#,#,#,#,#,#,#)),Const ("empty","RealDef.real"),
146.622 - Const ("empty","RealDef.real")) : tac_ option * term * term*)
146.623 -
146.624 - | assod pt d (m as Rewrite_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
146.625 - (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
146.626 - if id_rls rls = rls_ then
146.627 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.628 - else NotAss
146.629 -
146.630 - | assod pt d (m as Detail_Set_Inst' (thy',put,sub,rls,f,(f',asm)))
146.631 - (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free (rls_,_) $ _ $ f_)=
146.632 - if id_rls rls = rls_ then
146.633 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.634 - else NotAss
146.635 -
146.636 - | assod pt d (m as Rewrite_Set' (thy,put,rls,f,(f',asm)))
146.637 - (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
146.638 - if id_rls rls = rls_ then
146.639 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.640 - else NotAss
146.641 -
146.642 - | assod pt d (m as Detail_Set' (thy,put,rls,f,(f',asm)))
146.643 - (Const ("Script.Rewrite'_Set",_) $ Free (rls_,_) $ _ $ f_) =
146.644 - if id_rls rls = rls_ then
146.645 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.646 - else NotAss
146.647 -
146.648 - | assod pt d (m as Calculate' (thy',op_,f,(f',thm'))) stac =
146.649 - (case stac of
146.650 - (Const ("Script.Calculate",_) $ Free (op__,_) $ f_) =>
146.651 - if op_ = op__ then
146.652 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.653 - else NotAss
146.654 - | (Const ("Script.Rewrite'_Set'_Inst",_) $ sub_ $ Free(rls_,_) $_$f_)=>
146.655 - if contains_rule (Calc (snd (assoc1 (!calclist', op_))))
146.656 - (assoc_rls rls_) then
146.657 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.658 - else NotAss
146.659 - | (Const ("Script.Rewrite'_Set",_) $ Free (rls_, _) $ _ $ f_) =>
146.660 - if contains_rule (Calc (snd (assoc1 (!calclist', op_))))
146.661 - (assoc_rls rls_) then
146.662 - if f = f_ then Ass (m,f') else AssWeak (m,f')
146.663 - else NotAss
146.664 - | _ => NotAss)
146.665 -
146.666 - | assod pt _ (m as Check_elementwise' (consts,_,(consts_chkd,_)))
146.667 - (Const ("Script.Check'_elementwise",_) $ consts' $ _) =
146.668 - ((*writeln("### assod Check'_elementwise: consts= "^(term2str consts)^
146.669 - ", consts'= "^(term2str consts'));
146.670 - atomty consts; atomty consts';*)
146.671 - if consts = consts' then ((*writeln"### assod Check'_elementwise: Ass";*)
146.672 - Ass (m, consts_chkd))
146.673 - else ((*writeln"### assod Check'_elementwise: NotAss";*) NotAss))
146.674 -
146.675 - | assod pt _ (m as Or_to_List' (ors, list))
146.676 - (Const ("Script.Or'_to'_List",_) $ _) =
146.677 - Ass (m, list)
146.678 -
146.679 - | assod pt _ (m as Take' term)
146.680 - (Const ("Script.Take",_) $ _) =
146.681 - Ass (m, term)
146.682 -
146.683 - | assod pt _ (m as Substitute' (_, _, res))
146.684 - (Const ("Script.Substitute",_) $ _ $ _) =
146.685 - Ass (m, res)
146.686 -(* val t = str2term "Substitute [(x, 3)] (x^^^2 + x + 1)";
146.687 - val (Const ("Script.Substitute",_) $ _ $ _) = t;
146.688 - *)
146.689 -
146.690 - | assod pt _ (m as Tac_ (thy,f,id,f'))
146.691 - (Const ("Script.Tac",_) $ Free (id',_)) =
146.692 - if id = id' then Ass (m, ((term_of o the o (parse thy)) f'))
146.693 - else NotAss
146.694 -
146.695 -
146.696 -(* val t = str2term
146.697 - "SubProblem (DiffApp_,[make,function],[no_met]) \
146.698 - \[real_ m_, real_ v_, bool_list_ rs_]";
146.699 -
146.700 - val (Subproblem' ((domID,pblID,metID),_,_,_,f)) = m;
146.701 - val (Const ("Script.SubProblem",_) $
146.702 - (Const ("Pair",_) $
146.703 - Free (dI',_) $
146.704 - (Const ("Pair",_) $ pI' $ mI')) $ ags') = stac;
146.705 - *)
146.706 - | assod pt _ (Subproblem' ((domID,pblID,metID),_,_,_,f))
146.707 - (stac as Const ("Script.SubProblem",_) $
146.708 - (Const ("Pair",_) $
146.709 - Free (dI',_) $
146.710 - (Const ("Pair",_) $ pI' $ mI')) $ ags') =
146.711 -(*compare "| stac2tac_ thy (Const ("Script.SubProblem",_)"*)
146.712 - let val dI = ((implode o drop_last o explode) dI')^".thy";
146.713 - val thy = maxthy (assoc_thy dI) (rootthy pt);
146.714 - val pI = ((map (de_esc_underscore o free2str)) o isalist2list) pI';
146.715 - val mI = ((map (de_esc_underscore o free2str)) o isalist2list) mI';
146.716 - val ags = isalist2list ags';
146.717 - val (pI, pors, mI) =
146.718 - if mI = ["no_met"]
146.719 - then let val pors = (match_ags thy ((#ppc o get_pbt) pI) ags)
146.720 - handle _=>(match_ags_msg pI stac ags(*raise exn*);[]);
146.721 - val pI' = refine_ori' pors pI;
146.722 - in (pI', pors (*refinement over models with diff.prec only*),
146.723 - (hd o #met o get_pbt) pI') end
146.724 - else (pI, (match_ags thy ((#ppc o get_pbt) pI) ags)
146.725 - handle _ => (match_ags_msg pI stac ags(*raise exn*);[]),
146.726 - mI);
146.727 - val (fmz_, vals) = oris2fmz_vals pors;
146.728 - val {cas, ppc,...} = get_pbt pI
146.729 - val {cas, ppc, thy,...} = get_pbt pI
146.730 - val dI = theory2theory' thy (*take dI from _refined_ pbl*)
146.731 - val dI = theory2theory' (maxthy (assoc_thy dI) (rootthy pt))
146.732 - val hdl = case cas of
146.733 - NONE => pblterm dI pI
146.734 - | SOME t => subst_atomic ((vars_of_pbl_' ppc) ~~~ vals) t
146.735 - val f = subpbl (strip_thy dI) pI
146.736 - in if domID = dI andalso pblID = pI
146.737 - then Ass (Subproblem' ((dI, pI, mI), pors, hdl, fmz_, f), f)
146.738 - else NotAss
146.739 - end
146.740 -
146.741 - | assod pt d m t =
146.742 - (if (!trace_script)
146.743 - then writeln("@@@ the 'tac_' proposed to apply does NOT match the leaf found in the script:\n"^
146.744 - "@@@ tac_ = "^(tac_2str m))
146.745 - else ();
146.746 - NotAss);
146.747 -
146.748 -
146.749 -
146.750 -fun tac_2tac (Refine_Tacitly' (pI,_,_,_,_)) = Refine_Tacitly pI
146.751 - | tac_2tac (Model_Problem' (pI,_,_)) = Model_Problem
146.752 - | tac_2tac (Add_Given' (t,_)) = Add_Given t
146.753 - | tac_2tac (Add_Find' (t,_)) = Add_Find t
146.754 - | tac_2tac (Add_Relation' (t,_)) = Add_Relation t
146.755 -
146.756 - | tac_2tac (Specify_Theory' dI) = Specify_Theory dI
146.757 - | tac_2tac (Specify_Problem' (dI,_)) = Specify_Problem dI
146.758 - | tac_2tac (Specify_Method' (dI,_,_)) = Specify_Method dI
146.759 -
146.760 - | tac_2tac (Rewrite' (thy,rod,erls,put,(thmID,thm),f,(f',asm))) =
146.761 - Rewrite (thmID,thm)
146.762 -
146.763 - | tac_2tac (Rewrite_Inst' (thy,rod,erls,put,sub,(thmID,thm),f,(f',asm)))=
146.764 - Rewrite_Inst (subst2subs sub,(thmID,thm))
146.765 -
146.766 - | tac_2tac (Rewrite_Set' (thy,put,rls,f,(f',asm))) =
146.767 - Rewrite_Set (id_rls rls)
146.768 -
146.769 - | tac_2tac (Detail_Set' (thy,put,rls,f,(f',asm))) =
146.770 - Detail_Set (id_rls rls)
146.771 -
146.772 - | tac_2tac (Rewrite_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
146.773 - Rewrite_Set_Inst (subst2subs sub,id_rls rls)
146.774 -
146.775 - | tac_2tac (Detail_Set_Inst' (thy,put,sub,rls,f,(f',asm))) =
146.776 - Detail_Set_Inst (subst2subs sub,id_rls rls)
146.777 -
146.778 - | tac_2tac (Calculate' (thy,op_,t,(t',thm'))) = Calculate (op_)
146.779 -
146.780 - | tac_2tac (Check_elementwise' (consts,pred,consts')) =
146.781 - Check_elementwise pred
146.782 -
146.783 - | tac_2tac (Or_to_List' _) = Or_to_List
146.784 - | tac_2tac (Take' term) = Take (term2str term)
146.785 - | tac_2tac (Substitute' (subte, t, res)) = Substitute (subte2sube subte)
146.786 -
146.787 - | tac_2tac (Tac_ (_,f,id,f')) = Tac id
146.788 -
146.789 - | tac_2tac (Subproblem' ((domID, pblID, _), _, _,_,_)) =
146.790 - Subproblem (domID, pblID)
146.791 - | tac_2tac (Check_Postcond' (pblID, _)) =
146.792 - Check_Postcond pblID
146.793 - | tac_2tac Empty_Tac_ = Empty_Tac
146.794 -
146.795 - | tac_2tac m =
146.796 - raise error ("tac_2tac: not impl. for "^(tac_2str m));
146.797 -
146.798 -
146.799 -
146.800 -
146.801 -(** decompose tac_ to a rule and to (lhs,rhs)
146.802 - unly needed ~~~ **)
146.803 -
146.804 -val idT = Type ("Script.ID",[]);
146.805 -(*val tt = (term_of o the o (parse thy)) "square_equation_left::ID";
146.806 -type_of tt = idT;
146.807 -val it = true : bool
146.808 -*)
146.809 -
146.810 -fun make_rule thy t =
146.811 - let val ct = cterm_of thy (Trueprop $ t)
146.812 - in Thm (Syntax.string_of_term (thy2ctxt thy) (term_of ct), make_thm ct) end;
146.813 -
146.814 -(* val (Rewrite_Inst'(thy',rod,rls,put,subs,(thmID,thm),f,(f',asm)))=m;
146.815 - *)
146.816 -(*decompose tac_ to a rule and to (lhs,rhs) for ets FIXME.12.03: obsolete!
146.817 - NOTE.12.03: also used for msg 'not locatable' ?!: 'Subproblem' missing !!!
146.818 -WN0508 only use in tac_2res, which uses only last return-value*)
146.819 -fun rep_tac_ (Rewrite_Inst'
146.820 - (thy',rod,rls,put,subs,(thmID,thm),f,(f',asm))) =
146.821 - let val fT = type_of f;
146.822 - val b = if put then HOLogic.true_const else HOLogic.false_const;
146.823 - val sT = (type_of o fst o hd) subs;
146.824 - val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
146.825 - (map HOLogic.mk_prod subs);
146.826 - val sT' = type_of subs';
146.827 - val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,(*fT*)bool,fT] ---> fT)
146.828 - $ subs' $ Free (thmID,idT) $ b $ f;
146.829 - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
146.830 -(*Fehlersuche 25.4.01
146.831 -(a)----- als String zusammensetzen:
146.832 -ML> Syntax.string_of_term (thy2ctxt thy)f;
146.833 -val it = "d_d x #4 + d_d x (x ^^^ #2 + #3 * x)" : string
146.834 -ML> Syntax.string_of_term (thy2ctxt thy)f';
146.835 -val it = "#0 + d_d x (x ^^^ #2 + #3 * x)" : string
146.836 -ML> subs;
146.837 -val it = [(Free ("bdv","RealDef.real"),Free ("x","RealDef.real"))] : subst
146.838 -> val tt = (term_of o the o (parse thy))
146.839 - "(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))";
146.840 -> atomty tt;
146.841 -ML> writeln(Syntax.string_of_term (thy2ctxt thy)tt);
146.842 -(Rewrite_Inst [(bdv,x)] diff_const False d_d x #4 + d_d x (x ^^^ #2 + #3 * x)) =
146.843 - #0 + d_d x (x ^^^ #2 + #3 * x)
146.844 -
146.845 -(b)----- laut rep_tac_:
146.846 -> val ttt=HOLogic.mk_eq (lhs,f');
146.847 -> atomty ttt;
146.848 -
146.849 -
146.850 -(*Fehlersuche 1-2Monate vor 4.01:*)
146.851 -> val tt = (term_of o the o (parse thy))
146.852 - "Rewrite_Inst[(bdv,x)]square_equation_left True(x=#1+#2)";
146.853 -> atomty tt;
146.854 -
146.855 -> val f = (term_of o the o (parse thy)) "x=#1+#2";
146.856 -> val f' = (term_of o the o (parse thy)) "x=#3";
146.857 -> val subs = [((term_of o the o (parse thy)) "bdv",
146.858 - (term_of o the o (parse thy)) "x")];
146.859 -> val sT = (type_of o fst o hd) subs;
146.860 -> val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
146.861 - (map HOLogic.mk_prod subs);
146.862 -> val sT' = type_of subs';
146.863 -> val lhs = Const ("Script.Rewrite'_Inst",[sT',idT,fT,fT] ---> fT)
146.864 - $ subs' $ Free (thmID,idT) $ HOLogic.true_const $ f;
146.865 -> lhs = tt;
146.866 -val it = true : bool
146.867 -> rep_tac_ (Rewrite_Inst'
146.868 - ("Script.thy","tless_true","eval_rls",false,subs,
146.869 - ("square_equation_left",""),f,(f',[])));
146.870 -*)
146.871 - | rep_tac_ (Rewrite' (thy',rod,rls,put,(thmID,thm),f,(f',asm)))=
146.872 - let
146.873 - val fT = type_of f;
146.874 - val b = if put then HOLogic.true_const else HOLogic.false_const;
146.875 - val lhs = Const ("Script.Rewrite",[idT,HOLogic.boolT,fT] ---> fT)
146.876 - $ Free (thmID,idT) $ b $ f;
146.877 - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
146.878 -(*
146.879 -> val tt = (term_of o the o (parse thy)) (*____ ____..test*)
146.880 - "Rewrite square_equation_left True (x=#1+#2) = (x=#3)";
146.881 -
146.882 -> val f = (term_of o the o (parse thy)) "x=#1+#2";
146.883 -> val f' = (term_of o the o (parse thy)) "x=#3";
146.884 -> val Thm (id,thm) =
146.885 - rep_tac_ (Rewrite'
146.886 - ("Script.thy","tless_true","eval_rls",false,
146.887 - ("square_equation_left",""),f,(f',[])));
146.888 -> val SOME ct = parse thy
146.889 - "Rewrite square_equation_left True (x=#1+#2)";
146.890 -> rewrite_ Script.thy tless_true eval_rls true thm ct;
146.891 -val it = SOME ("x = #3",[]) : (cterm * cterm list) option
146.892 -*)
146.893 - | rep_tac_ (Rewrite_Set_Inst'
146.894 - (thy',put,subs,rls,f,(f',asm))) =
146.895 - (e_rule, (e_term, f'))
146.896 -(*WN050824: type error ...
146.897 - let val fT = type_of f;
146.898 - val sT = (type_of o fst o hd) subs;
146.899 - val subs' = list2isalist (HOLogic.mk_prodT (sT, sT))
146.900 - (map HOLogic.mk_prod subs);
146.901 - val sT' = type_of subs';
146.902 - val b = if put then HOLogic.true_const else HOLogic.false_const
146.903 - val lhs = Const ("Script.Rewrite'_Set'_Inst",
146.904 - [sT',idT,fT,fT] ---> fT)
146.905 - $ subs' $ Free (id_rls rls,idT) $ b $ f;
146.906 - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end*)
146.907 -(* ... vals from Rewrite_Inst' ...
146.908 -> rep_tac_ (Rewrite_Set_Inst'
146.909 - ("Script.thy",false,subs,
146.910 - "isolate_bdv",f,(f',[])));
146.911 -*)
146.912 -(* val (Rewrite_Set' (thy',put,rls,f,(f',asm)))=m;
146.913 -*)
146.914 - | rep_tac_ (Rewrite_Set' (thy',put,rls,f,(f',asm)))=
146.915 - let val fT = type_of f;
146.916 - val b = if put then HOLogic.true_const else HOLogic.false_const;
146.917 - val lhs = Const ("Script.Rewrite'_Set",[idT,bool,fT] ---> fT)
146.918 - $ Free (id_rls rls,idT) $ b $ f;
146.919 - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
146.920 -(* 13.3.01:
146.921 -val thy = assoc_thy thy';
146.922 -val t = HOLogic.mk_eq (lhs,f');
146.923 -make_rule thy t;
146.924 ---------------------------------------------------
146.925 -val lll = (term_of o the o (parse thy))
146.926 - "Rewrite_Set SqRoot_simplify False (d_d x (x ^^^ #2 + #3 * x) + d_d x #4)";
146.927 -
146.928 ---------------------------------------------------
146.929 -> val f = (term_of o the o (parse thy)) "x=#1+#2";
146.930 -> val f' = (term_of o the o (parse thy)) "x=#3";
146.931 -> val Thm (id,thm) =
146.932 - rep_tac_ (Rewrite_Set'
146.933 - ("Script.thy",false,"SqRoot_simplify",f,(f',[])));
146.934 -val id = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : string
146.935 -val thm = "(Rewrite_Set SqRoot_simplify True x = #1 + #2) = (x = #3)" : thm
146.936 -*)
146.937 - | rep_tac_ (Calculate' (thy',op_,f,(f',thm')))=
146.938 - let val fT = type_of f;
146.939 - val lhs = Const ("Script.Calculate",[idT,fT] ---> fT)
146.940 - $ Free (op_,idT) $ f
146.941 - in (((make_rule (assoc_thy thy')) o HOLogic.mk_eq) (lhs,f'),(lhs,f')) end
146.942 -(*
146.943 -> val lhs'=(term_of o the o (parse thy))"Calculate plus (#1+#2)";
146.944 - ... test-root-equ.sml: calculate ...
146.945 -> val Appl m'=applicable_in p pt (Calculate "PLUS");
146.946 -> val (lhs,_)=tac_2etac m';
146.947 -> lhs'=lhs;
146.948 -val it = true : bool*)
146.949 - | rep_tac_ (Check_elementwise' (t,str,(t',asm))) = (Erule, (e_term, t'))
146.950 - | rep_tac_ (Subproblem' (_,_,_,_,t')) = (Erule, (e_term, t'))
146.951 - | rep_tac_ (Take' (t')) = (Erule, (e_term, t'))
146.952 - | rep_tac_ (Substitute' (subst,t,t')) = (Erule, (t, t'))
146.953 - | rep_tac_ (Or_to_List' (t, t')) = (Erule, (t, t'))
146.954 - | rep_tac_ m = raise error ("rep_tac_: not impl.for "^
146.955 - (tac_2str m));
146.956 -
146.957 -(*"N.3.6.03------
146.958 -fun tac_2rule m = (fst o rep_tac_) m;
146.959 -fun tac_2etac m = (snd o rep_tac_) m;
146.960 -fun tac_2tac m = (fst o snd o rep_tac_) m;*)
146.961 -fun tac_2res m = (snd o snd o rep_tac_) m;(*ONLYuse of rep_tac_
146.962 - FIXXXXME: simplify rep_tac_*)
146.963 -
146.964 -
146.965 -(*.handle a leaf;
146.966 - a leaf is either a tactic or an 'exp' in 'let v = expr'
146.967 - where 'exp' does not contain a tactic.
146.968 - handling a leaf comprises
146.969 - (1) 'subst_stacexpr' substitute env and complete curried tactic
146.970 - (2) rewrite the leaf by 'srls'
146.971 -WN060906 quick and dirty fix: return a' too (for updating E later)
146.972 -.*)
146.973 -fun handle_leaf call thy srls E a v t =
146.974 - (*WN050916 'upd_env_opt' is a blind copy from previous version*)
146.975 - case subst_stacexpr E a v t of
146.976 - (a', STac stac) => (*script-tactic*)
146.977 - let val stac' = eval_listexpr_ (assoc_thy thy) srls
146.978 - (subst_atomic (upd_env_opt E (a,v)) stac)
146.979 - in (if (!trace_script)
146.980 - then writeln ("@@@ "^call^" leaf '"^term2str t^"' ---> STac '"^
146.981 - term2str stac'^"'")
146.982 - else ();
146.983 - (a', STac stac'))
146.984 - end
146.985 - | (a', Expr lexpr) => (*leaf-expression*)
146.986 - let val lexpr' = eval_listexpr_ (assoc_thy thy) srls
146.987 - (subst_atomic (upd_env_opt E (a,v)) lexpr)
146.988 - in (if (!trace_script)
146.989 - then writeln("@@@ "^call^" leaf '"^term2str t^"' ---> Expr '"^
146.990 - term2str lexpr'^"'")
146.991 - else ();
146.992 - (a', Expr lexpr'))
146.993 - end;
146.994 -
146.995 -
146.996 -
146.997 -(** locate an applicable stactic in a script **)
146.998 -
146.999 -datatype assoc = (*ExprVal in the sense of denotational semantics*)
146.1000 - Assoc of (*the stac is associated, strongly or weakly*)
146.1001 - scrstate * (*the current; returned for next_tac etc. outside ass* *)
146.1002 - (step list) (*list of steps done until associated stac found;
146.1003 - initiated with the data for doing the 1st step,
146.1004 - thus the head holds these data further on,
146.1005 - while the tail holds steps finished (incl.scrstate in ptree)*)
146.1006 -| NasApp of (*stac not associated, but applicable, ptree-node generated*)
146.1007 - scrstate * (step list)
146.1008 -| NasNap of (*stac not associated, not applicable, nothing generated;
146.1009 - for distinction in Or, for leaving iterations, leaving Seq,
146.1010 - evaluate scriptexpressions*)
146.1011 - term * env;
146.1012 -fun assoc2str (Assoc _) = "Assoc"
146.1013 - | assoc2str (NasNap _) = "NasNap"
146.1014 - | assoc2str (NasApp _) = "NasApp";
146.1015 -
146.1016 -
146.1017 -datatype asap = (*arg. of assy _only_ for distinction w.r.t. Or*)
146.1018 - Aundef (*undefined: set only by (topmost) Or*)
146.1019 -| AssOnly (*do not execute appl stacs - there could be an associated
146.1020 - in parallel Or-branch*)
146.1021 -| AssGen; (*no Ass(Weak) found within Or, thus
146.1022 - search for _applicable_ stacs, execute and generate pt*)
146.1023 -(*this constructions doesnt allow arbitrary nesting of Or !!!*)
146.1024 -
146.1025 -
146.1026 -(*assy, ass_up, astep_up scanning for locate_gen at stactic in a script.
146.1027 - search is clearly separated into (1)-(2):
146.1028 - (1) assy is recursive descent;
146.1029 - (2) ass_up resumes interpretation at a location somewhere in the script;
146.1030 - astep_up does only get to the parentnode of the scriptexpr.
146.1031 - consequence:
146.1032 - * call of (2) means _always_ that in this branch below
146.1033 - there was an appl.stac (Repeat, Or e1, ...)
146.1034 -*)
146.1035 -fun assy ya (is as (E,l,a,v,S,b),ss)
146.1036 - (Const ("Let",_) $ e $ (Abs (id,T,body))) =
146.1037 -(* val (ya, (is as (E,l,a,v,S,b),ss),Const ("Let",_) $ e $ (Abs (id,T,body))) =
146.1038 - (*1*)(((ts,d),Aundef), ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]), body);
146.1039 - *)
146.1040 - ((*writeln("### assy Let$e$Abs: is=");
146.1041 - writeln(istate2str (ScrState is));*)
146.1042 - case assy ya ((E , l@[L,R], a,v,S,b),ss) e of
146.1043 - NasApp ((E',l,a,v,S,bb),ss) =>
146.1044 - let val id' = mk_Free (id, T);
146.1045 - val E' = upd_env E' (id', v);
146.1046 - (*val _=writeln("### assy Let -> NasApp");*)
146.1047 - in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
146.1048 - | NasNap (v,E) =>
146.1049 - let val id' = mk_Free (id, T);
146.1050 - val E' = upd_env E (id', v);
146.1051 - (*val _=writeln("### assy Let -> NasNap");*)
146.1052 - in assy ya ((E', l@[R,D], a,v,S,b),ss) body end
146.1053 - | ay => ay)
146.1054 -
146.1055 - | assy (ya as (((thy,srls),_),_)) ((E,l,_,v,S,b),ss)
146.1056 - (Const ("Script.While",_) $ c $ e $ a) =
146.1057 - ((*writeln("### assy While $ c $ e $ a, upd_env= "^
146.1058 - (subst2str (upd_env E (a,v))));*)
146.1059 - if eval_true_ thy srls (subst_atomic (upd_env E (a,v)) c)
146.1060 - then assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e
146.1061 - else NasNap (v, E))
146.1062 -
146.1063 - | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
146.1064 - (Const ("Script.While",_) $ c $ e) =
146.1065 - ((*writeln("### assy While, l= "^(loc_2str l));*)
146.1066 - if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
146.1067 - then assy ya ((E, l@[R], a,v,S,b),ss) e
146.1068 - else NasNap (v, E))
146.1069 -
146.1070 - | assy (ya as (((thy,srls),_),_)) ((E,l,a,v,S,b),ss)
146.1071 - (Const ("If",_) $ c $ e1 $ e2) =
146.1072 - (if eval_true_ thy srls (subst_atomic (upd_env_opt E (a,v)) c)
146.1073 - then assy ya ((E, l@[L,R], a,v,S,b),ss) e1
146.1074 - else assy ya ((E, l@[ R], a,v,S,b),ss) e2)
146.1075 -
146.1076 - | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Try",_) $ e $ a) =
146.1077 - ((*writeln("### assy Try $ e $ a, l= "^(loc_2str l));*)
146.1078 - case assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e of
146.1079 - ay => ay)
146.1080 -
146.1081 - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Try",_) $ e) =
146.1082 - ((*writeln("### assy Try $ e, l= "^(loc_2str l));*)
146.1083 - case assy ya ((E, l@[R], a,v,S,b),ss) e of
146.1084 - ay => ay)
146.1085 -(* val (ya, ((E,l,_,v,S,b),ss), (Const ("Script.Seq",_) $e1 $ e2 $ a)) =
146.1086 - (*2*)(ya, ((E , l@[L,R], a,v,S,b),ss), e);
146.1087 - *)
146.1088 - | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2 $ a) =
146.1089 - ((*writeln("### assy Seq $e1 $ e2 $ a, E= "^(subst2str E));*)
146.1090 - case assy ya ((E, l@[L,L,R], SOME a,v,S,b),ss) e1 of
146.1091 - NasNap (v, E) => assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2
146.1092 - | NasApp ((E,_,_,v,_,_),ss) =>
146.1093 - assy ya ((E, l@[L,R], SOME a,v,S,b),ss) e2
146.1094 - | ay => ay)
146.1095 -
146.1096 - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Seq",_) $e1 $ e2) =
146.1097 - (case assy ya ((E, l@[L,R], a,v,S,b),ss) e1 of
146.1098 - NasNap (v, E) => assy ya ((E, l@[R], a,v,S,b),ss) e2
146.1099 - | NasApp ((E,_,_,v,_,_),ss) =>
146.1100 - assy ya ((E, l@[R], a,v,S,b),ss) e2
146.1101 - | ay => ay)
146.1102 -
146.1103 - | assy ya ((E,l,_,v,S,b),ss) (Const ("Script.Repeat",_) $ e $ a) =
146.1104 - assy ya ((E,(l@[L,R]),SOME a,v,S,b),ss) e
146.1105 -
146.1106 - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Repeat",_) $ e) =
146.1107 - assy ya ((E,(l@[R]),a,v,S,b),ss) e
146.1108 -
146.1109 -(*15.6.02: ass,app Or nochmals "uberlegen FIXXXME*)
146.1110 - | assy (y, Aundef) ((E,l,_,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2 $ a) =
146.1111 - (case assy (y, AssOnly) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of
146.1112 - NasNap (v, E) =>
146.1113 - (case assy (y, AssOnly) ((E,(l@[L,R]),SOME a,v,S,b),ss) e2 of
146.1114 - NasNap (v, E) =>
146.1115 - (case assy (y, AssGen) ((E,(l@[L,L,R]),SOME a,v,S,b),ss) e1 of
146.1116 - NasNap (v, E) =>
146.1117 - assy (y, AssGen) ((E, (l@[L,R]), SOME a,v,S,b),ss) e2
146.1118 - | ay => ay)
146.1119 - | ay =>(ay))
146.1120 - | NasApp _ => raise error ("assy: FIXXXME ///must not return NasApp///")
146.1121 - | ay => (ay))
146.1122 -
146.1123 - | assy ya ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $e1 $ e2) =
146.1124 - (case assy ya ((E,(l@[L,R]),a,v,S,b),ss) e1 of
146.1125 - NasNap (v, E) =>
146.1126 - assy ya ((E,(l@[R]),a,v,S,b),ss) e2
146.1127 - | ay => (ay))
146.1128 -(* val ((m,_,pt,(p,p_),c)::ss) = [(m,EmptyMout,pt,p,[])];
146.1129 - val t = (term_of o the o (parse Isac.thy)) "Rewrite rmult_1 False";
146.1130 -
146.1131 - val (ap,(p,p_),c,ss) = (Aundef,p,[],[]);
146.1132 - assy (((thy',srls),d),ap) ((E,l,a,v,S,b), (m,EmptyMout,pt,(p,p_),c)::ss) t;
146.1133 -val ((((thy',sr),d),ap), (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss), t) =
146.1134 - ();
146.1135 - *)
146.1136 -
146.1137 - | assy (((thy',sr),d),ap) (is as (E,l,a,v,S,b), (m,_,pt,(p,p_),c)::ss) t =
146.1138 - ((*writeln("### assy, m = "^tac_2str m);
146.1139 - writeln("### assy, (p,p_) = "^pos'2str (p,p_));
146.1140 - writeln("### assy, is= ");
146.1141 - writeln(istate2str (ScrState is));*)
146.1142 - case handle_leaf "locate" thy' sr E a v t of
146.1143 - (a', Expr s) =>
146.1144 - ((*writeln("### assy: listexpr t= "^(term2str t));
146.1145 - writeln("### assy, E= "^(env2str E));
146.1146 - writeln("### assy, eval(..)= "^(term2str
146.1147 - (eval_listexpr_ (assoc_thy thy') sr
146.1148 - (subst_atomic (upd_env_opt E (a',v)) t))));*)
146.1149 - NasNap (eval_listexpr_ (assoc_thy thy') sr
146.1150 - (subst_atomic (upd_env_opt E (a',v)) t), E))
146.1151 - (* val (_,STac stac) = subst_stacexpr E a v t;
146.1152 - *)
146.1153 - | (a', STac stac) =>
146.1154 - let (*val _=writeln("### assy, stac = "^term2str stac);*)
146.1155 - val p' = case p_ of Frm => p | Res => lev_on p
146.1156 - | _ => raise error ("assy: call by "^
146.1157 - (pos'2str (p,p_)));
146.1158 - in case assod pt d m stac of
146.1159 - Ass (m,v') =>
146.1160 - let (*val _=writeln("### assy: Ass ("^tac_2str m^", "^
146.1161 - term2str v'^")");*)
146.1162 - val (p'',c',f',pt') = generate1 (assoc_thy thy') m
146.1163 - (ScrState (E,l,a',v',S,true)) (p',p_) pt;
146.1164 - in Assoc ((E,l,a',v',S,true), (m,f',pt',p'',c @ c')::ss) end
146.1165 - | AssWeak (m,v') =>
146.1166 - let (*val _=writeln("### assy: Ass Weak("^tac_2str m^", "^
146.1167 - term2str v'^")");*)
146.1168 - val (p'',c',f',pt') = generate1 (assoc_thy thy') m
146.1169 - (ScrState (E,l,a',v',S,false)) (p',p_) pt;
146.1170 - in Assoc ((E,l,a',v',S,false), (m,f',pt',p'',c @ c')::ss) end
146.1171 - | NotAss =>
146.1172 - ((*writeln("### assy, NotAss");*)
146.1173 - case ap of (*switch for Or: 1st AssOnly, 2nd AssGen*)
146.1174 - AssOnly => (NasNap (v, E))
146.1175 - | gen => (case applicable_in (p,p_) pt
146.1176 - (stac2tac pt (assoc_thy thy') stac) of
146.1177 - Appl m' =>
146.1178 - let val is = (E,l,a',tac_2res m',S,false(*FIXXXME*))
146.1179 - val (p'',c',f',pt') =
146.1180 - generate1 (assoc_thy thy') m' (ScrState is) (p',p_) pt;
146.1181 - in NasApp (is,(m,f',pt',p'',c @ c')::ss) end
146.1182 - | Notappl _ =>
146.1183 - (NasNap (v, E))
146.1184 - )
146.1185 - )
146.1186 - end);
146.1187 -(* (astep_up ((thy',scr,d),NasApp_) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])])) handle e => print_exn_G e;
146.1188 - *)
146.1189 -
146.1190 -
146.1191 -(* val (ys as (y,s,Script sc,d),(is as (E,l,a,v,S,b),ss),Const ("Let",_) $ _) =
146.1192 - (ys, ((E,up,a,v,S,b),ss), go up sc);
146.1193 - *)
146.1194 -fun ass_up (ys as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss)
146.1195 - (Const ("Let",_) $ _) =
146.1196 - let (*val _= writeln("### ass_up1 Let$e: is=")
146.1197 - val _= writeln(istate2str (ScrState is))*)
146.1198 - val l = drop_last l; (*comes from e, goes to Abs*)
146.1199 - val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go l sc;
146.1200 - val i = mk_Free (i, T);
146.1201 - val E = upd_env E (i, v);
146.1202 - (*val _=writeln("### ass_up2 Let$e: E="^(subst2str E));*)
146.1203 - in case assy (((y,s),d),Aundef) ((E, l@[R,D], a,v,S,b),ss) body of
146.1204 - Assoc iss => Assoc iss
146.1205 - | NasApp iss => astep_up ys iss
146.1206 - | NasNap (v, E) => astep_up ys ((E,l,a,v,S,b),ss) end
146.1207 -
146.1208 - | ass_up ys (iss as (is,_)) (Abs (_,_,_)) =
146.1209 - ((*writeln("### ass_up Abs: is=");
146.1210 - writeln(istate2str (ScrState is));*)
146.1211 - astep_up ys iss) (*TODO 5.9.00: env ?*)
146.1212 -
146.1213 - | ass_up ys (iss as (is,_)) (Const ("Let",_) $ e $ (Abs (i,T,b)))=
146.1214 - ((*writeln("### ass_up Let $ e $ Abs: is=");
146.1215 - writeln(istate2str (ScrState is));*)
146.1216 - astep_up ys iss) (*TODO 5.9.00: env ?*)
146.1217 -
146.1218 - (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _ $ _)) =
146.1219 - (ys, ((E,up,a,v,S,b),ss), (go up sc));
146.1220 - *)
146.1221 - | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _ $ _) =
146.1222 - astep_up ysa iss (*all has been done in (*2*) below*)
146.1223 -
146.1224 - | ass_up ysa iss (Const ("Script.Seq",_) $ _ $ _) =
146.1225 - (* val (ysa, iss, (Const ("Script.Seq",_) $ _ $ _)) =
146.1226 - (ys, ((E,up,a,v,S,b),ss), (go up sc));
146.1227 - *)
146.1228 - astep_up ysa iss (*2*: comes from e2*)
146.1229 -
146.1230 - | ass_up (ysa as (y,s,Script sc,d)) (is as (E,l,a,v,S,b),ss)
146.1231 - (Const ("Script.Seq",_) $ _ ) = (*2*: comes from e1, goes to e2*)
146.1232 - (* val ((ysa as (y,s,Script sc,d)), (is as (E,l,a,v,S,b),ss),
146.1233 - (Const ("Script.Seq",_) $ _ )) =
146.1234 - (ys, ((E,up,a,v,S,b),ss), (go up sc));
146.1235 - *)
146.1236 - let val up = drop_last l;
146.1237 - val Const ("Script.Seq",_) $ _ $ e2 = go up sc
146.1238 - (*val _= writeln("### ass_up Seq$e: is=")
146.1239 - val _= writeln(istate2str (ScrState is))*)
146.1240 - in case assy (((y,s),d),Aundef) ((E, up@[R], a,v,S,b),ss) e2 of
146.1241 - NasNap (v,E) => astep_up ysa ((E,up,a,v,S,b),ss)
146.1242 - | NasApp iss => astep_up ysa iss
146.1243 - | ay => ay end
146.1244 -
146.1245 - (* val (ysa, iss, (Const ("Script.Try",_) $ e $ _)) =
146.1246 - (ys, ((E,up,a,v,S,b),ss), (go up sc));
146.1247 - *)
146.1248 - | ass_up ysa iss (Const ("Script.Try",_) $ e $ _) =
146.1249 - astep_up ysa iss
146.1250 -
146.1251 - (* val (ysa, iss, (Const ("Script.Try",_) $ e)) =
146.1252 - (ys, ((E,up,a,v,S,b),ss), (go up sc));
146.1253 - *)
146.1254 - | ass_up ysa iss (Const ("Script.Try",_) $ e) =
146.1255 - ((*writeln("### ass_up Try $ e");*)
146.1256 - astep_up ysa iss)
146.1257 -
146.1258 - | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
146.1259 - (*(Const ("Script.While",_) $ c $ e $ a) = WN050930 blind fix*)
146.1260 - (t as Const ("Script.While",_) $ c $ e $ a) =
146.1261 - ((*writeln("### ass_up: While c= "^
146.1262 - (term2str (subst_atomic (upd_env E (a,v)) c)));*)
146.1263 - if eval_true_ y s (subst_atomic (upd_env E (a,v)) c)
146.1264 - then (case assy (((y,s),d),Aundef) ((E, l@[L,R], SOME a,v,S,b),ss) e of
146.1265 - NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss)
146.1266 - | NasApp ((E',l,a,v,S,b),ss) =>
146.1267 - ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*)
146.1268 - | ay => ay)
146.1269 - else astep_up ys ((E,l, SOME a,v,S,b),ss)
146.1270 - )
146.1271 -
146.1272 - | ass_up (ys as (y,s,_,d)) ((E,l,a,v,S,b),ss)
146.1273 - (*(Const ("Script.While",_) $ c $ e) = WN050930 blind fix*)
146.1274 - (t as Const ("Script.While",_) $ c $ e) =
146.1275 - if eval_true_ y s (subst_atomic (upd_env_opt E (a,v)) c)
146.1276 - then (case assy (((y,s),d),Aundef) ((E, l@[R], a,v,S,b),ss) e of
146.1277 - NasNap (v,E') => astep_up ys ((E',l, a,v,S,b),ss)
146.1278 - | NasApp ((E',l,a,v,S,b),ss) =>
146.1279 - ass_up ys ((E',l,a,v,S,b),ss) t (*WN050930 't' was not assigned*)
146.1280 - | ay => ay)
146.1281 - else astep_up ys ((E,l, a,v,S,b),ss)
146.1282 -
146.1283 - | ass_up y iss (Const ("If",_) $ _ $ _ $ _) = astep_up y iss
146.1284 -
146.1285 - | ass_up (ys as (y,s,_,d)) ((E,l,_,v,S,b),ss)
146.1286 - (t as Const ("Script.Repeat",_) $ e $ a) =
146.1287 - (case assy (((y,s),d), Aundef) ((E, (l@[L,R]), SOME a,v,S,b),ss) e of
146.1288 - NasNap (v,E') => astep_up ys ((E',l, SOME a,v,S,b),ss)
146.1289 - | NasApp ((E',l,a,v,S,b),ss) =>
146.1290 - ass_up ys ((E',l,a,v,S,b),ss) t
146.1291 - | ay => ay)
146.1292 -
146.1293 - | ass_up (ys as (y,s,_,d)) (is as ((E,l,a,v,S,b),ss))
146.1294 - (t as Const ("Script.Repeat",_) $ e) =
146.1295 - (case assy (((y,s),d), Aundef) ((E, (l@[R]), a,v,S,b),ss) e of
146.1296 - NasNap (v', E') => astep_up ys ((E',l,a,v',S,b),ss)
146.1297 - | NasApp ((E',l,a,v',S,bb),ss) =>
146.1298 - ass_up ys ((E',l,a,v',S,b),ss) t
146.1299 - | ay => ay)
146.1300 -
146.1301 - | ass_up y iss (Const ("Script.Or",_) $ _ $ _ $ _) = astep_up y iss
146.1302 -
146.1303 - | ass_up y iss (Const ("Script.Or",_) $ _ $ _) = astep_up y iss
146.1304 -
146.1305 - | ass_up y ((E,l,a,v,S,b),ss) (Const ("Script.Or",_) $ _ ) =
146.1306 - astep_up y ((E, (drop_last l), a,v,S,b),ss)
146.1307 -
146.1308 - | ass_up y iss t =
146.1309 - raise error ("ass_up not impl for t= "^(term2str t))
146.1310 -(* 9.6.03
146.1311 - val (ys as (_,_,Script sc,_), ss) =
146.1312 - ((thy',srls,scr,d), [(m,EmptyMout,pt,p,[])]:step list);
146.1313 - astep_up ys ((E,l,a,v,S,b),ss);
146.1314 - val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) =
146.1315 - (ysa, iss);
146.1316 - val ((ys as (_,_,Script sc,_)), ((E,l,a,v,S,b),ss)) =
146.1317 - ((thy',srls,scr,d), ((E,l,a,v,S,b), [(m,EmptyMout,pt,p,[])]));
146.1318 - *)
146.1319 -and astep_up (ys as (_,_,Script sc,_)) ((E,l,a,v,S,b),ss) =
146.1320 - if 1 < length l
146.1321 - then
146.1322 - let val up = drop_last l;
146.1323 - (*val _= writeln("### astep_up: E= "^env2str E);*)
146.1324 - in ass_up ys ((E,up,a,v,S,b),ss) (go up sc) end
146.1325 - else (NasNap (v, E))
146.1326 -;
146.1327 -
146.1328 -
146.1329 -
146.1330 -
146.1331 -
146.1332 -(* use"ME/script.sml";
146.1333 - use"script.sml";
146.1334 - term2str (go up sc);
146.1335 -
146.1336 - *)
146.1337 -
146.1338 -(*check if there are tacs for rewriting only*)
146.1339 -fun rew_only ([]:step list) = true
146.1340 - | rew_only (((Rewrite' _ ,_,_,_,_))::ss) = rew_only ss
146.1341 - | rew_only (((Rewrite_Inst' _ ,_,_,_,_))::ss) = rew_only ss
146.1342 - | rew_only (((Rewrite_Set' _ ,_,_,_,_))::ss) = rew_only ss
146.1343 - | rew_only (((Rewrite_Set_Inst' _ ,_,_,_,_))::ss) = rew_only ss
146.1344 - | rew_only (((Calculate' _ ,_,_,_,_))::ss) = rew_only ss
146.1345 - | rew_only (((Begin_Trans' _ ,_,_,_,_))::ss) = rew_only ss
146.1346 - | rew_only (((End_Trans' _ ,_,_,_,_))::ss) = rew_only ss
146.1347 - | rew_only _ = false;
146.1348 -
146.1349 -
146.1350 -datatype locate =
146.1351 - Steps of istate (*producing hd of step list (which was latest)
146.1352 - for next_tac, for reporting Safe|Unsafe to DG*)
146.1353 - * step (*(scrstate producing this step is in ptree !)*)
146.1354 - list (*locate_gen may produce intermediate steps*)
146.1355 -| NotLocatable; (*no (m Ass m') or (m AssWeak m') found*)
146.1356 -
146.1357 -
146.1358 -
146.1359 -(* locate_gen tries to locate an input tac m in the script.
146.1360 - pursuing this goal the script is executed until an (m' equiv m) is found,
146.1361 - or the end of the script
146.1362 -args
146.1363 - m : input by the user, already checked by applicable_in,
146.1364 - (to be searched within Or; and _not_ an m doing the step on ptree !)
146.1365 - p,pt: (incl ets) at the time of input
146.1366 - scr : the script
146.1367 - d : canonical simplifier for locating Take, Substitute, Subproblems etc.
146.1368 - ets : ets at the time of input
146.1369 - l : the location (in scr) of the stac which generated the current formula
146.1370 -returns
146.1371 - Steps: pt,p (incl. ets) with m done
146.1372 - pos' list of proofobjs cut (from generate)
146.1373 - safe: implied from last proofobj
146.1374 - ets:
146.1375 - ///ToDo : ets contains a list of tacs to be done before m can be done
146.1376 - NOT IMPL. -- "error: do other step before"
146.1377 - NotLocatable: thus generate_hard
146.1378 -*)
146.1379 -(* val (Rewrite'(_,ro,er,pa,(id,str),f,_), p, Rfuns {locate_rule=lo,...},
146.1380 - RrlsState (_,f'',rss,rts)) = (m, (p,p_), sc, is);
146.1381 - *)
146.1382 -fun locate_gen (thy',_) (Rewrite'(_,ro,er,pa,(id,str),f,_)) (pt,p)
146.1383 - (Rfuns {locate_rule=lo,...}, d) (RrlsState (_,f'',rss,rts)) =
146.1384 - (case lo rss f (Thm (id, mk_thm (assoc_thy thy') str)) of
146.1385 - [] => NotLocatable
146.1386 - | rts' =>
146.1387 - Steps (rts2steps [] ((pt,p),(f,f'',rss,rts),(thy',ro,er,pa)) rts'))
146.1388 -(* val p as(p',p_)=(p,p_);val scr as Script(h $ body)=sc;val (E,l,a,v,S,bb)=is;
146.1389 - locate_gen (thy':theory') (m:tac_) ((pt,p):ptree * pos')
146.1390 - (scr,d) (E,l,a,v,S,bb);
146.1391 - 9.6.03
146.1392 - val ts = (thy',srls);
146.1393 - val p = (p,p_);
146.1394 - val (scr as Script (h $ body)) = (sc);
146.1395 - val ScrState (E,l,a,v,S,b) = (is);
146.1396 -
146.1397 - val (ts as (thy',srls), m, (pt,p),
146.1398 - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
146.1399 - ((thy',srls), m, (pt,(p,p_)), (sc,d), is);
146.1400 - locate_gen (thy',srls) m (pt,p) (Script(h $ body),d)(ScrState(E,l,a,v,S,b));
146.1401 -
146.1402 - val (ts as (thy',srls), m, (pt,p),
146.1403 - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
146.1404 - ((thy',srls), m', (pt,(lev_on p,Frm)), (sc,d), is');
146.1405 -
146.1406 - val (ts as (thy',srls), m, (pt,p),
146.1407 - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
146.1408 - ((thy',srls), m', (pt,(p, Res)), (sc,d), is');
146.1409 -
146.1410 - val (ts as (thy',srls), m, (pt,p),
146.1411 - (scr as Script (h $ body),d), (ScrState (E,l,a,v,S,b))) =
146.1412 - ((thy',srls), m, (pt,(p,p_)), (sc,d), is);
146.1413 - *)
146.1414 - | locate_gen (ts as (thy',srls)) (m:tac_) ((pt,p):ptree * pos')
146.1415 - (scr as Script (h $ body),d) (ScrState (E,l,a,v,S,b)) =
146.1416 - let (*val _= writeln("### locate_gen-----------------: is=");
146.1417 - val _= writeln( istate2str (ScrState (E,l,a,v,S,b)));
146.1418 - val _= writeln("### locate_gen: l= "^loc_2str l^", p= "^pos'2str p)*)
146.1419 - val thy = assoc_thy thy';
146.1420 - in case if l=[] orelse ((*init.in solve..Apply_Method...*)
146.1421 - (last_elem o fst) p = 0 andalso snd p = Res)
146.1422 - then (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),
146.1423 - [(m,EmptyMout,pt,p,[])]) body)
146.1424 -(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =
146.1425 - (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),[(m,EmptyMout,pt,p,[])]));
146.1426 - (assy ((ts,d),Aundef) ((E,[R],a,v,S,b),[(m,EmptyMout,pt,p,[])]) body);
146.1427 - *)
146.1428 - else (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),
146.1429 - [(m,EmptyMout,pt,p,[])]) ) of
146.1430 - Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =>
146.1431 -(* val Assoc (iss as (is as (_,_,_,_,_,bb), ss as ((m',f',pt',p',c')::_))) =
146.1432 - (astep_up (thy',srls,scr,d) ((E,l,a,v,S,b),
146.1433 - [(m,EmptyMout,pt,p,[])]) );
146.1434 - *)
146.1435 - ((*writeln("### locate_gen Assoc: p'="^(pos'2str p'));*)
146.1436 - if bb then Steps (ScrState is, ss)
146.1437 - else if rew_only ss (*andalso 'not bb'= associated weakly*)
146.1438 - then let val (po,p_) = p
146.1439 - val po' = case p_ of Frm => po | Res => lev_on po
146.1440 - (*WN.12.03: noticed, that pos is also updated in assy !?!
146.1441 - instead take p' from Assoc ?????????????????????????????*)
146.1442 - val (p'',c'',f'',pt'') =
146.1443 - generate1 thy m (ScrState is) (po',p_) pt;
146.1444 - (*val _=writeln("### locate_gen, aft g1: p''="^(pos'2str p''));*)
146.1445 - (*drop the intermediate steps !*)
146.1446 - in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
146.1447 - else Steps (ScrState is, ss))
146.1448 -
146.1449 - | NasApp _ (*[((E,l,a,v,S,bb),(m',f',pt',p',c'))] =>
146.1450 - raise error ("locate_gen: should not have got NasApp, ets =")*)
146.1451 - => NotLocatable
146.1452 - | NasNap (_,_) =>
146.1453 - if l=[] then NotLocatable
146.1454 - else (*scan from begin of script for rew_only*)
146.1455 - (case assy ((ts,d),Aundef) ((E,[R],a,v,Unsafe,b),
146.1456 - [(m,EmptyMout,pt,p,[])]) body of
146.1457 - Assoc (iss as (is as (_,_,_,_,_,bb),
146.1458 - ss as ((m',f',pt',p',c')::_))) =>
146.1459 - ((*writeln"4### locate_gen Assoc after Fini";*)
146.1460 - if rew_only ss
146.1461 - then let val(p'',c'',f'',pt'') =
146.1462 - generate1 thy m (ScrState is) p' pt;
146.1463 - (*drop the intermediate steps !*)
146.1464 - in Steps (ScrState is, [(m, f'',pt'',p'',c'')]) end
146.1465 - else NotLocatable)
146.1466 - | _ => ((*writeln ("#### locate_gen: after Fini");*)
146.1467 - NotLocatable))
146.1468 - end
146.1469 - | locate_gen _ m _ (sc,_) is =
146.1470 - raise error ("locate_gen: wrong arguments,\n tac= "^(tac_2str m)^
146.1471 - ",\n scr= "^(scr2str sc)^",\n istate= "^(istate2str is));
146.1472 -
146.1473 -
146.1474 -
146.1475 -(** find the next stactic in a script **)
146.1476 -
146.1477 -datatype appy = (*ExprVal in the sense of denotational semantics*)
146.1478 - Appy of (*applicable stac found, search stalled*)
146.1479 - tac_ * (*tac_ associated (fun assod) with stac*)
146.1480 - scrstate (*after determination of stac WN.18.8.03*)
146.1481 - | Napp of (*stac found was not applicable;
146.1482 - this mode may become Skip in Repeat, Try and Or*)
146.1483 - env (*stack*) (*popped while nxt_up*)
146.1484 - | Skip of (*for restart after Appy, for leaving iterations,
146.1485 - for passing the value of scriptexpressions,
146.1486 - and for finishing the script successfully*)
146.1487 - term * env (*stack*);
146.1488 -
146.1489 -(*appy, nxt_up, nstep_up scanning for next_tac.
146.1490 - search is clearly separated into (1)-(2):
146.1491 - (1) appy is recursive descent;
146.1492 - (2) nxt_up resumes interpretation at a location somewhere in the script;
146.1493 - nstep_up does only get to the parentnode of the scriptexpr.
146.1494 - consequence:
146.1495 - * call of (2) means _always_ that in this branch below
146.1496 - there was an applicable stac (Repeat, Or e1, ...)
146.1497 -*)
146.1498 -
146.1499 -
146.1500 -datatype appy_ = (*as argument in nxt_up, nstep_up, from appy*)
146.1501 - (* Appy is only (final) returnvalue, not argument during search
146.1502 - |*) Napp_ (*ev. detects 'script is not appropriate for this example'*)
146.1503 - | Skip_; (*detects 'script successfully finished'
146.1504 - also used as init-value for resuming; this works,
146.1505 - because 'nxt_up Or e1' treats as Appy*)
146.1506 -
146.1507 -fun appy thy ptp E l
146.1508 - (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
146.1509 -(* val (thy, ptp, E, l, t as Const ("Let",_) $ e $ (Abs (i,T,b)),a, v)=
146.1510 - (thy, ptp, E, up@[R,D], body, a, v);
146.1511 - appy thy ptp E l t a v;
146.1512 - *)
146.1513 - ((*writeln("### appy Let$e$Abs: is=");
146.1514 - writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
146.1515 - case appy thy ptp E (l@[L,R]) e a v of
146.1516 - Skip (res, E) =>
146.1517 - let (*val _= writeln("### appy Let "^(term2str t));
146.1518 - val _= writeln("### appy Let: Skip res ="^(term2str res));*)
146.1519 - (*val (i',b') = variant_abs (i,T,b); WN.15.5.03
146.1520 - val i = mk_Free(i',T); WN.15.5.03 *)
146.1521 - val E' = upd_env E (Free (i,T), res);
146.1522 - in appy thy ptp E' (l@[R,D]) b a v end
146.1523 - | ay => ay)
146.1524 -
146.1525 - | appy (thy as (th,sr)) ptp E l
146.1526 - (t as Const ("Script.While"(*1*),_) $ c $ e $ a) _ v = (*ohne n. 28.9.00*)
146.1527 - ((*writeln("### appy While $ c $ e $ a, upd_env= "^
146.1528 - (subst2str (upd_env E (a,v))));*)
146.1529 - if eval_true_ th sr (subst_atomic (upd_env E (a,v)) c)
146.1530 - then appy thy ptp E (l@[L,R]) e (SOME a) v
146.1531 - else Skip (v, E))
146.1532 -
146.1533 - | appy (thy as (th,sr)) ptp E l
146.1534 - (t as Const ("Script.While"(*2*),_) $ c $ e) a v =(*ohne nachdenken 28.9.00*)
146.1535 - ((*writeln("### appy While $ c $ e, upd_env= "^
146.1536 - (subst2str (upd_env_opt E (a,v))));*)
146.1537 - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
146.1538 - then appy thy ptp E (l@[R]) e a v
146.1539 - else Skip (v, E))
146.1540 -
146.1541 - | appy (thy as (th,sr)) ptp E l (t as Const ("If",_) $ c $ e1 $ e2) a v =
146.1542 - ((*writeln("### appy If: t= "^(term2str t));
146.1543 - writeln("### appy If: c= "^(term2str(subst_atomic(upd_env_opt E(a,v))c)));
146.1544 - writeln("### appy If: thy= "^(fst thy));*)
146.1545 - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
146.1546 - then ((*writeln("### appy If: true");*)appy thy ptp E (l@[L,R]) e1 a v)
146.1547 - else ((*writeln("### appy If: false");*)appy thy ptp E (l@[ R]) e2 a v))
146.1548 -(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e $ a), _, v) =
146.1549 - (thy, ptp, E, (l@[R]), e, a, v);
146.1550 - *)
146.1551 - | appy thy ptp E (*env*) l
146.1552 - (Const ("Script.Repeat"(*1*),_) $ e $ a) _ v =
146.1553 - ((*writeln("### appy Repeat a: ");*)
146.1554 - appy thy ptp E (*env*) (l@[L,R]) e (SOME a) v)
146.1555 -(* val (thy, ptp, E, l, (Const ("Script.Repeat",_) $ e), _, v) =
146.1556 - (thy, ptp, E, (l@[R]), e, a, v);
146.1557 - *)
146.1558 - | appy thy ptp E (*env*) l
146.1559 - (Const ("Script.Repeat"(*2*),_) $ e) a v =
146.1560 - ((*writeln("3### appy Repeat: a= "^
146.1561 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) a));*)
146.1562 - appy thy ptp E (*env*) (l@[R]) e a v)
146.1563 -(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e $ a), _, v)=
146.1564 - (thy, ptp, E, (l@[R]), e2, a, v);
146.1565 - *)
146.1566 - | appy thy ptp E l
146.1567 - (t as Const ("Script.Try",_) $ e $ a) _ v =
146.1568 - (case appy thy ptp E (l@[L,R]) e (SOME a) v of
146.1569 - Napp E => ((*writeln("### appy Try "^
146.1570 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
146.1571 - Skip (v, E))
146.1572 - | ay => ay)
146.1573 -(* val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)=
146.1574 - (thy, ptp, E, (l@[R]), e2, a, v);
146.1575 - val (thy, ptp, E, l, (t as Const ("Script.Try",_) $ e), _, v)=
146.1576 - (thy, ptp, E, (l@[L,R]), e1, a, v);
146.1577 - *)
146.1578 - | appy thy ptp E l
146.1579 - (t as Const ("Script.Try",_) $ e) a v =
146.1580 - (case appy thy ptp E (l@[R]) e a v of
146.1581 - Napp E => ((*writeln("### appy Try "^
146.1582 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
146.1583 - Skip (v, E))
146.1584 - | ay => ay)
146.1585 -
146.1586 -
146.1587 - | appy thy ptp E l
146.1588 - (Const ("Script.Or"(*1*),_) $e1 $ e2 $ a) _ v =
146.1589 - (case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of
146.1590 - Appy lme => Appy lme
146.1591 - | _ => appy thy ptp E (*env*) (l@[L,R]) e2 (SOME a) v)
146.1592 -
146.1593 - | appy thy ptp E l
146.1594 - (Const ("Script.Or"(*2*),_) $e1 $ e2) a v =
146.1595 - (case appy thy ptp E (l@[L,R]) e1 a v of
146.1596 - Appy lme => Appy lme
146.1597 - | _ => appy thy ptp E (l@[R]) e2 a v)
146.1598 -
146.1599 -(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)=
146.1600 - (thy, ptp, E,(up@[R]),e2, a, v);
146.1601 - val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2 $ a), _, v)=
146.1602 - (thy, ptp, E,(up@[R,D]),body, a, v);
146.1603 - *)
146.1604 - | appy thy ptp E l
146.1605 - (Const ("Script.Seq"(*1*),_) $ e1 $ e2 $ a) _ v =
146.1606 - ((*writeln("### appy Seq $ e1 $ e2 $ a, upd_env= "^
146.1607 - (subst2str (upd_env E (a,v))));*)
146.1608 - case appy thy ptp E (l@[L,L,R]) e1 (SOME a) v of
146.1609 - Skip (v,E) => appy thy ptp E (l@[L,R]) e2 (SOME a) v
146.1610 - | ay => ay)
146.1611 -
146.1612 -(* val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
146.1613 - (thy, ptp, E,(up@[R]),e2, a, v);
146.1614 - val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
146.1615 - (thy, ptp, E,(l@[R]), e2, a, v);
146.1616 - val (thy, ptp, E, l, (Const ("Script.Seq",_) $ e1 $ e2), _, v)=
146.1617 - (thy, ptp, E,(up@[R,D]),body, a, v);
146.1618 - *)
146.1619 - | appy thy ptp E l
146.1620 - (Const ("Script.Seq",_) $ e1 $ e2) a v =
146.1621 - (case appy thy ptp E (l@[L,R]) e1 a v of
146.1622 - Skip (v,E) => appy thy ptp E (l@[R]) e2 a v
146.1623 - | ay => ay)
146.1624 -
146.1625 - (*.a leaf has been found*)
146.1626 - | appy (thy as (th,sr)) (pt, p) E l t a v =
146.1627 -(* val (thy as (th,sr),(pt, p),E, l, t, a, v) =
146.1628 - (thy, ptp, E, up@[R,D], body, a, v);
146.1629 - val (thy as (th,sr),(pt, p),E, l, t, a, v) =
146.1630 - (thy, ptp, E, l@[L,R], e, a, v);
146.1631 - val (thy as (th,sr),(pt, p),E, l, t, a, v) =
146.1632 - (thy, ptp, E,(l@[R]), e, a, v);
146.1633 - *)
146.1634 - (case handle_leaf "next " th sr E a v t of
146.1635 -(* val (a', Expr s) = handle_leaf "next " th sr E a v t;
146.1636 - *)
146.1637 - (a', Expr s) => Skip (s, E)
146.1638 -(* val (a', STac stac) = handle_leaf "next " th sr E a v t;
146.1639 - *)
146.1640 - | (a', STac stac) =>
146.1641 - let
146.1642 - (*val _= writeln("### appy t, vor stac2tac_ is=");
146.1643 - val _= writeln(istate2str (ScrState (E,l,a',v,Sundef,false)));*)
146.1644 - val (m,m') = stac2tac_ pt (assoc_thy th) stac
146.1645 - in case m of
146.1646 - Subproblem _ => Appy (m', (E,l,a',tac_2res m',Sundef,false))
146.1647 - | _ => (case applicable_in p pt m of
146.1648 -(* val Appl m' = applicable_in p pt m;
146.1649 - *)
146.1650 - Appl m' =>
146.1651 - ((*writeln("### appy: Appy");*)
146.1652 - Appy (m', (E,l,a',tac_2res m',Sundef,false)))
146.1653 - | _ => ((*writeln("### appy: Napp");*)Napp E))
146.1654 - end);
146.1655 -
146.1656 -
146.1657 -(* val (scr as Script sc, l, t as Const ("Let",_) $ _) =
146.1658 - (Script sc, up, go up sc);
146.1659 - nxt_up thy ptp (Script sc) E l ay t a v;
146.1660 -
146.1661 - val (thy,ptp,scr as (Script sc),E,l, ay, t as Const ("Let",_) $ _, a, v)=
146.1662 - (thy,ptp,Script sc, E,up,ay, go up sc, a, v);
146.1663 - nxt_up thy ptp scr E l ay t a v;
146.1664 - *)
146.1665 -fun nxt_up thy ptp (scr as (Script sc)) E l ay
146.1666 - (t as Const ("Let",_) $ _) a v = (*comes from let=...*)
146.1667 - ((*writeln("### nxt_up1 Let$e: is=");
146.1668 - writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
146.1669 - if ay = Napp_
146.1670 - then nstep_up thy ptp scr E (drop_last l) Napp_ a v
146.1671 - else (*Skip_*)
146.1672 - let val up = drop_last l;
146.1673 - val (Const ("Let",_) $ e $ (Abs (i,T,body))) = go up sc;
146.1674 - val i = mk_Free (i, T);
146.1675 - val E = upd_env E (i, v);
146.1676 - (*val _= writeln("### nxt_up2 Let$e: is=");
146.1677 - val _= writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
146.1678 - in case appy thy ptp (E) (up@[R,D]) body a v of
146.1679 - Appy lre => Appy lre
146.1680 - | Napp E => nstep_up thy ptp scr E up Napp_ a v
146.1681 - | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end)
146.1682 -
146.1683 - | nxt_up thy ptp scr E l ay
146.1684 - (t as Abs (_,_,_)) a v =
146.1685 - ((*writeln("### nxt_up Abs: "^
146.1686 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
146.1687 - nstep_up thy ptp scr E (*enr*) l ay a v)
146.1688 -
146.1689 - | nxt_up thy ptp scr E l ay
146.1690 - (t as Const ("Let",_) $ e $ (Abs (i,T,b))) a v =
146.1691 - ((*writeln("### nxt_up Let$e$Abs: is=");
146.1692 - writeln(istate2str (ScrState (E,l,a,v,Sundef,false)));*)
146.1693 - (*writeln("### nxt_up Let e Abs: "^
146.1694 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
146.1695 - nstep_up thy ptp scr (*upd_env*) E (*a,v)*)
146.1696 - (*eno,upd_env env (iar,res),iar,res,saf*) l ay a v)
146.1697 -
146.1698 - (*no appy_: never causes Napp -> Helpless*)
146.1699 - | nxt_up (thy as (th,sr)) ptp scr E l _
146.1700 - (Const ("Script.While"(*1*),_) $ c $ e $ _) a v =
146.1701 - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
146.1702 - then case appy thy ptp E (l@[L,R]) e a v of
146.1703 - Appy lr => Appy lr
146.1704 - | Napp E => nstep_up thy ptp scr E l Skip_ a v
146.1705 - | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
146.1706 - else nstep_up thy ptp scr E l Skip_ a v
146.1707 -
146.1708 - (*no appy_: never causes Napp - Helpless*)
146.1709 - | nxt_up (thy as (th,sr)) ptp scr E l _
146.1710 - (Const ("Script.While"(*2*),_) $ c $ e) a v =
146.1711 - if eval_true_ th sr (subst_atomic (upd_env_opt E (a,v)) c)
146.1712 - then case appy thy ptp E (l@[R]) e a v of
146.1713 - Appy lr => Appy lr
146.1714 - | Napp E => nstep_up thy ptp scr E l Skip_ a v
146.1715 - | Skip (v,E) => nstep_up thy ptp scr E l Skip_ a v
146.1716 - else nstep_up thy ptp scr E l Skip_ a v
146.1717 -
146.1718 -(* val (scr, l) = (Script sc, up);
146.1719 - *)
146.1720 - | nxt_up thy ptp scr E l ay (Const ("If",_) $ _ $ _ $ _) a v =
146.1721 - nstep_up thy ptp scr E l ay a v
146.1722 -
146.1723 - | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*)
146.1724 - (Const ("Script.Repeat"(*1*),T) $ e $ _) a v =
146.1725 - (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[L,R]):loc_) e a v of
146.1726 - Appy lr => Appy lr
146.1727 - | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
146.1728 - nstep_up thy ptp scr E l Skip_ a v)
146.1729 - | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
146.1730 - (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
146.1731 - nstep_up thy ptp scr E l Skip_ a v))
146.1732 -
146.1733 - | nxt_up thy ptp scr E l _ (*no appy_: there was already a stac below*)
146.1734 - (Const ("Script.Repeat"(*2*),T) $ e) a v =
146.1735 - (case appy thy ptp (*upd_env*) E (*a,v)*) ((l@[R]):loc_) e a v of
146.1736 - Appy lr => Appy lr
146.1737 - | Napp E => ((*writeln("### nxt_up Repeat a: ");*)
146.1738 - nstep_up thy ptp scr E l Skip_ a v)
146.1739 - | Skip (v,E) => ((*writeln("### nxt_up Repeat: Skip res ="^
146.1740 - (Sign.string_of_term(sign_of (assoc_thy thy)) res'));*)
146.1741 - nstep_up thy ptp scr E l Skip_ a v))
146.1742 -(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e $ _), a, v) =
146.1743 - (thy, ptp, (Script sc),
146.1744 - E, up, ay,(go up sc), a, v);
146.1745 - *)
146.1746 - | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
146.1747 - (t as Const ("Script.Try",_) $ e $ _) a v =
146.1748 - ((*writeln("### nxt_up Try "^
146.1749 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
146.1750 - nstep_up thy ptp scr E l Skip_ a v )
146.1751 -(* val (thy, ptp, scr, E, l, _,(t as Const ("Script.Try",_) $ e), a, v) =
146.1752 - (thy, ptp, (Script sc),
146.1753 - E, up, ay,(go up sc), a, v);
146.1754 - *)
146.1755 - | nxt_up thy ptp scr E l _ (*makes Napp to Skip*)
146.1756 - (t as Const ("Script.Try"(*2*),_) $ e) a v =
146.1757 - ((*writeln("### nxt_up Try "^
146.1758 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t));*)
146.1759 - nstep_up thy ptp scr E l Skip_ a v)
146.1760 -
146.1761 -
146.1762 - | nxt_up thy ptp scr E l ay
146.1763 - (Const ("Script.Or",_) $ _ $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
146.1764 -
146.1765 - | nxt_up thy ptp scr E l ay
146.1766 - (Const ("Script.Or",_) $ _ $ _) a v = nstep_up thy ptp scr E l ay a v
146.1767 -
146.1768 - | nxt_up thy ptp scr E l ay
146.1769 - (Const ("Script.Or",_) $ _ ) a v =
146.1770 - nstep_up thy ptp scr E (drop_last l) ay a v
146.1771 -(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ _ $ _), a, v) =
146.1772 - (thy, ptp, (Script sc),
146.1773 - E, up, ay,(go up sc), a, v);
146.1774 - *)
146.1775 - | nxt_up thy ptp scr E l ay (*all has been done in (*2*) below*)
146.1776 - (Const ("Script.Seq"(*1*),_) $ _ $ _ $ _) a v =
146.1777 - nstep_up thy ptp scr E l ay a v
146.1778 -(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _ $ e2), a, v) =
146.1779 - (thy, ptp, (Script sc),
146.1780 - E, up, ay,(go up sc), a, v);
146.1781 - *)
146.1782 - | nxt_up thy ptp scr E l ay (*comes from e2*)
146.1783 - (Const ("Script.Seq"(*2*),_) $ _ $ e2) a v =
146.1784 - nstep_up thy ptp scr E l ay a v
146.1785 -(* val (thy, ptp, scr, E, l, ay, (Const ("Script.Seq",_) $ _), a, v) =
146.1786 - (thy, ptp, (Script sc),
146.1787 - E, up, ay,(go up sc), a, v);
146.1788 - *)
146.1789 - | nxt_up thy ptp (scr as Script sc) E l ay (*comes from e1*)
146.1790 - (Const ("Script.Seq",_) $ _) a v =
146.1791 - if ay = Napp_
146.1792 - then nstep_up thy ptp scr E (drop_last l) Napp_ a v
146.1793 - else (*Skip_*)
146.1794 - let val up = drop_last l;
146.1795 - val Const ("Script.Seq"(*2*),_) $ _ $ e2 = go up sc;
146.1796 - in case appy thy ptp E (up@[R]) e2 a v of
146.1797 - Appy lr => Appy lr
146.1798 - | Napp E => nstep_up thy ptp scr E up Napp_ a v
146.1799 - | Skip (v,E) => nstep_up thy ptp scr E up Skip_ a v end
146.1800 -
146.1801 - | nxt_up (thy,_) ptp scr E l ay t a v =
146.1802 - raise error ("nxt_up not impl for "^
146.1803 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) t))
146.1804 -
146.1805 -(* val (thy, ptp, (Script sc), E, l, ay, a, v)=
146.1806 - (thy, ptp, scr, E, l, Skip_, a, v);
146.1807 - val (thy, ptp, (Script sc), E, l, ay, a, v)=
146.1808 - (thy, ptp, sc, E, l, Skip_, a, v);
146.1809 - *)
146.1810 -and nstep_up thy ptp (Script sc) E l ay a v =
146.1811 - ((*writeln("### nstep_up from: "^(loc_2str l));
146.1812 - writeln("### nstep_up from: "^
146.1813 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go l sc)));*)
146.1814 - if 1 < length l
146.1815 - then
146.1816 - let
146.1817 - val up = drop_last l;
146.1818 - in ((*writeln("### nstep_up to: "^
146.1819 - (Syntax.string_of_term (thy2ctxt (assoc_thy thy)) (go up sc)));*)
146.1820 - nxt_up thy ptp (Script sc) E up ay (go up sc) a v ) end
146.1821 - else (*interpreted to end*)
146.1822 - if ay = Skip_ then Skip (v, E) else Napp E
146.1823 -);
146.1824 -
146.1825 -(* decide for the next applicable stac in the script;
146.1826 - returns (stactic, value) - the value in case the script is finished
146.1827 - 12.8.02: ~~~~~ and no assumptions ??? FIXME ???
146.1828 - 20.8.02: must return p in case of finished, because the next script
146.1829 - consulted need not be the calling script:
146.1830 - in case of detail ie. _inserted_ PrfObjs, the next stac
146.1831 - has to searched in a script with PblObj.status<>Complete !
146.1832 - (.. not true for other details ..PrfObj ??????????????????
146.1833 - 20.8.02: do NOT return safe (is only changed in locate !!!)
146.1834 -*)
146.1835 -(* val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
146.1836 - (thy', (pt,p), sc, RrlsState (ii t));
146.1837 - val (thy, (pt,p), Rfuns {next_rule=ne,...}, RrlsState (f,f',rss,_)) =
146.1838 - (thy', (pt',p'), sc, is');
146.1839 - *)
146.1840 -fun next_tac (thy,_) (pt,p) (Rfuns {next_rule,...}) (RrlsState(f,f',rss,_))=
146.1841 - if f = f' then (End_Detail' (f',[])(*8.6.03*), Uistate,
146.1842 - (f', Sundef(*FIXME is no value of next_tac! vor 8.6.03*)))
146.1843 - (*finished*)
146.1844 - else (case next_rule rss f of
146.1845 - NONE => (Empty_Tac_, Uistate, (e_term, Sundef)) (*helpless*)
146.1846 -(* val SOME (Thm (id,thm)) = next_rule rss f;
146.1847 - *)
146.1848 - | SOME (Thm (id,thm))(*8.6.03: muss auch f' liefern ?!!*) =>
146.1849 - (Rewrite' (thy, "e_rew_ord", e_rls,(*!?!8.6.03*) false,
146.1850 - (id, string_of_thmI thm), f,(e_term,[(*!?!8.6.03*)])),
146.1851 - Uistate, (e_term, Sundef))) (*next stac*)
146.1852 -
146.1853 -(* val(thy, ptp as (pt,(p,_)), sc as Script (h $ body),ScrState (E,l,a,v,s,b))=
146.1854 - ((thy',srls), (pt,pos), sc, is);
146.1855 - *)
146.1856 - | next_tac thy (ptp as (pt,(p,_)):ptree * pos') (sc as Script (h $ body))
146.1857 - (ScrState (E,l,a,v,s,b)) =
146.1858 - ((*writeln("### next_tac-----------------: E= ");
146.1859 - writeln( istate2str (ScrState (E,l,a,v,s,b)));*)
146.1860 - case if l=[] then appy thy ptp E [R] body NONE v
146.1861 - else nstep_up thy ptp sc E l Skip_ a v of
146.1862 - Skip (v,_) => (*finished*)
146.1863 - (case par_pbl_det pt p of
146.1864 - (true, p', _) =>
146.1865 - let val (_,pblID,_) = get_obj g_spec pt p';
146.1866 - in (Check_Postcond' (pblID, (v, [(*8.6.03 NO asms???*)])),
146.1867 - e_istate, (v,s)) end
146.1868 - | (_,p',rls') => (End_Detail' (e_term,[])(*8.6.03*), e_istate, (v,s)))
146.1869 - | Napp _ => (Empty_Tac_, e_istate, (e_term, Sundef)) (*helpless*)
146.1870 - | Appy (m', scrst as (_,_,_,v,_,_)) => (m', ScrState scrst,
146.1871 - (v, Sundef))) (*next stac*)
146.1872 -
146.1873 - | next_tac _ _ _ is = raise error ("next_tac: not impl for "^
146.1874 - (istate2str is));
146.1875 -
146.1876 -
146.1877 -
146.1878 -
146.1879 -(*.create the initial interpreter state from the items of the guard.*)
146.1880 -(* val (thy, itms, metID) = (thy, itms, mI);
146.1881 - *)
146.1882 -fun init_scrstate thy itms metID =
146.1883 - let val actuals = itms2args thy metID itms;
146.1884 - val scr as Script sc = (#scr o get_met) metID;
146.1885 - val formals = formal_args sc
146.1886 - (*expects same sequence of (actual) args in itms
146.1887 - and (formal) args in met*)
146.1888 - fun relate_args env [] [] = env
146.1889 - | relate_args env _ [] =
146.1890 - raise error ("ERROR in creating the environment for '"
146.1891 - ^id_of_scr sc^"' from \nthe items of the guard of "
146.1892 - ^metID2str metID^",\n\
146.1893 - \formal arg(s), from the script,\
146.1894 - \ miss actual arg(s), from the guards env:\n"
146.1895 - ^(string_of_int o length) formals
146.1896 - ^" formals: "^terms2str formals^"\n"
146.1897 - ^(string_of_int o length) actuals
146.1898 - ^" actuals: "^terms2str actuals)
146.1899 - | relate_args env [] actual_finds = env (*may drop Find!*)
146.1900 - | relate_args env (a::aa) (f::ff) =
146.1901 - if type_of a = type_of f
146.1902 - then relate_args (env @ [(a, f)]) aa ff else
146.1903 - raise error ("ERROR in creating the environment for '"
146.1904 - ^id_of_scr sc^"' from \nthe items of the guard of "
146.1905 - ^metID2str metID^",\n\
146.1906 - \different types of formal arg, from the script,\
146.1907 - \ and actual arg, from the guards env:'\n\
146.1908 - \formal: '"^term2str a^"::"^(type2str o type_of) a^"'\n\
146.1909 - \actual: '"^term2str f^"::"^(type2str o type_of) f^"'\n\
146.1910 - \in\n\
146.1911 - \formals: "^terms2str formals^"\n\
146.1912 - \actuals: "^terms2str actuals)
146.1913 - val env = relate_args [] formals actuals;
146.1914 - in (ScrState (env,[],NONE,e_term,Safe,true), scr):istate * scr end;
146.1915 -
146.1916 -(*.decide, where to get script/istate from:
146.1917 - (*1*) from PblObj.env: at begin of script if no init_form
146.1918 - (*2*) from PblObj/PrfObj: if stac is in the middle of the script
146.1919 - (*3*) from rls/PrfObj: in case of detail a ruleset.*)
146.1920 -(* val (thy', (p,p_), pt) = (thy', (p,p_), pt);
146.1921 - *)
146.1922 -fun from_pblobj_or_detail' thy' (p,p_) pt =
146.1923 - if member op = [Pbl,Met] p_
146.1924 - then case get_obj g_env pt p of
146.1925 - NONE => raise error "from_pblobj_or_detail': no istate"
146.1926 - | SOME is =>
146.1927 - let val metID = get_obj g_metID pt p
146.1928 - val {srls,...} = get_met metID
146.1929 - in (srls, is, (#scr o get_met) metID) end
146.1930 - else
146.1931 - let val (pbl,p',rls') = par_pbl_det pt p
146.1932 - in if pbl
146.1933 - then (*2*)
146.1934 - let val thy = assoc_thy thy'
146.1935 - val PblObj{meth=itms,...} = get_obj I pt p'
146.1936 - val metID = get_obj g_metID pt p'
146.1937 - val {srls,...} = get_met metID
146.1938 - in (*if last_elem p = 0 (*nothing written to pt yet*)
146.1939 - then let val (is, sc) = init_scrstate thy itms metID
146.1940 - in (srls, is, sc) end
146.1941 - else*) (srls, get_istate pt (p,p_), (#scr o get_met) metID)
146.1942 - end
146.1943 - else (*3*)
146.1944 - (e_rls, (*FIXME: get from pbl or met !!!
146.1945 - unused for Rrls in locate_gen, next_tac*)
146.1946 - get_istate pt (p,p_),
146.1947 - case rls' of
146.1948 - Rls {scr=scr,...} => scr
146.1949 - | Seq {scr=scr,...} => scr
146.1950 - | Rrls {scr=rfuns,...} => rfuns)
146.1951 - end;
146.1952 -
146.1953 -(*.get script and istate from PblObj, see (*1*) above.*)
146.1954 -fun from_pblobj' thy' (p,p_) pt =
146.1955 - let val p' = par_pblobj pt p
146.1956 - val thy = assoc_thy thy'
146.1957 - val PblObj{meth=itms,...} = get_obj I pt p'
146.1958 - val metID = get_obj g_metID pt p'
146.1959 - val {srls,scr,...} = get_met metID
146.1960 - in if last_elem p = 0 (*nothing written to pt yet*)
146.1961 - then let val (is, scr) = init_scrstate thy itms metID
146.1962 - in (srls, is, scr) end
146.1963 - else (srls, get_istate pt (p,p_), scr)
146.1964 - end;
146.1965 -
146.1966 -(*.get the stactics and problems of a script as tacs
146.1967 - instantiated with the current environment;
146.1968 - l is the location which generated the given formula.*)
146.1969 -(*WN.12.5.03: quick-and-dirty repair for listexpressions*)
146.1970 -fun is_spec_pos Pbl = true
146.1971 - | is_spec_pos Met = true
146.1972 - | is_spec_pos _ = false;
146.1973 -
146.1974 -(*. fetch _all_ tactics from script .*)
146.1975 -fun sel_rules _ (([],Res):pos') =
146.1976 - raise PTREE "no tactics applicable at the end of a calculation"
146.1977 -| sel_rules pt (p,p_) =
146.1978 - if is_spec_pos p_
146.1979 - then [get_obj g_tac pt p]
146.1980 - else
146.1981 - let val pp = par_pblobj pt p;
146.1982 - val thy' = (get_obj g_domID pt pp):theory';
146.1983 - val thy = assoc_thy thy';
146.1984 - val metID = get_obj g_metID pt pp;
146.1985 - val metID' =if metID =e_metID then(thd3 o snd3)(get_obj g_origin pt pp)
146.1986 - else metID
146.1987 - val {scr=Script sc,srls,...} = get_met metID'
146.1988 - val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_);
146.1989 - in map ((stac2tac pt thy) o rep_stacexpr o #2 o
146.1990 - (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc) end;
146.1991 -(*
146.1992 -> val Script sc = (#scr o get_met) ("SqRoot.thy","sqrt-equ-test");
146.1993 -> val env = [((term_of o the o (parse Isac.thy)) "bdv",
146.1994 - (term_of o the o (parse Isac.thy)) "x")];
146.1995 -> map ((stac2tac pt thy) o #2 o(subst_stacexpr env NONE e_term)) (stacpbls sc);
146.1996 -*)
146.1997 -
146.1998 -
146.1999 -(*. fetch tactics from script and filter _applicable_ tactics;
146.2000 - in case of Rewrite_Set* go down to _atomic_ rewrite-tactics .*)
146.2001 -fun sel_appl_atomic_tacs _ (([],Res):pos') =
146.2002 - raise PTREE "no tactics applicable at the end of a calculation"
146.2003 - | sel_appl_atomic_tacs pt (p,p_) =
146.2004 - if is_spec_pos p_
146.2005 - then [get_obj g_tac pt p]
146.2006 - else
146.2007 - let val pp = par_pblobj pt p
146.2008 - val thy' = (get_obj g_domID pt pp):theory'
146.2009 - val thy = assoc_thy thy'
146.2010 - val metID = get_obj g_metID pt pp
146.2011 - val metID' =if metID = e_metID
146.2012 - then (thd3 o snd3) (get_obj g_origin pt pp)
146.2013 - else metID
146.2014 - val {scr=Script sc,srls,erls,rew_ord'=ro,...} = get_met metID'
146.2015 - val ScrState (env,_,a,v,_,_) = get_istate pt (p,p_)
146.2016 - val alltacs = (*we expect at least 1 stac in a script*)
146.2017 - map ((stac2tac pt thy) o rep_stacexpr o #2 o
146.2018 - (handle_leaf "selrul" thy' srls env a v)) (stacpbls sc)
146.2019 - val f = case p_ of
146.2020 - Frm => get_obj g_form pt p
146.2021 - | Res => (fst o (get_obj g_result pt)) p
146.2022 - (*WN071231 ? replace atomic_appl_tacs with applicable_in (ineff!) ?*)
146.2023 - in (distinct o flat o
146.2024 - (map (atomic_appl_tacs thy ro erls f))) alltacs end;
146.2025 -
146.2026 -
146.2027 -(*
146.2028 -end
146.2029 -open Interpreter;
146.2030 -*)
146.2031 -
146.2032 -(* use"ME/script.sml";
146.2033 - use"script.sml";
146.2034 - *)
147.1 --- a/src/Tools/isac/ME/solve.sml Wed Aug 25 15:15:01 2010 +0200
147.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
147.3 @@ -1,579 +0,0 @@
147.4 -(* solve an example by interpreting a method's script
147.5 - (c) Walther Neuper 1999
147.6 -
147.7 -use"ME/solve.sml";
147.8 -use"solve.sml";
147.9 -*)
147.10 -
147.11 -fun safe (ScrState (_,_,_,_,s,_)) = s
147.12 - | safe (RrlsState _) = Safe;
147.13 -
147.14 -type mstID = string;
147.15 -type tac'_ = mstID * tac; (*DG <-> ME*)
147.16 -val e_tac'_ = ("Empty_Tac", Empty_Tac):tac'_;
147.17 -
147.18 -fun mk_tac'_ m = case m of
147.19 - Init_Proof (ppc, spec) => ("Init_Proof", Init_Proof (ppc, spec ))
147.20 -| Model_Problem => ("Model_Problem", Model_Problem)
147.21 -| Refine_Tacitly pblID => ("Refine_Tacitly", Refine_Tacitly pblID)
147.22 -| Refine_Problem pblID => ("Refine_Problem", Refine_Problem pblID)
147.23 -| Add_Given cterm' => ("Add_Given", Add_Given cterm')
147.24 -| Del_Given cterm' => ("Del_Given", Del_Given cterm')
147.25 -| Add_Find cterm' => ("Add_Find", Add_Find cterm')
147.26 -| Del_Find cterm' => ("Del_Find", Del_Find cterm')
147.27 -| Add_Relation cterm' => ("Add_Relation", Add_Relation cterm')
147.28 -| Del_Relation cterm' => ("Del_Relation", Del_Relation cterm')
147.29 -
147.30 -| Specify_Theory domID => ("Specify_Theory", Specify_Theory domID)
147.31 -| Specify_Problem pblID => ("Specify_Problem", Specify_Problem pblID)
147.32 -| Specify_Method metID => ("Specify_Method", Specify_Method metID)
147.33 -| Apply_Method metID => ("Apply_Method", Apply_Method metID)
147.34 -| Check_Postcond pblID => ("Check_Postcond", Check_Postcond pblID)
147.35 -| Free_Solve => ("Free_Solve",Free_Solve)
147.36 -
147.37 -| Rewrite_Inst (subs, thm') => ("Rewrite_Inst", Rewrite_Inst (subs, thm'))
147.38 -| Rewrite thm' => ("Rewrite", Rewrite thm')
147.39 -| Rewrite_Asm thm' => ("Rewrite_Asm", Rewrite_Asm thm')
147.40 -| Rewrite_Set_Inst (subs, rls')
147.41 - => ("Rewrite_Set_Inst", Rewrite_Set_Inst (subs, rls'))
147.42 -| Rewrite_Set rls' => ("Rewrite_Set", Rewrite_Set rls')
147.43 -| End_Ruleset => ("End_Ruleset", End_Ruleset)
147.44 -
147.45 -| End_Detail => ("End_Detail", End_Detail)
147.46 -| Detail_Set rls' => ("Detail_Set", Detail_Set rls')
147.47 -| Detail_Set_Inst (s, rls') => ("Detail_Set_Inst", Detail_Set_Inst (s, rls'))
147.48 -
147.49 -| Calculate op_ => ("Calculate", Calculate op_)
147.50 -| Substitute sube => ("Substitute", Substitute sube)
147.51 -| Apply_Assumption cts' => ("Apply_Assumption", Apply_Assumption cts')
147.52 -
147.53 -| Take cterm' => ("Take", Take cterm')
147.54 -| Take_Inst cterm' => ("Take_Inst", Take_Inst cterm')
147.55 -| Group (con, ints) => ("Group", Group (con, ints))
147.56 -| Subproblem (domID, pblID) => ("Subproblem", Subproblem (domID, pblID))
147.57 -(*
147.58 -| Subproblem_Full(spec,cts')=> ("Subproblem_Full", Subproblem_Full(spec,cts'))
147.59 -*)
147.60 -| End_Subproblem => ("End_Subproblem",End_Subproblem)
147.61 -| CAScmd cterm' => ("CAScmd", CAScmd cterm')
147.62 -
147.63 -| Split_And => ("Split_And", Split_And)
147.64 -| Conclude_And => ("Conclude_And", Conclude_And)
147.65 -| Split_Or => ("Split_Or", Split_Or)
147.66 -| Conclude_Or => ("Conclude_Or", Conclude_Or)
147.67 -| Begin_Trans => ("Begin_Trans", Begin_Trans)
147.68 -| End_Trans => ("End_Trans", End_Trans)
147.69 -| Begin_Sequ => ("Begin_Sequ", Begin_Sequ)
147.70 -| End_Sequ => ("End_Sequ", Begin_Sequ)
147.71 -| Split_Intersect => ("Split_Intersect", Split_Intersect)
147.72 -| End_Intersect => ("End_Intersect", End_Intersect)
147.73 -| Check_elementwise cterm' => ("Check_elementwise", Check_elementwise cterm')
147.74 -| Or_to_List => ("Or_to_List", Or_to_List)
147.75 -| Collect_Trues => ("Collect_Results", Collect_Trues)
147.76 -
147.77 -| Empty_Tac => ("Empty_Tac",Empty_Tac)
147.78 -| Tac string => ("Tac",Tac string)
147.79 -| User => ("User",User)
147.80 -| End_Proof' => ("End_Proof'",End_Proof');
147.81 -
147.82 -(*Detail*)
147.83 -val empty_tac'_ = (mk_tac'_ Empty_Tac):tac'_;
147.84 -
147.85 -fun mk_tac ((_,m):tac'_) = m;
147.86 -fun mk_mstID ((mI,_):tac'_) = mI;
147.87 -
147.88 -fun tac'_2str ((ID,ms):tac'_) = ID ^ (tac2str ms);
147.89 -(* TODO: tac2str, tac'_2str NOT tested *)
147.90 -
147.91 -
147.92 -
147.93 -type squ = ptree; (* TODO: safe etc. *)
147.94 -
147.95 -(*13.9.02--------------
147.96 -type ctr = (loc * pos) list;
147.97 -val ops = [("PLUS","op +"),("minus","op -"),("TIMES","op *"),
147.98 - ("cancel","cancel"),("pow","pow"),("sqrt","sqrt")];
147.99 -fun op_intern op_ =
147.100 - case assoc (ops,op_) of
147.101 - SOME op' => op' | NONE => raise error ("op_intern: no op= "^op_);
147.102 ------------------------*)
147.103 -
147.104 -
147.105 -
147.106 -(* use"ME/solve.sml";
147.107 - use"solve.sml";
147.108 -
147.109 -val ttt = (term_of o the o (parse thy))"Substitute [(bdv,x)] g";
147.110 -val ttt = (term_of o the o (parse thy))"Rewrite thmid True g";
147.111 -
147.112 - Const ("Script.Rewrite'_Inst",_) $ sub $ Free (thm',_) $ Const (pa,_) $ f'
147.113 - *)
147.114 -
147.115 -
147.116 -
147.117 -val specsteps = ["Init_Proof","Refine_Tacitly","Refine_Problem",
147.118 - "Model_Problem",(*"Match_Problem",*)
147.119 - "Add_Given","Del_Given","Add_Find","Del_Find",
147.120 - "Add_Relation","Del_Relation",
147.121 - "Specify_Theory","Specify_Problem","Specify_Method"];
147.122 -
147.123 -"-----------------------------------------------------------------------";
147.124 -
147.125 -
147.126 -fun step2taci ((tac_, _, pt, p, _):step) = (*FIXXME.040312: redesign step*)
147.127 - (tac_2tac tac_, tac_, (p, get_istate pt p)):taci;
147.128 -
147.129 -
147.130 -(*FIXME.WN050821 compare solve ... nxt_solv*)
147.131 -(* val ("Apply_Method",Apply_Method' (mI,_))=(mI,m);
147.132 - val (("Apply_Method",Apply_Method' (mI,_,_)),pt, pos as (p,_))=(m,pt, pos);
147.133 - *)
147.134 -fun solve ("Apply_Method", m as Apply_Method' (mI, _, _))
147.135 - (pt:ptree, (pos as (p,_))) =
147.136 - let val {srls,...} = get_met mI;
147.137 - val PblObj{meth=itms,...} = get_obj I pt p;
147.138 - val thy' = get_obj g_domID pt p;
147.139 - val thy = assoc_thy thy';
147.140 - val (is as ScrState (env,_,_,_,_,_), sc) = init_scrstate thy itms mI;
147.141 - val ini = init_form thy sc env;
147.142 - val p = lev_dn p;
147.143 - in
147.144 - case ini of
147.145 - SOME t => (* val SOME t = ini;
147.146 - *)
147.147 - let val (pos,c,_,pt) =
147.148 - generate1 thy (Apply_Method' (mI, SOME t, is))
147.149 - is (lev_on p, Frm)(*implicit Take*) pt;
147.150 - in ("ok",([(Apply_Method mI, Apply_Method' (mI, SOME t, is),
147.151 - ((lev_on p, Frm), is))], c, (pt,pos)):calcstate')
147.152 - end
147.153 - | NONE => (*execute the first tac in the Script, compare solve m*)
147.154 - let val (m', is', _) = next_tac (thy', srls) (pt, (p, Res)) sc is;
147.155 - val d = e_rls (*FIXME: get simplifier from domID*);
147.156 - in
147.157 - case locate_gen (thy',srls) m' (pt,(p, Res))(sc,d) is' of
147.158 - Steps (is'', ss as (m'',f',pt',p',c')::_) =>
147.159 -(* val Steps (is'', ss as (m'',f',pt',p',c')::_) =
147.160 - locate_gen (thy',srls) m' (pt,(p,Res)) (sc,d) is';
147.161 - *)
147.162 - ("ok", (map step2taci ss, c', (pt',p')))
147.163 - | NotLocatable =>
147.164 - let val (p,ps,f,pt) =
147.165 - generate_hard (assoc_thy "Isac.thy") m (p,Frm) pt;
147.166 - in ("not-found-in-script",
147.167 - ([(tac_2tac m, m, (pos, is))], ps, (pt,p))) end
147.168 - (*just-before------------------------------------------------------
147.169 - ("ok",([(Apply_Method mI,Apply_Method'(mI,NONE,e_istate),
147.170 - (pos, is))],
147.171 - [], (update_env pt (fst pos) (SOME is),pos)))
147.172 - -----------------------------------------------------------------*)
147.173 - end
147.174 - end
147.175 -
147.176 - | solve ("Free_Solve", Free_Solve') (pt,po as (p,_)) =
147.177 - let (*val _=writeln"###solve Free_Solve";*)
147.178 - val p' = lev_dn_ (p,Res);
147.179 - val pt = update_metID pt (par_pblobj pt p) e_metID;
147.180 - in ("ok", ((*(p',Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Unsafe,*)
147.181 - [(Empty_Tac, Empty_Tac_, (po, Uistate))], [], (pt,p'))) end
147.182 -
147.183 -(* val (("Check_Postcond",Check_Postcond' (pI,_)), (pt,(pos as (p,p_)))) =
147.184 - ( m, (pt, pos));
147.185 - *)
147.186 - | solve ("Check_Postcond",Check_Postcond' (pI,_)) (pt,(pos as (p,p_))) =
147.187 - let (*val _=writeln"###solve Check_Postcond";*)
147.188 - val pp = par_pblobj pt p
147.189 - val asm = (case get_obj g_tac pt p of
147.190 - Check_elementwise _ => (*collects and instantiates asms*)
147.191 - (snd o (get_obj g_result pt)) p
147.192 - | _ => ((map fst) o (get_assumptions_ pt)) (p,p_))
147.193 - handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*)
147.194 - val metID = get_obj g_metID pt pp;
147.195 - val {srls=srls,scr=sc,...} = get_met metID;
147.196 - val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_);
147.197 - (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_)));
147.198 - val _= writeln("### solve Check_postc, is= "^(istate2str is));*)
147.199 - val thy' = get_obj g_domID pt pp;
147.200 - val thy = assoc_thy thy';
147.201 - val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is;
147.202 - (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*)
147.203 -
147.204 - in if pp = [] then
147.205 - let val is = ScrState (E,l,a,scval,scsaf,b)
147.206 - val tac_ = Check_Postcond'(pI,(scval, map term2str asm))
147.207 - val (pos,ps,f,pt) = generate1 thy tac_ is (pp,Res) pt;
147.208 - in ("ok", ((*(([],Res),is,End_Proof''), f, End_Proof', scsaf,*)
147.209 - [(Check_Postcond pI, tac_, ((pp,Res),is))], ps,(pt,pos))) end
147.210 - else
147.211 - let
147.212 - (*resume script of parpbl, transfer value of subpbl-script*)
147.213 - val ppp = par_pblobj pt (lev_up p);
147.214 - val thy' = get_obj g_domID pt ppp;
147.215 - val thy = assoc_thy thy';
147.216 - val metID = get_obj g_metID pt ppp;
147.217 - val sc = (#scr o get_met) metID;
147.218 - val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm);
147.219 - (*val _=writeln("### solve Check_postc, parpbl pos= "^(pos'2str(pp,Frm)));
147.220 - val _=writeln("### solve Check_postc, is(pt)= "^(istate2str is));
147.221 - val _=writeln("### solve Check_postc, is'= "^
147.222 - (istate2str (E,l,a,scval,scsaf,b)));*)
147.223 - val ((p,p_),ps,f,pt) =
147.224 - generate1 thy (Check_Postcond' (pI, (scval, map term2str asm)))
147.225 - (ScrState (E,l,a,scval,scsaf,b)) (pp,Res) pt;
147.226 - (*val _=writeln("### solve Check_postc, is(pt')= "^
147.227 - (istate2str (get_istate pt ([3],Res))));
147.228 - val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) sc
147.229 - (ScrState (E,l,a,scval,scsaf,b));*)
147.230 - in ("ok",(*((pp,Res),is',nx), f, tac_2tac nx, scsaf,*)
147.231 - ([(Check_Postcond pI, Check_Postcond'(pI,(scval, map term2str asm)),
147.232 - ((pp,Res), ScrState (E,l,a,scval,scsaf,b)))],ps,(pt,(p,p_))))
147.233 - end
147.234 - end
147.235 -(* val (msg, cs') =
147.236 - ("ok",([(Check_Postcond pI,Check_Postcond'(pI, (scval, map term2str asm))),
147.237 - ((pp,Res),(ScrState (E,l,a,scval,scsaf,b)))], (pt,(p,p_))));
147.238 - val (_,(pt',p')) = cs';
147.239 - (writeln o istate2str) (get_istate pt' p');
147.240 - (term2str o fst) (get_obj g_result pt' (fst p'));
147.241 - *)
147.242 -
147.243 -(* writeln(istate2str(get_istate pt (p,p_)));
147.244 - *)
147.245 - | solve (_,End_Proof'') (pt, (p,p_)) =
147.246 - ("end-proof",
147.247 - ((*(([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe,*)
147.248 - [(Empty_Tac,Empty_Tac_,(([],Res),Uistate))],[],(pt,(p,p_))))
147.249 -
147.250 -(*-----------vvvvvvvvvvv could be done by generate1 ?!?*)
147.251 - | solve (_,End_Detail' t) (pt,(p,p_)) =
147.252 - let val pr as (p',_) = (lev_up p, Res)
147.253 - val pp = par_pblobj pt p
147.254 - val r = (fst o (get_obj g_result pt)) p'
147.255 - (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*)
147.256 - val thy' = get_obj g_domID pt pp
147.257 - val (srls, is, sc) = from_pblobj' thy' pr pt
147.258 - val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is
147.259 - in ("ok", ((*((pp,Frm(*???*)),is,tac_),
147.260 - Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)),
147.261 - tac_2tac tac_, Sundef,*)
147.262 - [(End_Detail, End_Detail' t ,
147.263 - ((p,p_), get_istate pt (p,p_)))], [], (pt,pr))) end
147.264 -
147.265 - | solve (mI,m) (pt, po as (p,p_)) =
147.266 -(* val ((mI,m), (pt, po as (p,p_))) = (m, (pt, pos));
147.267 - *)
147.268 - if e_metID = get_obj g_metID pt (par_pblobj pt p)(*29.8.02:
147.269 - could be detail, too !!*)
147.270 - then let val ((p,p_),ps,f,pt) =
147.271 - generate1 (assoc_thy (get_obj g_domID pt (par_pblobj pt p)))
147.272 - m e_istate (p,p_) pt;
147.273 - in ("no-method-specified", (*Free_Solve*)
147.274 - ((*((p,p_),Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*)
147.275 - [(Empty_Tac,Empty_Tac_, ((p,p_),Uistate))], ps, (pt,(p,p_)))) end
147.276 - else
147.277 - let
147.278 - val thy' = get_obj g_domID pt (par_pblobj pt p);
147.279 - val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt;
147.280 -(*val _= writeln("### solve, before locate_gen p="^(pos'2str(p,p_)));*)
147.281 - val d = e_rls; (*FIXME: canon.simplifier for domain is missing
147.282 - 8.01: generate from domID?*)
147.283 - in case locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is of
147.284 - Steps (is', ss as (m',f',pt',p',c')::_) =>
147.285 -(* val Steps (is', ss as (m',f',pt',p',c')::_) =
147.286 - locate_gen (thy',srls) m (pt,(p,p_)) (sc,d) is;
147.287 - *)
147.288 - let (*val _= writeln("### solve, after locate_gen: is= ")
147.289 - val _= writeln(istate2str is')*)
147.290 - (*val nxt_ =
147.291 - case p' of (*change from solve to model subpbl*)
147.292 - (_,Pbl) => nxt_model_pbl m' (pt',p')
147.293 - | _ => fst3 (next_tac (thy',srls) (pt',p') sc is');*)
147.294 - (*27.8.02:next_tac may change to other branches in pt FIXXXXME*)
147.295 - in ("ok", ((*(p',is',nxt_), f', tac_2tac nxt_, safe is',*)
147.296 - map step2taci ss, c', (pt',p'))) end
147.297 - | NotLocatable =>
147.298 - let val (p,ps,f,pt) =
147.299 - generate_hard (assoc_thy "Isac.thy") m (p,p_) pt;
147.300 - in ("not-found-in-script",
147.301 - ((*(p,Uistate,Empty_Tac_),f, Empty_Tac, Unsafe,*)
147.302 - [(tac_2tac m, m, (po,is))], ps, (pt,p))) end
147.303 - end;
147.304 -
147.305 -
147.306 -(*FIXME.WN050821 compare solve ... nxt_solv*)
147.307 -(* nxt_solv (Apply_Method' vvv FIXME: get args in applicable_in *)
147.308 -fun nxt_solv (Apply_Method' (mI,_,_)) _ (pt:ptree, pos as (p,_)) =
147.309 -(* val ((Apply_Method' (mI,_,_)), _, (pt:ptree, pos as (p,_))) =
147.310 - ((Apply_Method' (mI, NONE, e_istate)), e_istate, ptp);
147.311 - *)
147.312 - let val {srls,ppc,...} = get_met mI;
147.313 - val PblObj{meth=itms,origin=(oris,_,_),probl,...} = get_obj I pt p;
147.314 - val itms = if itms <> [] then itms
147.315 - else complete_metitms oris probl [] ppc
147.316 - val thy' = get_obj g_domID pt p;
147.317 - val thy = assoc_thy thy';
147.318 - val (is as ScrState (env,_,_,_,_,_), scr) = init_scrstate thy itms mI;
147.319 - val ini = init_form thy scr env;
147.320 - in
147.321 - case ini of
147.322 - SOME t => (* val SOME t = ini;
147.323 - *)
147.324 - let val pos = ((lev_on o lev_dn) p, Frm)
147.325 - val tac_ = Apply_Method' (mI, SOME t, is);
147.326 - val (pos,c,_,pt) = (*implicit Take*)
147.327 - generate1 thy tac_ is pos pt
147.328 - (*val _= ("### nxt_solv Apply_Method, pos= "^pos'2str (lev_on p,Frm));*)
147.329 - in ([(Apply_Method mI, tac_, (pos, is))], c, (pt, pos)):calcstate' end
147.330 - | NONE =>
147.331 - let val pt = update_env pt (fst pos) (SOME is)
147.332 - val (tacis, c, ptp) = nxt_solve_ (pt, pos)
147.333 - in (tacis @
147.334 - [(Apply_Method mI, Apply_Method' (mI, NONE, e_istate), (pos, is))],
147.335 - c, ptp) end
147.336 - end
147.337 -(* val ("Check_Postcond",Check_Postcond' (pI,_)) = (mI,m);
147.338 - val (Check_Postcond' (pI,_), _, (pt, pos as (p,p_))) =
147.339 - (tac_, is, ptp);
147.340 - *)
147.341 - (*TODO.WN050913 remove unnecessary code below*)
147.342 - | nxt_solv (Check_Postcond' (pI,_)) _ (pt, pos as (p,p_)) =
147.343 - let (*val _=writeln"###solve Check_Postcond";*)
147.344 - val pp = par_pblobj pt p
147.345 - val asm = (case get_obj g_tac pt p of
147.346 - Check_elementwise _ => (*collects and instantiates asms*)
147.347 - (snd o (get_obj g_result pt)) p
147.348 - | _ => ((map fst) o (get_assumptions_ pt)) (p,p_))
147.349 - handle _ => [] (*WN.27.5.03 asms in subpbls not completely clear*)
147.350 - val metID = get_obj g_metID pt pp;
147.351 - val {srls=srls,scr=sc,...} = get_met metID;
147.352 - val is as ScrState (E,l,a,_,_,b) = get_istate pt (p,p_);
147.353 - (*val _= writeln("### solve Check_postc, subpbl pos= "^(pos'2str (p,p_)));
147.354 - val _= writeln("### solve Check_postc, is= "^(istate2str is));*)
147.355 - val thy' = get_obj g_domID pt pp;
147.356 - val thy = assoc_thy thy';
147.357 - val (_,_,(scval,scsaf)) = next_tac (thy',srls) (pt,(p,p_)) sc is;
147.358 - (*val _= writeln("### solve Check_postc, scval= "^(term2str scval));*)
147.359 - in if pp = [] then
147.360 - let val is = ScrState (E,l,a,scval,scsaf,b)
147.361 - val tac_ = Check_Postcond'(pI,(scval, map term2str asm))
147.362 - (*val _= writeln"### nxt_solv2 Apply_Method: stored is =";
147.363 - val _= writeln(istate2str is);*)
147.364 - val ((p,p_),ps,f,pt) =
147.365 - generate1 thy tac_ is (pp,Res) pt;
147.366 - in ([(Check_Postcond pI, tac_, ((pp,Res), is))],ps,(pt, (p,p_))) end
147.367 - else
147.368 - let
147.369 - (*resume script of parpbl, transfer value of subpbl-script*)
147.370 - val ppp = par_pblobj pt (lev_up p);
147.371 - val thy' = get_obj g_domID pt ppp;
147.372 - val thy = assoc_thy thy';
147.373 - val metID = get_obj g_metID pt ppp;
147.374 - val {scr,...} = get_met metID;
147.375 - val is as ScrState (E,l,a,_,_,b) = get_istate pt (pp(*!/p/*),Frm)
147.376 - val tac_ = Check_Postcond' (pI, (scval, map term2str asm))
147.377 - val is = ScrState (E,l,a,scval,scsaf,b)
147.378 - (*val _= writeln"### nxt_solv3 Apply_Method: stored is =";
147.379 - val _= writeln(istate2str is);*)
147.380 - val ((p,p_),ps,f,pt) = generate1 thy tac_ is (pp, Res) pt;
147.381 - (*val (nx,is',_) = next_tac (thy',srls) (pt,(p,p_)) scr is;WN050913*)
147.382 - in ([(Check_Postcond pI, tac_, ((pp, Res), is))], ps, (pt, (p,p_))) end
147.383 - end
147.384 -(* writeln(istate2str(get_istate pt (p,p_)));
147.385 - *)
147.386 -
147.387 -(*.start interpreter and do one rewrite.*)
147.388 -(* val (_,Detail_Set'(thy',rls,t)) = (mI,m); val p = (p,p_);
147.389 - solve ("",Detail_Set'(thy', rls, t)) p pt;
147.390 - | nxt_solv (Detail_Set'(thy', rls, t)) _ (pt, p) = **********
147.391 ----> FE-interface/sml.sml
147.392 -
147.393 - | nxt_solv (End_Detail' t) _ (pt, (p,p_)) = **********
147.394 - let val pr as (p',_) = (lev_up p, Res)
147.395 - val pp = par_pblobj pt p
147.396 - val r = (fst o (get_obj g_result pt)) p'
147.397 - (*Rewrite_Set* done at Detail_Set*: this result is already in ptree*)
147.398 - val thy' = get_obj g_domID pt pp
147.399 - val (srls, is, sc) = from_pblobj' thy' pr pt
147.400 - val (tac_,is',_) = next_tac (thy',srls) (pt,pr) sc is
147.401 - in (pr, ((pp,Frm(*???*)),is,tac_),
147.402 - Form' (FormKF (~1, EdUndef, length p', Nundef, term2str r)),
147.403 - tac_2tac tac_, Sundef, pt) end
147.404 -*)
147.405 - | nxt_solv (End_Proof'') _ ptp = ([], [], ptp)
147.406 -
147.407 - | nxt_solv tac_ is (pt, pos as (p,p_)) =
147.408 -(* val (pt, pos as (p,p_)) = ptp;
147.409 - *)
147.410 - let val pos = case pos of
147.411 - (p, Met) => ((lev_on o lev_dn) p, Frm)(*begin script*)
147.412 - | (p, Res) => (lev_on p,Res) (*somewhere in script*)
147.413 - | _ => pos (*somewhere in script*)
147.414 - (*val _= writeln"### nxt_solv4 Apply_Method: stored is =";
147.415 - val _= writeln(istate2str is);*)
147.416 - val (pos',c,_,pt) = generate1 (assoc_thy "Isac.thy") tac_ is pos pt;
147.417 - in ([(tac_2tac tac_, tac_, (pos,is))], c, (pt, pos')) end
147.418 -
147.419 -
147.420 - (*(p,p_), (([],Res),Uistate,Empty_Tac_), EmptyMout, Empty_Tac, Safe, pt*)
147.421 -
147.422 -
147.423 -(*.find the next tac from the script, nxt_solv will update the ptree.*)
147.424 -(* val (ptp as (pt,pos as (p,p_))) = ptp';
147.425 - val (ptp as (pt, pos as (p,p_))) = ptp'';
147.426 - val (ptp as (pt, pos as (p,p_))) = ptp;
147.427 - val (ptp as (pt, pos as (p,p_))) = (pt,ip);
147.428 - val (ptp as (pt, pos as (p,p_))) = (pt, pos);
147.429 - *)
147.430 -and nxt_solve_ (ptp as (pt, pos as (p,p_))) =
147.431 - if e_metID = get_obj g_metID pt (par_pblobj pt p)
147.432 - then ([], [], (pt,(p,p_))):calcstate'
147.433 - else let val thy' = get_obj g_domID pt (par_pblobj pt p);
147.434 - val (srls, is, sc) = from_pblobj_or_detail' thy' (p,p_) pt;
147.435 - val (tac_,is,(t,_)) = next_tac (thy',srls) (pt,pos) sc is;
147.436 - (*TODO here ^^^ return finished/helpless/ok !*)
147.437 - (* val (tac_',is',(t',_)) = next_tac (thy',srls) (pt,pos) sc is;
147.438 - *)
147.439 - in case tac_ of
147.440 - End_Detail' _ => ([(End_Detail,
147.441 - End_Detail' (t,[(*FIXME.040215*)]),
147.442 - (pos, is))], [], (pt, pos))
147.443 - | _ => nxt_solv tac_ is ptp end;
147.444 -
147.445 -(*.says how may steps of a calculation should be done by "fun autocalc".*)
147.446 -(*TODO.WN0512 redesign togehter with autocalc ?*)
147.447 -datatype auto =
147.448 - Step of int (*1 do #int steps; may stop in model/specify:
147.449 - IS VERY INEFFICIENT IN MODEL/SPECIY*)
147.450 -| CompleteModel (*2 complete modeling
147.451 - if model complete, finish specifying + start solving*)
147.452 -| CompleteCalcHead (*3 complete model/specify in one go + start solving*)
147.453 -| CompleteToSubpbl (*4 stop at the next begin of a subproblem,
147.454 - if none, complete the actual (sub)problem*)
147.455 -| CompleteSubpbl (*5 complete the actual (sub)problem (incl.ev.subproblems)*)
147.456 -| CompleteCalc; (*6 complete the calculation as a whole*)
147.457 -fun autoord (Step _ ) = 1
147.458 - | autoord CompleteModel = 2
147.459 - | autoord CompleteCalcHead = 3
147.460 - | autoord CompleteToSubpbl = 4
147.461 - | autoord CompleteSubpbl = 5
147.462 - | autoord CompleteCalc = 6;
147.463 -
147.464 -(* val (auto, c, (ptp as (_, p))) = (auto, (c@c'), ptp);
147.465 - *)
147.466 -fun complete_solve auto c (ptp as (_, p): ptree * pos') =
147.467 - if p = ([], Res) then ("end-of-calculation", [], ptp) else
147.468 - case nxt_solve_ ptp of
147.469 - ((Subproblem _, tac_, (_, is))::_, c', ptp') =>
147.470 -(* val ptp' = ptp''';
147.471 - *)
147.472 - if autoord auto < 5 then ("ok", c@c', ptp)
147.473 - else let val ptp = all_modspec ptp';
147.474 - val (_, c'', ptp) = all_solve auto (c@c') ptp;
147.475 - in complete_solve auto (c@c'@c'') ptp end
147.476 - | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) =>
147.477 - if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp')
147.478 - else complete_solve auto (c@c') ptp'
147.479 - | ((End_Detail, _, _)::_, c', ptp') =>
147.480 - if autoord auto < 6 then ("ok", c@c', ptp')
147.481 - else complete_solve auto (c@c') ptp'
147.482 - | (_, c', ptp') => complete_solve auto (c@c') ptp'
147.483 -(* val (tacis, c', ptp') = nxt_solve_ ptp;
147.484 - val (tacis, c', ptp'') = nxt_solve_ ptp';
147.485 - val (tacis, c', ptp''') = nxt_solve_ ptp'';
147.486 - val (tacis, c', ptp'''') = nxt_solve_ ptp''';
147.487 - val (tacis, c', ptp''''') = nxt_solve_ ptp'''';
147.488 - *)
147.489 -and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') =
147.490 -(* val (ptp as (pt, (p,_))) = ptp;
147.491 - val (ptp as (pt, (p,_))) = ptp';
147.492 - val (ptp as (pt, (p,_))) = (pt, pos);
147.493 - *)
147.494 - let val (_,_,mI) = get_obj g_spec pt p;
147.495 - val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate))
147.496 - e_istate ptp;
147.497 - in complete_solve auto (c@c') ptp end;
147.498 -(*@@@ vvv @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
147.499 -fun complete_solve auto c (ptp as (_, p as (_,p_)): ptree * pos') =
147.500 - if p = ([], Res) then ("end-of-calculation", [], ptp) else
147.501 - if member op = [Pbl,Met] p_
147.502 - then let val ptp = all_modspec ptp
147.503 - val (_, c', ptp) = all_solve auto c ptp
147.504 - in complete_solve auto (c@c') ptp end
147.505 - else case nxt_solve_ ptp of
147.506 - ((Subproblem _, tac_, (_, is))::_, c', ptp') =>
147.507 - if autoord auto < 5 then ("ok", c@c', ptp)
147.508 - else let val ptp = all_modspec ptp'
147.509 - val (_, c'', ptp) = all_solve auto (c@c') ptp
147.510 - in complete_solve auto (c@c'@c'') ptp end
147.511 - | ((Check_Postcond _, tac_, (_, is))::_, c', ptp' as (_, p')) =>
147.512 - if autoord auto < 6 orelse p' = ([],Res) then ("ok", c@c', ptp')
147.513 - else complete_solve auto (c@c') ptp'
147.514 - | ((End_Detail, _, _)::_, c', ptp') =>
147.515 - if autoord auto < 6 then ("ok", c@c', ptp')
147.516 - else complete_solve auto (c@c') ptp'
147.517 - | (_, c', ptp') => complete_solve auto (c@c') ptp'
147.518 -and all_solve auto c (ptp as (pt, (p,_)): ptree * pos') =
147.519 - let val (_,_,mI) = get_obj g_spec pt p
147.520 - val (_, c', ptp) = nxt_solv (Apply_Method' (mI, NONE, e_istate))
147.521 - e_istate ptp
147.522 - in complete_solve auto (c@c') ptp end;
147.523 -
147.524 -(*.aux.fun for detailrls with Rrls, reverse rewriting.*)
147.525 -(* val (nds, t, ((rule, (t', asm)) :: rts)) = ([], t, rul_terms);
147.526 - *)
147.527 -fun rul_terms_2nds nds t [] = nds
147.528 - | rul_terms_2nds nds t ((rule, res as (t', _)) :: rts) =
147.529 - (append_atomic [] e_istate t (rule2tac [] rule) res Complete EmptyPtree) ::
147.530 - (rul_terms_2nds nds t' rts);
147.531 -
147.532 -
147.533 -(*. detail steps done internally by Rewrite_Set*
147.534 - into ctree by use of a script .*)
147.535 -(* val (pt, (p,p_)) = (pt, pos);
147.536 - *)
147.537 -fun detailrls pt ((p,p_):pos') =
147.538 - let val t = get_obj g_form pt p
147.539 - val tac = get_obj g_tac pt p
147.540 - val rls = (assoc_rls o rls_of) tac
147.541 - in case rls of
147.542 -(* val Rrls {scr = Rfuns {init_state,...},...} = rls;
147.543 - *)
147.544 - Rrls {scr = Rfuns {init_state,...},...} =>
147.545 - let val (_,_,_,rul_terms) = init_state t
147.546 - val newnds = rul_terms_2nds [] t rul_terms
147.547 - val pt''' = ins_chn newnds pt p
147.548 - in ("detailrls", pt''', (p @ [length newnds], Res):pos') end
147.549 - | _ =>
147.550 - let val is = init_istate tac t
147.551 - (*TODO.WN060602 ScrState (["(t_, Problem (Isac,[equation,univar]))"]
147.552 - is wrong for simpl, but working ?!? *)
147.553 - val tac_ = Apply_Method' (e_metID(*WN0402: see generate1 !?!*),
147.554 - SOME t, is)
147.555 - val pos' = ((lev_on o lev_dn) p, Frm)
147.556 - val thy = assoc_thy "Isac.thy"
147.557 - val (_,_,_,pt') = (*implicit Take*)generate1 thy tac_ is pos' pt
147.558 - val (_,_,(pt'',_)) = complete_solve CompleteSubpbl [] (pt',pos')
147.559 - val newnds = children (get_nd pt'' p)
147.560 - val pt''' = ins_chn newnds pt p
147.561 - (*complete_solve cuts branches after*)
147.562 - in ("detailrls", pt'''(*, get_formress [] ((lev_on o lev_dn) p)cn*),
147.563 - (p @ [length newnds], Res):pos') end
147.564 - end;
147.565 -
147.566 -
147.567 -
147.568 -(* val(mI,m)=m;val ppp=p;(*!!!*)val(p,p_)=pos;val(_,pt,_)=ppp(*!!!*);
147.569 - get_form ((mI,m):tac'_) ((p,p_):pos') ppp;
147.570 - *)
147.571 -fun get_form ((mI,m):tac'_) ((p,p_):pos') pt =
147.572 - case applicable_in (p,p_) pt m of
147.573 - Notappl e => Error' (Error_ e)
147.574 - | Appl m =>
147.575 - (* val Appl m=applicable_in (p,p_) pt m;
147.576 - *)
147.577 - if member op = specsteps mI
147.578 - then let val (_,_,f,_,_,_) = specify m (p,p_) [] pt
147.579 - in f end
147.580 - else let val (*_,_,f,_,_,_*)_ = solve (mI,m) (pt,(p,p_))
147.581 - in (*f*) EmptyMout end;
147.582 -
148.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
148.2 +++ b/src/Tools/isac/ProgLang/Isabelle-isac-conflicts Wed Aug 25 16:20:07 2010 +0200
148.3 @@ -0,0 +1,22 @@
148.4 +6.8.02:
148.5 +(1) special constants are already defined by Isabelle2002,
148.6 + and thus cannot be parsed from terms; eg.
148.7 +
148.8 + Reals thus formula 'subproblem (Reals,...)' not possible
148.9 + power thus 'Calculate power' not possible in Scripts
148.10 +
148.11 +(2) numerals in (terms and) thms are stored differently:
148.12 + string Isabelle term isac term
148.13 + 123 Bin.... Free("123",_)
148.14 + 0 Const("0",_) Free("0",_)
148.15 + 0 Const("1",_) Free("1",_)
148.16 +
148.17 +(3) overwritteln functions
148.18 + find_first see isac/ROOT.ML
148.19 +
148.20 +
148.21 +Questions for Isabelle team:
148.22 +
148.23 +28.02.03
148.24 +(4) what is going on in Isa02/Typefix.thy (Markus Wenzen) ?
148.25 +(5) how avoid "- x" ---parse---> Free ("-x", _) ?
148.26 \ No newline at end of file
149.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
149.2 +++ b/src/Tools/isac/ProgLang/ListC.thy Wed Aug 25 16:20:07 2010 +0200
149.3 @@ -0,0 +1,204 @@
149.4 +(* use_thy_only"../ProgLang/ListC";
149.5 + use_thy_only"ProgLang/ListC";
149.6 + use_thy"ProgLang/ListC";
149.7 +
149.8 + use_thy_only"ListC";
149.9 + W.N. 8.01
149.10 + attaches identifiers to definition of listfuns,
149.11 + for storing them in list_rls
149.12 +
149.13 +WN.29.4.03:
149.14 +*)
149.15 +
149.16 +theory ListC imports Complex_Main
149.17 +uses ("library.sml")("calcelems.sml")
149.18 +("ProgLang/term.sml")("ProgLang/calculate.sml")
149.19 +("ProgLang/rewrite.sml")
149.20 +begin
149.21 +use "library.sml" (*indent,...*)
149.22 +use "calcelems.sml" (*str_of_type, Thm,...*)
149.23 +use "ProgLang/term.sml" (*num_str,...*)
149.24 +use "ProgLang/calculate.sml" (*???*)
149.25 +use "ProgLang/rewrite.sml" (*?*** At command "end" (line 205../ListC.thy*)
149.26 +
149.27 +text {* 'nat' in List.thy replaced by 'real' *}
149.28 +
149.29 +primrec length_' :: "'a list => real"
149.30 +where
149.31 + LENGTH_NIL: "length_' [] = 0" (*length: 'a list => nat*)
149.32 +| LENGTH_CONS: "length_' (x#xs) = 1 + length_' xs"
149.33 +
149.34 +primrec del :: "['a list, 'a] => 'a list"
149.35 +where
149.36 + del_base: "del [] x = []"
149.37 +| del_rec: "del (y#ys) x = (if x = y then ys else y#(del ys x))"
149.38 +
149.39 +definition
149.40 + list_diff :: "['a list, 'a list] => 'a list" (* as -- bs *)
149.41 + ("(_ --/ _)" [66, 66] 65)
149.42 + where "a -- b == foldl del a b"
149.43 +
149.44 +consts nth_' :: "[real, 'a list] => 'a"
149.45 +axioms
149.46 + (*** more than one non-variable in pattern in "nth_ 1 [x] = x"--*)
149.47 + NTH_NIL: "nth_' 1 (x#xs) = x"
149.48 +(* NTH_CONS: "nth_' n (x#xs) = nth_' (n+ -1) xs" *)
149.49 +
149.50 +(*rewriter does not reach base case ...... ;
149.51 + the condition involves another rule set (erls, eval_binop in Atools):*)
149.52 + NTH_CONS: "1 < n ==> nth_' n (x#xs) = nth_' (n+ - 1) xs"
149.53 +
149.54 +(*primrec from Isabelle/src/HOL/List.thy -- def.twice not allowed*)
149.55 +(*primrec*)
149.56 + hd_thm: "hd(x#xs) = x"
149.57 +(*primrec*)
149.58 + tl_Nil: "tl([]) = []"
149.59 + tl_Cons: "tl(x#xs) = xs"
149.60 +(*primrec*)
149.61 + null_Nil: "null([]) = True"
149.62 + null_Cons: "null(x#xs) = False"
149.63 +(*primrec*)
149.64 + LAST: "last(x#xs) = (if xs=[] then x else last xs)"
149.65 +(*primrec*)
149.66 + butlast_Nil: "butlast [] = []"
149.67 + butlast_Cons: "butlast(x#xs) = (if xs=[] then [] else x#butlast xs)"
149.68 +(*primrec*)
149.69 + mem_Nil: "x mem [] = False"
149.70 + mem_Cons: "x mem (y#ys) = (if y=x then True else x mem ys)"
149.71 +(*primrec-------already named---
149.72 + "set [] = {}"
149.73 + "set (x#xs) = insert x (set xs)"
149.74 + primrec
149.75 + list_all_Nil "list_all P [] = True"
149.76 + list_all_Cons "list_all P (x#xs) = (P(x) & list_all P xs)"
149.77 +----------------*)
149.78 +(*primrec*)
149.79 + map_Nil: "map f [] = []"
149.80 + map_Cons: "map f (x#xs) = f(x)#map f xs"
149.81 +(*primrec*)
149.82 + append_Nil: "[] @ys = ys"
149.83 + append_Cons: "(x#xs)@ys = x#(xs@ys)"
149.84 +(*primrec*)
149.85 + rev_Nil: "rev([]) = []"
149.86 + rev_Cons: "rev(x#xs) = rev(xs) @ [x]"
149.87 +(*primrec*)
149.88 + filter_Nil: "filter P [] = []"
149.89 + filter_Cons: "filter P (x#xs) =(if P x then x#filter P xs else filter P xs)"
149.90 +(*primrec-------already named---
149.91 + foldl_Nil "foldl f a [] = a"
149.92 + foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs"
149.93 +----------------*)
149.94 +(*primrec*)
149.95 + foldr_Nil: "foldr f [] a = a"
149.96 + foldr_Cons: "foldr f (x#xs) a = f x (foldr f xs a)"
149.97 +(*primrec*)
149.98 + concat_Nil: "concat([]) = []"
149.99 + concat_Cons: "concat(x#xs) = x @ concat(xs)"
149.100 +(*primrec-------already named---
149.101 + drop_Nil "drop n [] = []"
149.102 + drop_Cons "drop n (x#xs) = (case n of 0 => x#xs | Suc(m) => drop m xs)"
149.103 + (* Warning: simpset does not contain this definition but separate theorems
149.104 + for n=0 / n=Suc k*)
149.105 +(*primrec*)
149.106 + take_Nil "take n [] = []"
149.107 + take_Cons "take n (x#xs) = (case n of 0 => [] | Suc(m) => x # take m xs)"
149.108 + (* Warning: simpset does not contain this definition but separate theorems
149.109 + for n=0 / n=Suc k*)
149.110 +(*primrec*)
149.111 + nth_Cons "(x#xs)!n = (case n of 0 => x | (Suc k) => xs!k)"
149.112 + (* Warning: simpset does not contain this definition but separate theorems
149.113 + for n=0 / n=Suc k*)
149.114 +(*primrec*)
149.115 + " [][i:=v] = []"
149.116 + "(x#xs)[i:=v] = (case i of 0 => v # xs
149.117 + | Suc j => x # xs[j:=v])"
149.118 +----------------*)
149.119 +(*primrec*)
149.120 + takeWhile_Nil: "takeWhile P [] = []"
149.121 + takeWhile_Cons:
149.122 + "takeWhile P (x#xs) = (if P x then x#takeWhile P xs else [])"
149.123 +(*primrec*)
149.124 + dropWhile_Nil: "dropWhile P [] = []"
149.125 + dropWhile_Cons:
149.126 + "dropWhile P (x#xs) = (if P x then dropWhile P xs else x#xs)"
149.127 +(*primrec*)
149.128 + zip_Nil: "zip xs [] = []"
149.129 + zip_Cons: "zip xs (y#ys) =(case xs of [] => [] | z#zs =>(z,y)#zip zs ys)"
149.130 + (* Warning: simpset does not contain this definition but separate theorems
149.131 + for xs=[] / xs=z#zs *)
149.132 +(*primrec
149.133 + upt_0 "[i..0(] = []"
149.134 + upt_Suc "[i..(Suc j)(] = (if i <= j then [i..j(] @ [j] else [])"
149.135 +*)
149.136 +(*primrec*)
149.137 + distinct_Nil: "distinct [] = True"
149.138 + distinct_Cons: "distinct (x#xs) = (x ~: set xs & distinct xs)"
149.139 +(*primrec*)
149.140 + remdups_Nil: "remdups [] = []"
149.141 + remdups_Cons: "remdups (x#xs) =
149.142 + (if x : set xs then remdups xs else x # remdups xs)"
149.143 +(*primrec-------already named---
149.144 + replicate_0 "replicate 0 x = []"
149.145 + replicate_Suc "replicate (Suc n) x = x # replicate n x"
149.146 +----------------*)
149.147 +
149.148 +(** Lexicographic orderings on lists ...!!!**)
149.149 +
149.150 +ML{* (*the former ListC.ML*)
149.151 +(** rule set for evaluating listexpr in scripts **)
149.152 +val list_rls =
149.153 + Rls{id="list_rls",preconds = [], rew_ord = ("dummy_ord",dummy_ord),
149.154 + erls = e_rls, srls = Erls, calc = [], (*asm_thm=[],*)
149.155 + rules = (*8.01: copied from*)
149.156 + [Thm ("refl", num_str refl), (*'a<>b -> FALSE' by fun eval_equal*)
149.157 + Thm ("o_apply", num_str @{thm o_apply}),
149.158 +
149.159 + Thm ("NTH_CONS",num_str @{thm NTH_CONS}),(*erls for cond. in Atools.ML*)
149.160 + Thm ("NTH_NIL",num_str @{thm NTH_NIL}),
149.161 + Thm ("append_Cons",num_str @{thm append_Cons}),
149.162 + Thm ("append_Nil",num_str @{thm append_Nil}),
149.163 + Thm ("butlast_Cons",num_str @{thm butlast_Cons}),
149.164 + Thm ("butlast_Nil",num_str @{thm butlast_Nil}),
149.165 + Thm ("concat_Cons",num_str @{thm concat_Cons}),
149.166 + Thm ("concat_Nil",num_str @{thm concat_Nil}),
149.167 + Thm ("del_base",num_str @{thm del_base}),
149.168 + Thm ("del_rec",num_str @{thm del_rec}),
149.169 +
149.170 + Thm ("distinct_Cons",num_str @{thm distinct_Cons}),
149.171 + Thm ("distinct_Nil",num_str @{thm distinct_Nil}),
149.172 + Thm ("dropWhile_Cons",num_str @{thm dropWhile_Cons}),
149.173 + Thm ("dropWhile_Nil",num_str @{thm dropWhile_Nil}),
149.174 + Thm ("filter_Cons",num_str @{thm filter_Cons}),
149.175 + Thm ("filter_Nil",num_str @{thm filter_Nil}),
149.176 + Thm ("foldr_Cons",num_str @{thm foldr_Cons}),
149.177 + Thm ("foldr_Nil",num_str @{thm foldr_Nil}),
149.178 + Thm ("hd_thm",num_str @{thm hd_thm}),
149.179 + Thm ("LAST",num_str @{thm LAST}),
149.180 + Thm ("LENGTH_CONS",num_str @{thm LENGTH_CONS}),
149.181 + Thm ("LENGTH_NIL",num_str @{thm LENGTH_NIL}),
149.182 + Thm ("list_diff_def",num_str @{thm list_diff_def}),
149.183 + Thm ("map_Cons",num_str @{thm map_Cons}),
149.184 + Thm ("map_Nil",num_str @{thm map_Cons}),
149.185 + Thm ("mem_Cons",num_str @{thm mem_Cons}),
149.186 + Thm ("mem_Nil",num_str @{thm mem_Nil}),
149.187 + Thm ("null_Cons",num_str @{thm null_Cons}),
149.188 + Thm ("null_Nil",num_str @{thm null_Nil}),
149.189 + Thm ("remdups_Cons",num_str @{thm remdups_Cons}),
149.190 + Thm ("remdups_Nil",num_str @{thm remdups_Nil}),
149.191 + Thm ("rev_Cons",num_str @{thm rev_Cons}),
149.192 + Thm ("rev_Nil",num_str @{thm rev_Nil}),
149.193 + Thm ("take_Nil",num_str @{thm take_Nil}),
149.194 + Thm ("take_Cons",num_str @{thm take_Cons}),
149.195 + Thm ("tl_Cons",num_str @{thm tl_Cons}),
149.196 + Thm ("tl_Nil",num_str @{thm tl_Nil}),
149.197 + Thm ("zip_Cons",num_str @{thm zip_Cons}),
149.198 + Thm ("zip_Nil",num_str @{thm zip_Nil})
149.199 + ], scr = EmptyScr}:rls;
149.200 +*}
149.201 +
149.202 +ML{*
149.203 +ruleset' := overwritelthy @{theory} (!ruleset',
149.204 + [("list_rls",list_rls)
149.205 + ]);
149.206 +*}
149.207 +end
150.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
150.2 +++ b/src/Tools/isac/ProgLang/Real2002-theorems.sml Wed Aug 25 16:20:07 2010 +0200
150.3 @@ -0,0 +1,1005 @@
150.4 +(*WN060306 from isabelle-users:
150.5 +put expressions involving plus and minus into a canonical form. Here is a possible set of
150.6 +rules:
150.7 +
150.8 + add_assoc add_commute
150.9 + diff_def minus_add_distrib
150.10 + minus_minus minus_zero
150.11 +===========================================================================*)
150.12 +
150.13 +(*
150.14 + cd ~/Isabelle2002/src/HOL/Real
150.15 + grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml
150.16 + WN 9.8.02
150.17 +
150.18 +ML> thy;
150.19 +val it =
150.20 + {ProtoPure, CPure, HOL, Set, Typedef, Fun, Product_Type, Lfp, Gfp, Sum_Type,
150.21 + Relation, Record, Inductive, Transitive_Closure, Wellfounded_Recursion,
150.22 + NatDef, Nat, NatArith, Divides, Power, SetInterval, Finite_Set, Equiv,
150.23 + IntDef, Int, Datatype_Universe, Datatype, Numeral, Bin, IntArith,
150.24 + Wellfounded_Relations, Recdef, IntDiv, IntPower, NatBin, NatSimprocs,
150.25 + Relation_Power, PreList, List, Map, Hilbert_Choice, Main, Lubs, PNat, PRat,
150.26 + PReal, RealDef, RealOrd, RealInt, RealBin, RealArith0, RealArith,
150.27 + RComplete, RealAbs, RealPow, Ring_and_Field, Complex_Numbers, Real}
150.28 + : theory
150.29 +
150.30 +theories with their respective theorems found by
150.31 +grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml;
150.32 +theories listed in the the order as found in Real.thy above
150.33 +
150.34 +comments
150.35 + (**)"...theorem..." : first choice for one of the rule-sets
150.36 + "...theorem..."(*??*): to be investigated
150.37 + "...theorem... : just for documenting the contents
150.38 +*)
150.39 +
150.40 +Lubs.ML:qed -----------------------------------------------------------------
150.41 + "setleI"; "ALL y::?'a:?S::?'a set. y <= (?x::?'a) ==> ?S *<= ?x"
150.42 + "setleD"; "[| (?S::?'a set) *<= (?x::?'a); (?y::?'a) : ?S |] ==> ?y <= ?x"
150.43 + "setgeI"; "Ball (?S::?'a set) (op <= (?x::?'a)) ==> ?x <=* ?S"
150.44 + "setgeD"; "[| (?x::?'a) <=* (?S::?'a set); (?y::?'a) : ?S |] ==> ?x <= ?y"
150.45 + "leastPD1";
150.46 + "leastPD2";
150.47 + "leastPD3";
150.48 + "isLubD1";
150.49 + "isLubD1a";
150.50 + "isLub_isUb";
150.51 + "isLubD2";
150.52 + "isLubD3";
150.53 + "isLubI1";
150.54 + "isLubI2";
150.55 + "isUbD";
150.56 + "[| isUb (?R::?'a set) (?S::?'a set) (?x::?'a); (?y::?'a) : ?S |]
150.57 + ==> ?y <= ?x" "isUbD2";
150.58 + "isUbD2a";
150.59 + "isUbI";
150.60 + "isLub_le_isUb";
150.61 + "isLub_ubs";
150.62 +PNat.ML:qed ------------------------------------------------------------------
150.63 + "pnat_fun_mono"; "mono (%X::nat set. {Suc (0::nat)} Un Suc ` X)"
150.64 + "one_RepI"; "Suc (0::nat) : pnat"
150.65 + "pnat_Suc_RepI";
150.66 + "two_RepI";
150.67 + "PNat_induct";
150.68 + "[| (?i::nat) : pnat; (?P::nat => bool) (Suc (0::nat));
150.69 + !!j::nat. [| j : pnat; ?P j |] ==> ?P (Suc j) |] ==> ?P ?i"
150.70 + "pnat_induct";
150.71 + "[| (?P::pnat => bool) (1::pnat); !!n::pnat. ?P n ==> ?P (pSuc n) |]
150.72 + ==> ?P (?n::pnat)"
150.73 + "pnat_diff_induct";
150.74 + "pnatE";
150.75 + "inj_on_Abs_pnat";
150.76 + "inj_Rep_pnat";
150.77 + "zero_not_mem_pnat";
150.78 + "mem_pnat_gt_zero";
150.79 + "gt_0_mem_pnat";
150.80 + "mem_pnat_gt_0_iff";
150.81 + "Rep_pnat_gt_zero";
150.82 + "pnat_add_commute"; "(?x::pnat) + (?y::pnat) = ?y + ?x"
150.83 + "Collect_pnat_gt_0";
150.84 + "pSuc_not_one";
150.85 + "inj_pSuc";
150.86 + "pSuc_pSuc_eq";
150.87 + "n_not_pSuc_n";
150.88 + "not1_implies_pSuc";
150.89 + "pSuc_is_plus_one";
150.90 + "sum_Rep_pnat";
150.91 + "sum_Rep_pnat_sum";
150.92 + "pnat_add_assoc";
150.93 + "pnat_add_left_commute";
150.94 + "pnat_add_left_cancel";
150.95 + "pnat_add_right_cancel";
150.96 + "pnat_no_add_ident";
150.97 + "pnat_less_not_refl";
150.98 + "pnat_less_not_refl2";
150.99 + "Rep_pnat_not_less0";
150.100 + "Rep_pnat_not_less_one";
150.101 + "Rep_pnat_gt_implies_not0";
150.102 + "pnat_less_linear";
150.103 + "Rep_pnat_le_one";
150.104 + "lemma_less_ex_sum_Rep_pnat";
150.105 + "pnat_le_iff_Rep_pnat_le";
150.106 + "pnat_add_left_cancel_le";
150.107 + "pnat_add_left_cancel_less";
150.108 + "pnat_add_lessD1";
150.109 + "pnat_not_add_less1";
150.110 + "pnat_not_add_less2";
150.111 +PNat.ML:qed_spec_mp
150.112 + "pnat_add_leD1";
150.113 + "pnat_add_leD2";
150.114 +PNat.ML:qed
150.115 + "pnat_less_add_eq_less";
150.116 + "pnat_less_iff";
150.117 + "pnat_linear_Ex_eq";
150.118 + "pnat_eq_lessI";
150.119 + "Rep_pnat_mult_1";
150.120 + "Rep_pnat_mult_1_right";
150.121 + "mult_Rep_pnat";
150.122 + "mult_Rep_pnat_mult";
150.123 + "pnat_mult_commute"; "(?m::pnat) * (?n::pnat) = ?n * ?m"
150.124 + "pnat_add_mult_distrib";
150.125 + "pnat_add_mult_distrib2";
150.126 + "pnat_mult_assoc";
150.127 + "pnat_mult_left_commute";
150.128 + "pnat_mult_1";
150.129 + "pnat_mult_1_left";
150.130 + "pnat_mult_less_mono2";
150.131 + "pnat_mult_less_mono1";
150.132 + "pnat_mult_less_cancel2";
150.133 + "pnat_mult_less_cancel1";
150.134 + "pnat_mult_cancel2";
150.135 + "pnat_mult_cancel1";
150.136 + "pnat_same_multI2";
150.137 + "eq_Abs_pnat";
150.138 + "pnat_one_iff";
150.139 + "pnat_two_eq";
150.140 + "inj_pnat_of_nat";
150.141 + "nat_add_one_less";
150.142 + "nat_add_one_less1";
150.143 + "pnat_of_nat_add";
150.144 + "pnat_of_nat_less_iff";
150.145 + "pnat_of_nat_mult";
150.146 +PRat.ML:qed ------------------------------------------------------------------
150.147 + "prat_trans_lemma";
150.148 + "[| (?x1.0::pnat) * (?y2.0::pnat) = (?x2.0::pnat) * (?y1.0::pnat);
150.149 + ?x2.0 * (?y3.0::pnat) = (?x3.0::pnat) * ?y2.0 |]
150.150 + ==> ?x1.0 * ?y3.0 = ?x3.0 * ?y1.0"
150.151 + "ratrel_iff";
150.152 + "ratrelI";
150.153 + "ratrelE_lemma";
150.154 + "ratrelE";
150.155 + "ratrel_refl";
150.156 + "equiv_ratrel";
150.157 + "ratrel_in_prat";
150.158 + "inj_on_Abs_prat";
150.159 + "inj_Rep_prat";
150.160 + "inj_prat_of_pnat";
150.161 + "eq_Abs_prat";
150.162 + "qinv_congruent";
150.163 + "qinv";
150.164 + "qinv_qinv";
150.165 + "inj_qinv";
150.166 + "qinv_1";
150.167 + "prat_add_congruent2_lemma";
150.168 + "prat_add_congruent2";
150.169 + "prat_add";
150.170 + "prat_add_commute";
150.171 + "prat_add_assoc";
150.172 + "prat_add_left_commute";
150.173 + "pnat_mult_congruent2";
150.174 + "prat_mult";
150.175 + "prat_mult_commute";
150.176 + "prat_mult_assoc";
150.177 + "prat_mult_left_commute";
150.178 + "prat_mult_1";
150.179 + "prat_mult_1_right";
150.180 + "prat_of_pnat_add";
150.181 + "prat_of_pnat_mult";
150.182 + "prat_mult_qinv";
150.183 + "prat_mult_qinv_right";
150.184 + "prat_qinv_ex";
150.185 + "prat_qinv_ex1";
150.186 + "prat_qinv_left_ex1";
150.187 + "prat_mult_inv_qinv";
150.188 + "prat_as_inverse_ex";
150.189 + "qinv_mult_eq";
150.190 + "prat_add_mult_distrib";
150.191 + "prat_add_mult_distrib2";
150.192 + "prat_less_iff";
150.193 + "prat_lessI";
150.194 + "prat_lessE_lemma";
150.195 + "prat_lessE";
150.196 + "prat_less_trans";
150.197 + "prat_less_not_refl";
150.198 + "prat_less_not_sym";
150.199 + "lemma_prat_dense";
150.200 + "prat_lemma_dense";
150.201 + "prat_dense";
150.202 + "prat_add_less2_mono1";
150.203 + "prat_add_less2_mono2";
150.204 + "prat_mult_less2_mono1";
150.205 + "prat_mult_left_less2_mono1";
150.206 + "lemma_prat_add_mult_mono";
150.207 + "qless_Ex";
150.208 + "lemma_prat_less_linear";
150.209 + "prat_linear";
150.210 + "prat_linear_less2";
150.211 + "lemma1_qinv_prat_less";
150.212 + "lemma2_qinv_prat_less";
150.213 + "qinv_prat_less";
150.214 + "prat_qinv_gt_1";
150.215 + "prat_qinv_is_gt_1";
150.216 + "prat_less_1_2";
150.217 + "prat_less_qinv_2_1";
150.218 + "prat_mult_qinv_less_1";
150.219 + "prat_self_less_add_self";
150.220 + "prat_self_less_add_right";
150.221 + "prat_self_less_add_left";
150.222 + "prat_self_less_mult_right";
150.223 + "prat_leI";
150.224 + "prat_leD";
150.225 + "prat_less_le_iff";
150.226 + "not_prat_leE";
150.227 + "prat_less_imp_le";
150.228 + "prat_le_imp_less_or_eq";
150.229 + "prat_less_or_eq_imp_le";
150.230 + "prat_le_eq_less_or_eq";
150.231 + "prat_le_refl";
150.232 + "prat_le_less_trans";
150.233 + "prat_le_trans";
150.234 + "not_less_not_eq_prat_less";
150.235 + "prat_add_less_mono";
150.236 + "prat_mult_less_mono";
150.237 + "prat_mult_left_le2_mono1";
150.238 + "prat_mult_le2_mono1";
150.239 + "qinv_prat_le";
150.240 + "prat_add_left_le2_mono1";
150.241 + "prat_add_le2_mono1";
150.242 + "prat_add_le_mono";
150.243 + "prat_add_right_less_cancel";
150.244 + "prat_add_left_less_cancel";
150.245 + "Abs_prat_mult_qinv";
150.246 + "lemma_Abs_prat_le1";
150.247 + "lemma_Abs_prat_le2";
150.248 + "lemma_Abs_prat_le3";
150.249 + "pre_lemma_gleason9_34";
150.250 + "pre_lemma_gleason9_34b";
150.251 + "prat_of_pnat_less_iff";
150.252 + "lemma_prat_less_1_memEx";
150.253 + "lemma_prat_less_1_set_non_empty";
150.254 + "empty_set_psubset_lemma_prat_less_1_set";
150.255 + "lemma_prat_less_1_not_memEx";
150.256 + "lemma_prat_less_1_set_not_rat_set";
150.257 + "lemma_prat_less_1_set_psubset_rat_set";
150.258 + "preal_1";
150.259 + "{x::prat. x < prat_of_pnat (Abs_pnat (Suc (0::nat)))}
150.260 + : {A::prat set.
150.261 + {} < A &
150.262 + A < UNIV &
150.263 + (ALL y::prat:A. (ALL z::prat. z < y --> z : A) & Bex A (op < y))}"
150.264 +PReal.ML:qed -----------------------------------------------------------------
150.265 + "inj_on_Abs_preal"; "inj_on Abs_preal preal"
150.266 + "inj_Rep_preal";
150.267 + "empty_not_mem_preal";
150.268 + "one_set_mem_preal";
150.269 + "preal_psubset_empty";
150.270 + "Rep_preal_psubset_empty";
150.271 + "mem_Rep_preal_Ex";
150.272 + "prealI1";
150.273 + "[| {} < (?A::prat set); ?A < UNIV;
150.274 + ALL y::prat:?A. (ALL z::prat. z < y --> z : ?A) & Bex ?A (op < y) |]
150.275 + ==> ?A : preal"
150.276 + "prealI2";
150.277 + "prealE_lemma";
150.278 + "prealE_lemma1";
150.279 + "prealE_lemma2";
150.280 + "prealE_lemma3";
150.281 + "prealE_lemma3a";
150.282 + "prealE_lemma3b";
150.283 + "prealE_lemma4";
150.284 + "prealE_lemma4a";
150.285 + "not_mem_Rep_preal_Ex";
150.286 + "lemma_prat_less_set_mem_preal";
150.287 + "lemma_prat_set_eq";
150.288 + "inj_preal_of_prat";
150.289 + "not_in_preal_ub";
150.290 + "preal_less_not_refl";
150.291 + "preal_not_refl2";
150.292 + "preal_less_trans";
150.293 + "preal_less_not_sym";
150.294 + "preal_linear";
150.295 + "(?r1.0::preal) < (?r2.0::preal) | ?r1.0 = ?r2.0 | ?r2.0 < ?r1.0"
150.296 + "preal_linear_less2";
150.297 + "preal_add_commute"; "(?x::preal) + (?y::preal) = ?y + ?x"
150.298 + "preal_add_set_not_empty";
150.299 + "preal_not_mem_add_set_Ex";
150.300 + "preal_add_set_not_prat_set";
150.301 + "preal_add_set_lemma3";
150.302 + "preal_add_set_lemma4";
150.303 + "preal_mem_add_set";
150.304 + "preal_add_assoc";
150.305 + "preal_add_left_commute";
150.306 + "preal_mult_commute"; "(?x::preal) * (?y::preal) = ?y * ?x"
150.307 + "preal_mult_set_not_empty";
150.308 + "preal_not_mem_mult_set_Ex";
150.309 + "preal_mult_set_not_prat_set";
150.310 + "preal_mult_set_lemma3";
150.311 + "preal_mult_set_lemma4";
150.312 + "preal_mem_mult_set";
150.313 + "preal_mult_assoc";
150.314 + "preal_mult_left_commute";
150.315 + "preal_mult_1";
150.316 + "preal_mult_1_right";
150.317 + "preal_add_assoc_cong";
150.318 + "preal_add_assoc_swap";
150.319 + "mem_Rep_preal_addD";
150.320 + "mem_Rep_preal_addI";
150.321 + "mem_Rep_preal_add_iff";
150.322 + "mem_Rep_preal_multD";
150.323 + "mem_Rep_preal_multI";
150.324 + "mem_Rep_preal_mult_iff";
150.325 + "lemma_add_mult_mem_Rep_preal";
150.326 + "lemma_add_mult_mem_Rep_preal1";
150.327 + "lemma_preal_add_mult_distrib";
150.328 + "lemma_preal_add_mult_distrib2";
150.329 + "preal_add_mult_distrib2";
150.330 + "preal_add_mult_distrib";
150.331 + "qinv_not_mem_Rep_preal_Ex";
150.332 + "lemma_preal_mem_inv_set_ex";
150.333 + "preal_inv_set_not_empty";
150.334 + "qinv_mem_Rep_preal_Ex";
150.335 + "preal_not_mem_inv_set_Ex";
150.336 + "preal_inv_set_not_prat_set";
150.337 + "preal_inv_set_lemma3";
150.338 + "preal_inv_set_lemma4";
150.339 + "preal_mem_inv_set";
150.340 + "preal_mem_mult_invD";
150.341 + "lemma1_gleason9_34";
150.342 + "lemma1b_gleason9_34";
150.343 + "lemma_gleason9_34a";
150.344 + "lemma_gleason9_34";
150.345 + "lemma1_gleason9_36";
150.346 + "lemma2_gleason9_36";
150.347 + "lemma_gleason9_36";
150.348 + "lemma_gleason9_36a";
150.349 + "preal_mem_mult_invI";
150.350 + "preal_mult_inv";
150.351 + "preal_mult_inv_right";
150.352 + "eq_Abs_preal";
150.353 + "Rep_preal_self_subset";
150.354 + "Rep_preal_sum_not_subset";
150.355 + "Rep_preal_sum_not_eq";
150.356 + "preal_self_less_add_left";
150.357 + "preal_self_less_add_right";
150.358 + "preal_leD";
150.359 + "not_preal_leE";
150.360 + "preal_leI";
150.361 + "preal_less_le_iff";
150.362 + "preal_less_imp_le";
150.363 + "preal_le_imp_less_or_eq";
150.364 + "preal_less_or_eq_imp_le";
150.365 + "preal_le_refl";
150.366 + "preal_le_trans";
150.367 + "preal_le_anti_sym";
150.368 + "preal_neq_iff";
150.369 + "preal_less_le";
150.370 + "lemma_psubset_mem";
150.371 + "lemma_psubset_not_refl";
150.372 + "psubset_trans";
150.373 + "subset_psubset_trans";
150.374 + "subset_psubset_trans2";
150.375 + "psubsetD";
150.376 + "lemma_ex_mem_less_left_add1";
150.377 + "preal_less_set_not_empty";
150.378 + "lemma_ex_not_mem_less_left_add1";
150.379 + "preal_less_set_not_prat_set";
150.380 + "preal_less_set_lemma3";
150.381 + "preal_less_set_lemma4";
150.382 + "preal_mem_less_set";
150.383 + "preal_less_add_left_subsetI";
150.384 + "lemma_sum_mem_Rep_preal_ex";
150.385 + "preal_less_add_left_subsetI2";
150.386 + "preal_less_add_left";
150.387 + "preal_less_add_left_Ex";
150.388 + "preal_add_less2_mono1";
150.389 + "preal_add_less2_mono2";
150.390 + "preal_mult_less_mono1";
150.391 + "preal_mult_left_less_mono1";
150.392 + "preal_mult_left_le_mono1";
150.393 + "preal_mult_le_mono1";
150.394 + "preal_add_left_le_mono1";
150.395 + "preal_add_le_mono1";
150.396 + "preal_add_right_less_cancel";
150.397 + "preal_add_left_less_cancel";
150.398 + "preal_add_less_iff1";
150.399 + "preal_add_less_iff2";
150.400 + "preal_add_less_mono";
150.401 + "preal_mult_less_mono";
150.402 + "preal_add_right_cancel";
150.403 + "preal_add_left_cancel";
150.404 + "preal_add_left_cancel_iff";
150.405 + "preal_add_right_cancel_iff";
150.406 + "preal_sup_mem_Ex";
150.407 + "preal_sup_set_not_empty";
150.408 + "preal_sup_not_mem_Ex";
150.409 + "preal_sup_not_mem_Ex1";
150.410 + "preal_sup_set_not_prat_set";
150.411 + "preal_sup_set_not_prat_set1";
150.412 + "preal_sup_set_lemma3";
150.413 + "preal_sup_set_lemma3_1";
150.414 + "preal_sup_set_lemma4";
150.415 + "preal_sup_set_lemma4_1";
150.416 + "preal_sup";
150.417 + "preal_sup1";
150.418 + "preal_psup_leI";
150.419 + "preal_psup_leI2";
150.420 + "preal_psup_leI2b";
150.421 + "preal_psup_leI2a";
150.422 + "psup_le_ub";
150.423 + "psup_le_ub1";
150.424 + "preal_complete";
150.425 + "lemma_preal_rat_less";
150.426 + "lemma_preal_rat_less2";
150.427 + "preal_of_prat_add";
150.428 + "lemma_preal_rat_less3";
150.429 + "lemma_preal_rat_less4";
150.430 + "preal_of_prat_mult";
150.431 + "preal_of_prat_less_iff"; "(preal_of_prat ?p < preal_of_prat ?q) = (?p < ?q)"
150.432 +RealDef.ML:qed ---------------------------------------------------------------
150.433 + "preal_trans_lemma";
150.434 + "realrel_iff";
150.435 + "realrelI";
150.436 + "?x1.0 + ?y2.0 = ?x2.0 + ?y1.0 ==> ((?x1.0, ?y1.0), ?x2.0, ?y2.0) : realrel"
150.437 + "realrelE_lemma";
150.438 + "realrelE";
150.439 + "realrel_refl";
150.440 + "equiv_realrel";
150.441 + "realrel_in_real";
150.442 + "inj_on_Abs_REAL";
150.443 + "inj_Rep_REAL";
150.444 + "inj_real_of_preal";
150.445 + "eq_Abs_REAL";
150.446 + "real_minus_congruent";
150.447 + "real_minus";
150.448 + "- Abs_REAL (realrel `` {(?x, ?y)}) = Abs_REAL (realrel `` {(?y, ?x)})"
150.449 + "real_minus_minus"; (**)"- (- (?z::real)) = ?z"
150.450 + "inj_real_minus"; "inj uminus"
150.451 + "real_minus_zero"; (**)"- 0 = 0"
150.452 + "real_minus_zero_iff"; (**)"(- ?x = 0) = (?x = 0)"
150.453 + "real_add_congruent2";
150.454 + "congruent2 realrel
150.455 + (%p1 p2. (%(x1, y1). (%(x2, y2). realrel `` {(x1 + x2, y1 + y2)}) p2) p1)"
150.456 + "real_add";
150.457 + "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) +
150.458 + Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) =
150.459 + Abs_REAL (realrel `` {(?x1.0 + ?x2.0, ?y1.0 + ?y2.0)})"
150.460 + "real_add_commute"; (**)"(?z::real) + (?w::real) = ?w + ?z"
150.461 + "real_add_assoc"; (**)
150.462 + "real_add_left_commute"; (**)
150.463 + "real_add_zero_left"; (**)"0 + ?z = ?z"
150.464 + "real_add_zero_right"; (**)
150.465 + "real_add_minus"; (**)"?z + - ?z = 0"
150.466 + "real_add_minus_left"; (**)
150.467 + "real_add_minus_cancel"; (**)"?z + (- ?z + ?w) = ?w"
150.468 + "real_minus_add_cancel"; (**)"- ?z + (?z + ?w) = ?w"
150.469 + "real_minus_ex"; "EX y. ?x + y = 0"
150.470 + "real_minus_ex1";
150.471 + "real_minus_left_ex1"; "EX! y. y + ?x = 0"
150.472 + "real_add_minus_eq_minus";"?x + ?y = 0 ==> ?x = - ?y"
150.473 + "real_as_add_inverse_ex"; "EX y. ?x = - y"
150.474 + "real_minus_add_distrib"; (**)"- (?x + ?y) = - ?x + - ?y"
150.475 + "real_add_left_cancel"; "(?x + ?y = ?x + ?z) = (?y = ?z)"
150.476 + "real_add_right_cancel"; "(?y + ?x = ?z + ?x) = (?y = ?z)"
150.477 + "real_diff_0"; (**)"0 - ?x = - ?x"
150.478 + "real_diff_0_right"; (**)"?x - 0 = ?x"
150.479 + "real_diff_self"; (**)"?x - ?x = 0"
150.480 + "real_mult_congruent2_lemma";
150.481 + "real_mult_congruent2";
150.482 + "congruent2 realrel
150.483 + (%p1 p2.
150.484 + (%(x1, y1).
150.485 + (%(x2, y2). realrel `` {(x1 * x2 + y1 * y2, x1 * y2 + x2 * y1)})
150.486 + p2) p1)"
150.487 + "real_mult";
150.488 + "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) *
150.489 + Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) =
150.490 + Abs_REAL
150.491 + (realrel ``
150.492 + {(?x1.0 * ?x2.0 + ?y1.0 * ?y2.0, ?x1.0 * ?y2.0 + ?x2.0 * ?y1.0)})"
150.493 + "real_mult_commute"; (**)"?z * ?w = ?w * ?z"
150.494 + "real_mult_assoc"; (**)
150.495 + "real_mult_left_commute";
150.496 + (**)"?z1.0 * (?z2.0 * ?z3.0) = ?z2.0 * (?z1.0 * ?z3.0)"
150.497 + "real_mult_1"; (**)"1 * ?z = ?z"
150.498 + "real_mult_1_right"; (**)"?z * 1 = ?z"
150.499 + "real_mult_0"; (**)
150.500 + "real_mult_0_right"; (**)"?z * 0 = 0"
150.501 + "real_mult_minus_eq1"; (**)"- ?x * ?y = - (?x * ?y)"
150.502 + "real_mult_minus_eq2"; (**)"?x * - ?y = - (?x * ?y)"
150.503 + "real_mult_minus_1"; (**)"- 1 * ?z = - ?z"
150.504 + "real_mult_minus_1_right";(**)"?z * - 1 = - ?z"
150.505 + "real_minus_mult_cancel"; (**)"- ?x * - ?y = ?x * ?y"
150.506 + "real_minus_mult_commute";(**)"- ?x * ?y = ?x * - ?y"
150.507 + "real_add_assoc_cong";
150.508 + "?z + ?v = ?z' + ?v' ==> ?z + (?v + ?w) = ?z' + (?v' + ?w)"
150.509 + "real_add_assoc_swap"; (**)"?z + (?v + ?w) = ?v + (?z + ?w)"
150.510 + "real_add_mult_distrib"; (**)"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"
150.511 + "real_add_mult_distrib2"; (**)"?w * (?z1.0 + ?z2.0) = ?w * ?z1.0 + ?w * ?z2.0"
150.512 + "real_diff_mult_distrib"; (**)"(?z1.0 - ?z2.0) * ?w = ?z1.0 * ?w - ?z2.0 * ?w"
150.513 + "real_diff_mult_distrib2";(**)"?w * (?z1.0 - ?z2.0) = ?w * ?z1.0 - ?w * ?z2.0"
150.514 + "real_zero_not_eq_one";
150.515 + "real_zero_iff"; "0 = Abs_REAL (realrel `` {(?x, ?x)})"
150.516 + "real_mult_inv_right_ex"; "?x ~= 0 ==> EX y. ?x * y = 1"
150.517 + "real_mult_inv_left_ex"; "?x ~= 0 ==> inverse ?x * ?x = 1"
150.518 + "real_mult_inv_left";
150.519 + "real_mult_inv_right"; "?x ~= 0 ==> ?x * inverse ?x = 1"
150.520 + "INVERSE_ZERO"; "inverse 0 = 0"
150.521 + "DIVISION_BY_ZERO"; (*NOT for adding to default simpset*)"?a / 0 = 0"
150.522 + "real_mult_left_cancel"; (**)"?c ~= 0 ==> (?c * ?a = ?c * ?b) = (?a = ?b)"
150.523 + "real_mult_right_cancel"; (**)"?c ~= 0 ==> (?a * ?c = ?b * ?c) = (?a = ?b)"
150.524 + "real_mult_left_cancel_ccontr"; "?c * ?a ~= ?c * ?b ==> ?a ~= ?b"
150.525 + "real_mult_right_cancel_ccontr"; "?a * ?c ~= ?b * ?c ==> ?a ~= ?b"
150.526 + "real_inverse_not_zero"; "?x ~= 0 ==> inverse ?x ~= 0"
150.527 + "real_mult_not_zero"; "[| ?x ~= 0; ?y ~= 0 |] ==> ?x * ?y ~= 0"
150.528 + "real_inverse_inverse"; "inverse (inverse ?x) = ?x"
150.529 + "real_inverse_1"; "inverse 1 = 1"
150.530 + "real_minus_inverse"; "inverse (- ?x) = - inverse ?x"
150.531 + "real_inverse_distrib"; "inverse (?x * ?y) = inverse ?x * inverse ?y"
150.532 + "real_times_divide1_eq"; (**)"?x * (?y / ?z) = ?x * ?y / ?z"
150.533 + "real_times_divide2_eq"; (**)"?y / ?z * ?x = ?y * ?x / ?z"
150.534 + "real_divide_divide1_eq"; (**)"?x / (?y / ?z) = ?x * ?z / ?y"
150.535 + "real_divide_divide2_eq"; (**)"?x / ?y / ?z = ?x / (?y * ?z)"
150.536 + "real_minus_divide_eq"; (**)"- ?x / ?y = - (?x / ?y)"
150.537 + "real_divide_minus_eq"; (**)"?x / - ?y = - (?x / ?y)"
150.538 + "real_add_divide_distrib"; (**)"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"
150.539 + "preal_lemma_eq_rev_sum";
150.540 + "[| ?x = ?y; ?x1.0 = ?y1.0 |] ==> ?x + ?y1.0 = ?x1.0 + ?y"
150.541 + "preal_add_left_commute_cancel";
150.542 + "?x + (?b + ?y) = ?x1.0 + (?b + ?y1.0) ==> ?x + ?y = ?x1.0 + ?y1.0"
150.543 + "preal_lemma_for_not_refl";
150.544 + "real_less_not_refl"; "~ ?R < ?R"
150.545 + "real_not_refl2";
150.546 + "preal_lemma_trans";
150.547 + "real_less_trans";
150.548 + "real_less_not_sym";
150.549 + "real_of_preal_add";
150.550 + "real_of_preal (?z1.0 + ?z2.0) = real_of_preal ?z1.0 + real_of_preal ?z2.0"
150.551 + "real_of_preal_mult";
150.552 + "real_of_preal_ExI";
150.553 + "real_of_preal_ExD";
150.554 + "real_of_preal_iff";
150.555 + "real_of_preal_trichotomy";
150.556 + "real_of_preal_trichotomyE";
150.557 + "real_of_preal_lessD";
150.558 + "real_of_preal_lessI";
150.559 + "?m1.0 < ?m2.0 ==> real_of_preal ?m1.0 < real_of_preal ?m2.0"
150.560 + "real_of_preal_less_iff1";
150.561 + "real_of_preal_minus_less_self";
150.562 + "real_of_preal_minus_less_zero";
150.563 + "real_of_preal_not_minus_gt_zero";
150.564 + "real_of_preal_zero_less";
150.565 + "real_of_preal_not_less_zero";
150.566 + "real_minus_minus_zero_less";
150.567 + "real_of_preal_sum_zero_less";
150.568 + "real_of_preal_minus_less_all";
150.569 + "real_of_preal_not_minus_gt_all";
150.570 + "real_of_preal_minus_less_rev1";
150.571 + "real_of_preal_minus_less_rev2";
150.572 + "real_of_preal_minus_less_rev_iff";
150.573 + "real_linear"; "?R1.0 < ?R2.0 | ?R1.0 = ?R2.0 | ?R2.0 < ?R1.0"
150.574 + "real_neq_iff";
150.575 + "real_linear_less2";
150.576 + "[| ?R1.0 < ?R2.0 ==> ?P; ?R1.0 = ?R2.0 ==> ?P; ?R2.0 < ?R1.0 ==> ?P |]
150.577 + ==> ?P"
150.578 + "real_leI";
150.579 + "real_leD"; "~ ?w < ?z ==> ?z <= ?w"
150.580 + "real_less_le_iff";
150.581 + "not_real_leE";
150.582 + "real_le_imp_less_or_eq";
150.583 + "real_less_or_eq_imp_le";
150.584 + "real_le_less";
150.585 + "real_le_refl"; "?w <= ?w"
150.586 + "real_le_linear";
150.587 + "real_le_trans"; "[| ?i <= ?j; ?j <= ?k |] ==> ?i <= ?k"
150.588 + "real_le_anti_sym"; "[| ?z <= ?w; ?w <= ?z |] ==> ?z = ?w"
150.589 + "not_less_not_eq_real_less";
150.590 + "real_less_le"; "(?w < ?z) = (?w <= ?z & ?w ~= ?z)"
150.591 + "real_minus_zero_less_iff";
150.592 + "real_minus_zero_less_iff2";
150.593 + "real_less_add_positive_left_Ex";
150.594 + "real_less_sum_gt_zero"; "?W < ?S ==> 0 < ?S + - ?W"
150.595 + "real_lemma_change_eq_subj";
150.596 + "real_sum_gt_zero_less"; "0 < ?S + - ?W ==> ?W < ?S"
150.597 + "real_less_sum_gt_0_iff"; "(0 < ?S + - ?W) = (?W < ?S)"
150.598 + "real_less_eq_diff"; "(?x < ?y) = (?x - ?y < 0)"
150.599 + "real_add_diff_eq"; (**)"?x + (?y - ?z) = ?x + ?y - ?z"
150.600 + "real_diff_add_eq"; (**)"?x - ?y + ?z = ?x + ?z - ?y"
150.601 + "real_diff_diff_eq"; (**)"?x - ?y - ?z = ?x - (?y + ?z)"
150.602 + "real_diff_diff_eq2"; (**)"?x - (?y - ?z) = ?x + ?z - ?y"
150.603 + "real_diff_less_eq"; "(?x - ?y < ?z) = (?x < ?z + ?y)"
150.604 + "real_less_diff_eq";
150.605 + "real_diff_le_eq"; "(?x - ?y <= ?z) = (?x <= ?z + ?y)"
150.606 + "real_le_diff_eq";
150.607 + "real_diff_eq_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)"
150.608 + "real_eq_diff_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)"
150.609 + "real_less_eqI";
150.610 + "real_le_eqI";
150.611 + "real_eq_eqI"; "?x - ?y = ?x' - ?y' ==> (?x = ?y) = (?x' = ?y')"
150.612 +RealOrd.ML:qed ---------------------------------------------------------------
150.613 + "real_add_cancel_21"; "(?x + (?y + ?z) = ?y + ?u) = (?x + ?z = ?u)"
150.614 + "real_add_cancel_end"; "(?x + (?y + ?z) = ?y) = (?x = - ?z)"
150.615 + "real_minus_diff_eq"; (*??*)"- (?x - ?y) = ?y - ?x"
150.616 + "real_gt_zero_preal_Ex";
150.617 + "real_gt_preal_preal_Ex";
150.618 + "real_ge_preal_preal_Ex";
150.619 + "real_less_all_preal"; "?y <= 0 ==> ALL x. ?y < real_of_preal x"
150.620 + "real_less_all_real2";
150.621 + "real_lemma_add_positive_imp_less";
150.622 + "real_ex_add_positive_left_less";"EX T. 0 < T & ?R + T = ?S ==> ?R < ?S"
150.623 + "real_less_iff_add";
150.624 + "real_of_preal_le_iff";
150.625 + "real_mult_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x * ?y"
150.626 + "neg_real_mult_order";
150.627 + "real_mult_less_0"; "[| 0 < ?x; ?y < 0 |] ==> ?x * ?y < 0"
150.628 + "real_zero_less_one"; "0 < 1"
150.629 + "real_add_right_cancel_less"; "(?v + ?z < ?w + ?z) = (?v < ?w)"
150.630 + "real_add_left_cancel_less";
150.631 + "real_add_right_cancel_le";
150.632 + "real_add_left_cancel_le";
150.633 + "real_add_less_le_mono"; "[| ?w' < ?w; ?z' <= ?z |] ==> ?w' + ?z' < ?w + ?z"
150.634 + "real_add_le_less_mono"; "[| ?w' <= ?w; ?z' < ?z |] ==> ?w' + ?z' < ?w + ?z"
150.635 + "real_add_less_mono2";
150.636 + "real_less_add_right_cancel";
150.637 + "real_less_add_left_cancel"; "?C + ?A < ?C + ?B ==> ?A < ?B"
150.638 + "real_le_add_right_cancel";
150.639 + "real_le_add_left_cancel"; "?C + ?A <= ?C + ?B ==> ?A <= ?B"
150.640 + "real_add_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x + ?y"
150.641 + "real_le_add_order";
150.642 + "real_add_less_mono";
150.643 + "real_add_left_le_mono1";
150.644 + "real_add_le_mono";
150.645 + "real_less_Ex";
150.646 + "real_add_minus_positive_less_self"; "0 < ?r ==> ?u + - ?r < ?u"
150.647 + "real_le_minus_iff"; "(- ?s <= - ?r) = (?r <= ?s)"
150.648 + "real_le_square";
150.649 + "real_of_posnat_one";
150.650 + "real_of_posnat_two";
150.651 + "real_of_posnat_add"; "real_of_posnat ?n1.0 + real_of_posnat ?n2.0 =
150.652 + real_of_posnat (?n1.0 + ?n2.0) + 1"
150.653 + "real_of_posnat_add_one";
150.654 + "real_of_posnat_Suc";
150.655 + "inj_real_of_posnat";
150.656 + "real_of_nat_zero";
150.657 + "real_of_nat_one"; "real (Suc 0) = 1"
150.658 + "real_of_nat_add";
150.659 + "real_of_nat_Suc";
150.660 + "real_of_nat_less_iff";
150.661 + "real_of_nat_le_iff";
150.662 + "inj_real_of_nat";
150.663 + "real_of_nat_ge_zero";
150.664 + "real_of_nat_mult";
150.665 + "real_of_nat_inject";
150.666 +RealOrd.ML:qed_spec_mp
150.667 + "real_of_nat_diff";
150.668 +RealOrd.ML:qed
150.669 + "real_of_nat_zero_iff";
150.670 + "real_of_nat_neg_int";
150.671 + "real_inverse_gt_0";
150.672 + "real_inverse_less_0";
150.673 + "real_mult_less_mono1";
150.674 + "real_mult_less_mono2";
150.675 + "real_mult_less_cancel1";
150.676 + "(?k * ?m < ?k * ?n) = (0 < ?k & ?m < ?n | ?k < 0 & ?n < ?m)"
150.677 + "real_mult_less_cancel2";
150.678 + "real_mult_less_iff1";
150.679 + "real_mult_less_iff2";
150.680 + "real_mult_le_cancel_iff1";
150.681 + "real_mult_le_cancel_iff2";
150.682 + "real_mult_le_less_mono1";
150.683 + "real_mult_less_mono";
150.684 + "real_mult_less_mono'";
150.685 + "real_gt_zero"; "1 <= ?x ==> 0 < ?x"
150.686 + "real_mult_self_le"; "[| 1 < ?r; 1 <= ?x |] ==> ?x <= ?r * ?x"
150.687 + "real_mult_self_le2";
150.688 + "real_inverse_less_swap";
150.689 + "real_mult_is_0";
150.690 + "real_inverse_add";
150.691 + "real_minus_zero_le_iff";
150.692 + "real_minus_zero_le_iff2";
150.693 + "real_sum_squares_cancel"; "?x * ?x + ?y * ?y = 0 ==> ?x = 0"
150.694 + "real_sum_squares_cancel2"; "?x * ?x + ?y * ?y = 0 ==> ?y = 0"
150.695 + "real_0_less_mult_iff";
150.696 + "real_0_le_mult_iff";
150.697 + "real_mult_less_0_iff"; "(?x * ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)"
150.698 + "real_mult_le_0_iff";
150.699 +RealInt.ML:qed ---------------------------------------------------------------
150.700 + "real_of_int_congruent";
150.701 + "real_of_int"; "real (Abs_Integ (intrel `` {(?i, ?j)})) =
150.702 + Abs_REAL
150.703 + (realrel ``
150.704 + {(preal_of_prat (prat_of_pnat (pnat_of_nat ?i)),
150.705 + preal_of_prat (prat_of_pnat (pnat_of_nat ?j)))})"
150.706 + "inj_real_of_int";
150.707 + "real_of_int_zero";
150.708 + "real_of_one";
150.709 + "real_of_int_add"; "real ?x + real ?y = real (?x + ?y)"
150.710 + "real_of_int_minus";
150.711 + "real_of_int_diff";
150.712 + "real_of_int_mult"; "real ?x * real ?y = real (?x * ?y)"
150.713 + "real_of_int_Suc";
150.714 + "real_of_int_real_of_nat";
150.715 + "real_of_nat_real_of_int";
150.716 + "real_of_int_zero_cancel";
150.717 + "real_of_int_less_cancel";
150.718 + "real_of_int_inject";
150.719 + "real_of_int_less_mono";
150.720 + "real_of_int_less_iff";
150.721 + "real_of_int_le_iff";
150.722 +RealBin.ML:qed ---------------------------------------------------------------
150.723 + "real_number_of"; "real (number_of ?w) = number_of ?w"
150.724 + "real_numeral_0_eq_0";
150.725 + "real_numeral_1_eq_1";
150.726 + "add_real_number_of";
150.727 + "minus_real_number_of";
150.728 + "diff_real_number_of";
150.729 + "mult_real_number_of";
150.730 + "real_mult_2"; (**)"2 * ?z = ?z + ?z"
150.731 + "real_mult_2_right"; (**)"?z * 2 = ?z + ?z"
150.732 + "eq_real_number_of";
150.733 + "less_real_number_of";
150.734 + "le_real_number_of_eq_not_less";
150.735 + "real_minus_1_eq_m1"; "- 1 = -1"(*uminus.. = "-.."*)
150.736 + "real_mult_minus1"; (**)"-1 * ?z = - ?z"
150.737 + "real_mult_minus1_right"; (**)"?z * -1 = - ?z"
150.738 + "zero_less_real_of_nat_iff";"(0 < real ?n) = (0 < ?n)"
150.739 + "zero_le_real_of_nat_iff";
150.740 + "real_add_number_of_left";
150.741 + "real_mult_number_of_left";
150.742 + "number_of ?v * (number_of ?w * ?z) = number_of (bin_mult ?v ?w) * ?z"
150.743 + "real_add_number_of_diff1";
150.744 + "real_add_number_of_diff2";"number_of ?v + (?c - number_of ?w) =
150.745 + number_of (bin_add ?v (bin_minus ?w)) + ?c"
150.746 + "real_of_nat_number_of";
150.747 + "real (number_of ?v) = (if neg (number_of ?v) then 0 else number_of ?v)"
150.748 + "real_less_iff_diff_less_0"; "(?x < ?y) = (?x - ?y < 0)"
150.749 + "real_eq_iff_diff_eq_0";
150.750 + "real_le_iff_diff_le_0";
150.751 + "left_real_add_mult_distrib";
150.752 + (**)"?i * ?u + (?j * ?u + ?k) = (?i + ?j) * ?u + ?k"
150.753 + "real_eq_add_iff1";
150.754 + "(?i * ?u + ?m = ?j * ?u + ?n) = ((?i - ?j) * ?u + ?m = ?n)"
150.755 + "real_eq_add_iff2";
150.756 + "real_less_add_iff1";
150.757 + "real_less_add_iff2";
150.758 + "real_le_add_iff1";
150.759 + "real_le_add_iff2";
150.760 + "real_mult_le_mono1";
150.761 + "real_mult_le_mono2";
150.762 + "real_mult_le_mono";
150.763 + "[| ?i <= ?j; ?k <= ?l; 0 <= ?j; 0 <= ?k |] ==> ?i * ?k <= ?j * ?l"
150.764 +RealArith0.ML:qed ------------------------------------------------------------
150.765 + "real_diff_minus_eq"; (**)"?x - - ?y = ?x + ?y"
150.766 + "real_0_divide"; (**)"0 / ?x = 0"
150.767 + "real_0_less_inverse_iff"; "(0 < inverse ?x) = (0 < ?x)"
150.768 + "real_inverse_less_0_iff";
150.769 + "real_0_le_inverse_iff";
150.770 + "real_inverse_le_0_iff";
150.771 + "REAL_DIVIDE_ZERO"; "?x / 0 = 0"(*!!!*)
150.772 + "real_inverse_eq_divide";
150.773 + "real_0_less_divide_iff";"(0 < ?x / ?y) = (0 < ?x & 0 < ?y | ?x < 0 & ?y < 0)"
150.774 + "real_divide_less_0_iff";"(?x / ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)"
150.775 + "real_0_le_divide_iff";
150.776 + "real_divide_le_0_iff";
150.777 + "(?x / ?y <= 0) = ((?x <= 0 | ?y <= 0) & (0 <= ?x | 0 <= ?y))"
150.778 + "real_inverse_zero_iff";
150.779 + "real_divide_eq_0_iff"; "(?x / ?y = 0) = (?x = 0 | ?y = 0)"(*!!!*)
150.780 + "real_divide_self_eq"; "?h ~= 0 ==> ?h / ?h = 1"(**)
150.781 + "real_minus_less_minus"; "(- ?y < - ?x) = (?x < ?y)"
150.782 + "real_mult_less_mono1_neg"; "[| ?i < ?j; ?k < 0 |] ==> ?j * ?k < ?i * ?k"
150.783 + "real_mult_less_mono2_neg";
150.784 + "real_mult_le_mono1_neg";
150.785 + "real_mult_le_mono2_neg";
150.786 + "real_mult_less_cancel2";
150.787 + "real_mult_le_cancel2";
150.788 + "real_mult_less_cancel1";
150.789 + "real_mult_le_cancel1";
150.790 + "real_mult_eq_cancel1"; "(?k * ?m = ?k * ?n) = (?k = 0 | ?m = ?n)"
150.791 + "real_mult_eq_cancel2"; "(?m * ?k = ?n * ?k) = (?k = 0 | ?m = ?n)"
150.792 + "real_mult_div_cancel1"; (**)"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n"
150.793 + "real_mult_div_cancel_disj";
150.794 + "?k * ?m / (?k * ?n) = (if ?k = 0 then 0 else ?m / ?n)"
150.795 + "pos_real_le_divide_eq";
150.796 + "neg_real_le_divide_eq";
150.797 + "pos_real_divide_le_eq";
150.798 + "neg_real_divide_le_eq";
150.799 + "pos_real_less_divide_eq";
150.800 + "neg_real_less_divide_eq";
150.801 + "pos_real_divide_less_eq";
150.802 + "neg_real_divide_less_eq";
150.803 + "real_eq_divide_eq"; (**)"?z ~= 0 ==> (?x = ?y / ?z) = (?x * ?z = ?y)"
150.804 + "real_divide_eq_eq"; (**)"?z ~= 0 ==> (?y / ?z = ?x) = (?y = ?x * ?z)"
150.805 + "real_divide_eq_cancel2"; "(?m / ?k = ?n / ?k) = (?k = 0 | ?m = ?n)"
150.806 + "real_divide_eq_cancel1"; "(?k / ?m = ?k / ?n) = (?k = 0 | ?m = ?n)"
150.807 + "real_inverse_less_iff";
150.808 + "real_inverse_le_iff";
150.809 + "real_divide_1"; (**)"?x / 1 = ?x"
150.810 + "real_divide_minus1"; (**)"?x / -1 = - ?x"
150.811 + "real_minus1_divide"; (**)"-1 / ?x = - (1 / ?x)"
150.812 + "real_lbound_gt_zero";
150.813 + "[| 0 < ?d1.0; 0 < ?d2.0 |] ==> EX e. 0 < e & e < ?d1.0 & e < ?d2.0"
150.814 + "real_inverse_eq_iff"; "(inverse ?x = inverse ?y) = (?x = ?y)"
150.815 + "real_divide_eq_iff"; "(?z / ?x = ?z / ?y) = (?z = 0 | ?x = ?y)"
150.816 + "real_less_minus"; "(?x < - ?y) = (?y < - ?x)"
150.817 + "real_minus_less"; "(- ?x < ?y) = (- ?y < ?x)"
150.818 + "real_le_minus";
150.819 + "real_minus_le"; "(- ?x <= ?y) = (- ?y <= ?x)"
150.820 + "real_equation_minus"; (**)"(?x = - ?y) = (?y = - ?x)"
150.821 + "real_minus_equation"; (**)"(- ?x = ?y) = (- ?y = ?x)"
150.822 + "real_add_minus_iff"; (**)"(?x + - ?a = 0) = (?x = ?a)"
150.823 + "real_minus_eq_cancel"; (**)"(- ?b = - ?a) = (?b = ?a)"
150.824 + "real_add_eq_0_iff"; (**)"(?x + ?y = 0) = (?y = - ?x)"
150.825 + "real_add_less_0_iff"; "(?x + ?y < 0) = (?y < - ?x)"
150.826 + "real_0_less_add_iff";
150.827 + "real_add_le_0_iff";
150.828 + "real_0_le_add_iff";
150.829 + "real_0_less_diff_iff"; "(0 < ?x - ?y) = (?y < ?x)"
150.830 + "real_0_le_diff_iff";
150.831 + "real_minus_diff_eq"; (**)"- (?x - ?y) = ?y - ?x"
150.832 + "real_less_half_sum"; "?x < ?y ==> ?x < (?x + ?y) / 2"
150.833 + "real_gt_half_sum";
150.834 + "real_dense"; "?x < ?y ==> EX r. ?x < r & r < ?y"
150.835 +RealArith ///!!!///-----------------------------------------------------------
150.836 +RComplete.ML:qed -------------------------------------------------------------
150.837 + "real_sum_of_halves"; (**)"?x / 2 + ?x / 2 = ?x"
150.838 + "real_sup_lemma1";
150.839 + "real_sup_lemma2";
150.840 + "posreal_complete";
150.841 + "real_isLub_unique";
150.842 + "real_order_restrict";
150.843 + "posreals_complete";
150.844 + "real_sup_lemma3";
150.845 + "lemma_le_swap2";
150.846 + "lemma_real_complete2b";
150.847 + "reals_complete";
150.848 + "real_of_nat_Suc_gt_zero";
150.849 + "reals_Archimedean"; "0 < ?x ==> EX n. inverse (real (Suc n)) < ?x"
150.850 + "reals_Archimedean2";
150.851 +RealAbs.ML:qed
150.852 + "abs_nat_number_of";
150.853 + "abs (number_of ?v) =
150.854 + (if neg (number_of ?v) then number_of (bin_minus ?v) else number_of ?v)"
150.855 + "abs_split";
150.856 + "abs_iff";
150.857 + "abs_zero"; "abs 0 = 0"
150.858 + "abs_one";
150.859 + "abs_eqI1";
150.860 + "abs_eqI2";
150.861 + "abs_minus_eqI2";
150.862 + "abs_minus_eqI1";
150.863 + "abs_ge_zero"; "0 <= abs ?x"
150.864 + "abs_idempotent"; "abs (abs ?x) = abs ?x"
150.865 + "abs_zero_iff"; "(abs ?x = 0) = (?x = 0)"
150.866 + "abs_ge_self"; "?x <= abs ?x"
150.867 + "abs_ge_minus_self";
150.868 + "abs_mult"; "abs (?x * ?y) = abs ?x * abs ?y"
150.869 + "abs_inverse"; "abs (inverse ?x) = inverse (abs ?x)"
150.870 + "abs_mult_inverse";
150.871 + "abs_triangle_ineq"; "abs (?x + ?y) <= abs ?x + abs ?y"
150.872 + "abs_triangle_ineq_four";
150.873 + "abs_minus_cancel";
150.874 + "abs_minus_add_cancel";
150.875 + "abs_triangle_minus_ineq";
150.876 +RealAbs.ML:qed_spec_mp
150.877 + "abs_add_less"; "[| abs ?x < ?r; abs ?y < ?s |] ==> abs (?x + ?y) < ?r + ?s"
150.878 +RealAbs.ML:qed
150.879 + "abs_add_minus_less";
150.880 + "real_mult_0_less"; "(0 * ?x < ?r) = (0 < ?r)"
150.881 + "real_mult_less_trans";
150.882 + "real_mult_le_less_trans";
150.883 + "abs_mult_less";
150.884 + "abs_mult_less2";
150.885 + "abs_less_gt_zero";
150.886 + "abs_minus_one"; "abs -1 = 1"
150.887 + "abs_disj"; "abs ?x = ?x | abs ?x = - ?x"
150.888 + "abs_interval_iff";
150.889 + "abs_le_interval_iff";
150.890 + "abs_add_pos_gt_zero";
150.891 + "abs_add_one_gt_zero";
150.892 + "abs_not_less_zero";
150.893 + "abs_circle"; "abs ?h < abs ?y - abs ?x ==> abs (?x + ?h) < abs ?y"
150.894 + "abs_le_zero_iff";
150.895 + "real_0_less_abs_iff";
150.896 + "abs_real_of_nat_cancel";
150.897 + "abs_add_one_not_less_self";
150.898 + "abs_triangle_ineq_three"; "abs (?w + ?x + ?y) <= abs ?w + abs ?x + abs ?y"
150.899 + "abs_diff_less_imp_gt_zero";
150.900 + "abs_diff_less_imp_gt_zero2";
150.901 + "abs_diff_less_imp_gt_zero3";
150.902 + "abs_diff_less_imp_gt_zero4";
150.903 + "abs_triangle_ineq_minus_cancel";
150.904 + "abs_sum_triangle_ineq";
150.905 + "abs (?x + ?y + (- ?l + - ?m)) <= abs (?x + - ?l) + abs (?y + - ?m)"
150.906 +RealPow.ML:qed
150.907 + "realpow_zero"; "0 ^ Suc ?n = 0"
150.908 +RealPow.ML:qed_spec_mp
150.909 + "realpow_not_zero"; "?r ~= 0 ==> ?r ^ ?n ~= 0"
150.910 + "realpow_zero_zero"; "?r ^ ?n = 0 ==> ?r = 0"
150.911 + "realpow_inverse"; "inverse (?r ^ ?n) = inverse ?r ^ ?n"
150.912 + "realpow_abs"; "abs (?r ^ ?n) = abs ?r ^ ?n"
150.913 + "realpow_add"; (**)"?r ^ (?n + ?m) = ?r ^ ?n * ?r ^ ?m"
150.914 + "realpow_one"; (**)"?r ^ 1 = ?r"
150.915 + "realpow_two"; (**)"?r ^ Suc (Suc 0) = ?r * ?r"
150.916 +RealPow.ML:qed_spec_mp
150.917 + "realpow_gt_zero"; "0 < ?r ==> 0 < ?r ^ ?n"
150.918 + "realpow_ge_zero"; "0 <= ?r ==> 0 <= ?r ^ ?n"
150.919 + "realpow_le"; "0 <= ?x & ?x <= ?y ==> ?x ^ ?n <= ?y ^ ?n"
150.920 + "realpow_less";
150.921 +RealPow.ML:qed
150.922 + "realpow_eq_one"; (**)"1 ^ ?n = 1"
150.923 + "abs_realpow_minus_one"; "abs (-1 ^ ?n) = 1"
150.924 + "realpow_mult"; (**)"(?r * ?s) ^ ?n = ?r ^ ?n * ?s ^ ?n"
150.925 + "realpow_two_le"; "0 <= ?r ^ Suc (Suc 0)"
150.926 + "abs_realpow_two";
150.927 + "realpow_two_abs"; "abs ?x ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)"
150.928 + "realpow_two_gt_one";
150.929 +RealPow.ML:qed_spec_mp
150.930 + "realpow_ge_one"; "1 < ?r ==> 1 <= ?r ^ ?n"
150.931 +RealPow.ML:qed
150.932 + "realpow_ge_one2";
150.933 + "two_realpow_ge_one";
150.934 + "two_realpow_gt";
150.935 + "realpow_minus_one"; (**)"-1 ^ (2 * ?n) = 1"
150.936 + "realpow_minus_one_odd"; "-1 ^ Suc (2 * ?n) = - 1"
150.937 + "realpow_minus_one_even";
150.938 +RealPow.ML:qed_spec_mp
150.939 + "realpow_Suc_less";
150.940 + "realpow_Suc_le"; "0 <= ?r & ?r < 1 ==> ?r ^ Suc ?n <= ?r ^ ?n"
150.941 +RealPow.ML:qed
150.942 + "realpow_zero_le"; "0 <= 0 ^ ?n"
150.943 +RealPow.ML:qed_spec_mp
150.944 + "realpow_Suc_le2";
150.945 +RealPow.ML:qed
150.946 + "realpow_Suc_le3";
150.947 +RealPow.ML:qed_spec_mp
150.948 + "realpow_less_le"; "0 <= ?r & ?r < 1 & ?n < ?N ==> ?r ^ ?N <= ?r ^ ?n"
150.949 +RealPow.ML:qed
150.950 + "realpow_le_le"; "[| 0 <= ?r; ?r < 1; ?n <= ?N |] ==> ?r ^ ?N <= ?r ^ ?n"
150.951 + "realpow_Suc_le_self";
150.952 + "realpow_Suc_less_one";
150.953 +RealPow.ML:qed_spec_mp
150.954 + "realpow_le_Suc";
150.955 + "realpow_less_Suc";
150.956 + "realpow_le_Suc2";
150.957 + "realpow_gt_ge";
150.958 + "realpow_gt_ge2";
150.959 +RealPow.ML:qed
150.960 + "realpow_ge_ge"; "[| 1 < ?r; ?n <= ?N |] ==> ?r ^ ?n <= ?r ^ ?N"
150.961 + "realpow_ge_ge2";
150.962 +RealPow.ML:qed_spec_mp
150.963 + "realpow_Suc_ge_self";
150.964 + "realpow_Suc_ge_self2";
150.965 +RealPow.ML:qed
150.966 + "realpow_ge_self";
150.967 + "realpow_ge_self2";
150.968 +RealPow.ML:qed_spec_mp
150.969 + "realpow_minus_mult"; "0 < ?n ==> ?x ^ (?n - 1) * ?x = ?x ^ ?n"
150.970 + "realpow_two_mult_inverse";
150.971 + "?r ~= 0 ==> ?r * inverse ?r ^ Suc (Suc 0) = inverse ?r"
150.972 + "realpow_two_minus"; "(- ?x) ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)"
150.973 + "realpow_two_diff";
150.974 + "realpow_two_disj";
150.975 + "realpow_diff";
150.976 + "[| ?x ~= 0; ?m <= ?n |] ==> ?x ^ (?n - ?m) = ?x ^ ?n * inverse (?x ^ ?m)"
150.977 + "realpow_real_of_nat";
150.978 + "realpow_real_of_nat_two_pos"; "0 < real (Suc (Suc 0) ^ ?n)"
150.979 +RealPow.ML:qed_spec_mp
150.980 + "realpow_increasing";
150.981 + "realpow_Suc_cancel_eq";
150.982 + "[| 0 <= ?x; 0 <= ?y; ?x ^ Suc ?n = ?y ^ Suc ?n |] ==> ?x = ?y"
150.983 +RealPow.ML:qed
150.984 + "realpow_eq_0_iff"; "(?x ^ ?n = 0) = (?x = 0 & 0 < ?n)"
150.985 + "zero_less_realpow_abs_iff";
150.986 + "zero_le_realpow_abs";
150.987 + "real_of_int_power"; "real ?x ^ ?n = real (?x ^ ?n)"
150.988 + "power_real_number_of"; "number_of ?v ^ ?n = real (number_of ?v ^ ?n)"
150.989 +Ring_and_Field ---///!!!///---------------------------------------------------
150.990 +Complex_Numbers --///!!!///---------------------------------------------------
150.991 +Real -------------///!!!///---------------------------------------------------
150.992 +real_arith0.ML:qed "";
150.993 +real_arith0.ML:qed "";
150.994 +real_arith0.ML:qed "";
150.995 +real_arith0.ML:qed "";
150.996 +real_arith0.ML:qed "";
150.997 +real_arith0.ML:qed "";
150.998 +real_arith0.ML:qed "";
150.999 +real_arith0.ML:qed "";
150.1000 +real_arith0.ML:qed "";
150.1001 +
150.1002 +
150.1003 +
150.1004 +
150.1005 +
150.1006 +
150.1007 +
150.1008 +
151.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
151.2 +++ b/src/Tools/isac/ProgLang/Script.thy Wed Aug 25 16:20:07 2010 +0200
151.3 @@ -0,0 +1,194 @@
151.4 +(* Title: tactics, tacticals etc. for scripts
151.5 + Author: Walther Neuper 000224
151.6 + (c) due to copyright terms
151.7 +
151.8 +use_thy_only"ProgLang/Script";
151.9 +use_thy"../ProgLang/Script";
151.10 +use_thy"Script";
151.11 + *)
151.12 +
151.13 +theory Script imports Tools begin
151.14 +
151.15 +typedecl
151.16 + ID (* identifiers for thy, ruleset,... *)
151.17 +
151.18 +typedecl
151.19 + arg (* argument of subproblem *)
151.20 +
151.21 +consts
151.22 +
151.23 +(*types of subproblems' arguments*)
151.24 + real_' :: "real => arg"
151.25 + real_list_' :: "(real list) => arg"
151.26 + real_set_' :: "(real set) => arg"
151.27 + bool_' :: "bool => arg"
151.28 + bool_list_' :: "(bool list) => arg"
151.29 + real_real_' :: "(real => real) => arg"
151.30 +
151.31 +(*tactics*)
151.32 + Rewrite :: "[ID, bool, 'a] => 'a"
151.33 + Rewrite'_Inst:: "[(real * real) list, ID, bool, 'a] => 'a"
151.34 + ("(Rewrite'_Inst (_ _ _))" 11)
151.35 + (*without last argument ^^ for @@*)
151.36 + Rewrite'_Set :: "[ID, bool, 'a] => 'a" ("(Rewrite'_Set (_ _))" 11)
151.37 + Rewrite'_Set'_Inst
151.38 + :: "[(real * real) list, ID, bool, 'a] => 'a"
151.39 + ("(Rewrite'_Set'_Inst (_ _ _))" 11)
151.40 + (*without last argument ^^ for @@*)
151.41 + Calculate :: "[ID, 'a] => 'a" (*WN100816 PLUS, TIMES, POWER miss.in scr*)
151.42 + Calculate1 :: "[ID, 'a] => 'a" (*FIXXXME: unknown to script-interpreter*)
151.43 +
151.44 + (* WN0509 substitution now is rewriting by a list of terms (of type bool)
151.45 + Substitute :: "[(real * real) list, 'a] => 'a"*)
151.46 + Substitute :: "[bool list, 'a] => 'a"
151.47 +
151.48 + Map :: "['a => 'b, 'a list] => 'b list"
151.49 + Tac :: "ID => 'a" (*deprecated; only use in Test.ML*)
151.50 + Check'_elementwise ::
151.51 + "['a list, 'b set] => 'a list"
151.52 + ("Check'_elementwise (_ _)" 11)
151.53 + Take :: "'a => 'a" (*for non-var args as long as no 'o'*)
151.54 + SubProblem :: "[ID * ID list * ID list, arg list] => 'a"
151.55 +
151.56 + Or'_to'_List :: "bool => 'a list" ("Or'_to'_List (_)" 11)
151.57 + (*=========== record these ^^^ in 'tacs' in Script.ML =========*)
151.58 +
151.59 + Assumptions :: bool
151.60 + Problem :: "[ID * ID list] => 'a"
151.61 +
151.62 +(*special formulas for frontend 'CAS format'*)
151.63 + Subproblem :: "(ID * ID list) => 'a"
151.64 +
151.65 +(*script-expressions (tacticals)*)
151.66 + Seq :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "@@" 10) (*@ used*)
151.67 + Try :: "['a => 'a, 'a] => 'a"
151.68 + Repeat :: "['a => 'a, 'a] => 'a"
151.69 + Or :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "Or" 10)
151.70 + While :: "[bool, 'a => 'a, 'a] => 'a" ("((While (_) Do)//(_))" 9)
151.71 +(*WN100723 because of "Error in syntax translation" below...
151.72 + (*'b => bool doesn't work with "contains_root _"*)
151.73 + Letpar :: "['a, 'a => 'b] => 'b"
151.74 + (*--- defined in Isabelle/scr/HOL/HOL.thy:
151.75 + Let :: "['a, 'a => 'b] => 'b"
151.76 + "_Let" :: "[letbinds, 'a] => 'a" ("(let (_)/ in (_))" 10)
151.77 + If :: "[bool, 'a, 'a] => 'a" ("(if (_)/ then (_)/ else (_))" 10)
151.78 + %x. P x .. lambda is defined in Isabelles meta logic
151.79 + --- *)
151.80 +*)
151.81 + failtac :: 'a
151.82 + idletac :: 'a
151.83 + (*... + RECORD IN 'screxpr' in Script.ML *)
151.84 +
151.85 +(*for scripts generated automatically from rls*)
151.86 + Stepwise :: "['z, 'z] => 'z" ("((Script Stepwise (_ =))// (_))" 9)
151.87 + Stepwise'_inst:: "['z,real,'z] => 'z"
151.88 + ("((Script Stepwise'_inst (_ _ =))// (_))" 9)
151.89 +
151.90 +
151.91 +(*SHIFT -> resp.thys ----vvv---------------------------------------------*)
151.92 +(*script-names: initial capital letter,
151.93 + type of last arg (=script-body) == result-type !
151.94 + Xxxx :: script ids, duplicate result-type 'r in last argument:
151.95 + "['a, ... , \
151.96 + \ 'r] => 'r
151.97 +*)
151.98 +
151.99 +(*make'_solution'_set :: "bool => bool list"
151.100 + ("(make'_solution'_set (_))" 11)
151.101 +
151.102 + max'_on'_interval
151.103 + :: "[ID * (ID list) * ID, bool,real,real set] => real"
151.104 + ("(max'_on'_interval (_)/ (_ _ _))" 9)
151.105 + find'_vals
151.106 + :: "[ID * (ID list) * ID,
151.107 + real,real,real,real,bool list] => bool list"
151.108 + ("(find'_vals (_)/ (_ _ _ _ _))" 9)
151.109 +
151.110 + make'_fun :: "[ID * (ID list) * ID, real,real,bool list] => bool"
151.111 + ("(make'_fun (_)/ (_ _ _))" 9)
151.112 +
151.113 + solve'_univar
151.114 + :: "[ID * (ID list) * ID, bool,real] => bool list"
151.115 + ("(solve'_univar (_)/ (_ _ ))" 9)
151.116 + solve'_univar'_err
151.117 + :: "[ID * (ID list) * ID, bool,real,bool] => bool list"
151.118 + ("(solve'_univar (_)/ (_ _ _))" 9)
151.119 +----------*)
151.120 +
151.121 + Testeq :: "[bool, bool] => bool"
151.122 + ("((Script Testeq (_ =))//
151.123 + (_))" 9)
151.124 +
151.125 + Testeq2 :: "[bool, bool list] => bool list"
151.126 + ("((Script Testeq2 (_ =))//
151.127 + (_))" 9)
151.128 +
151.129 + Testterm :: "[real, real] => real"
151.130 + ("((Script Testterm (_ =))//
151.131 + (_))" 9)
151.132 +
151.133 + Testchk :: "[bool, real, real list] => real list"
151.134 + ("((Script Testchk (_ _ =))//
151.135 + (_))" 9)
151.136 + (*... + RECORD IN 'subpbls' in Script.ML *)
151.137 +(*SHIFT -> resp.thys ----^^^----------------------------*)
151.138 +
151.139 +(*Makarius 10.03
151.140 +syntax
151.141 +
151.142 + "_Letpar" :: "[letbinds, 'a] => 'a" ("(letpar (_)/ in (_))" 10)
151.143 +
151.144 +translations
151.145 +
151.146 + "_Letpar (_binds b bs) e" == "_Letpar b (_Letpar bs e)"
151.147 + "letpar x = a in e" == "Letpar a (%x. e)"
151.148 +*** Error in syntax translation rule: rhs contains extra variables
151.149 +*** ("_Letpar" ("_bind" x a) e) -> (Letpar a ("_abs" x e))
151.150 +*** At command "translations" (line 140 of "/usr/local/isabisac/src/Pure/isac/Scripts/Script.thy").
151.151 +*)
151.152 +
151.153 +ML {* (*the former Script.ML*)
151.154 +
151.155 +(*.record all theories defined for Scripts; in order to distinguish them
151.156 + from general IsacKnowledge defined later on.*)
151.157 +script_thys := !theory';
151.158 +
151.159 +(*--vvv----- SHIFT? or delete ?*)
151.160 +val IDTyp = Type("Script.ID",[]);
151.161 +
151.162 +
151.163 +val tacs = ref (distinct (remove op = ""
151.164 + ["Calculate",
151.165 + "Rewrite","Rewrite'_Inst","Rewrite'_Set","Rewrite'_Set'_Inst",
151.166 + "Substitute","Tac","Check'_elementswise",
151.167 + "Take","Subproblem","Or'_to'_List"]));
151.168 +
151.169 +val screxpr = ref (distinct (remove op = ""
151.170 + ["Let","If","Repeat","While","Try","Or"]));
151.171 +
151.172 +val listfuns = ref [(*_all_ functions in Isa99.List.thy *)
151.173 + "@","filter","concat","foldl","hd","last","set","list_all",
151.174 + "map","mem","nth","list_update","take","drop",
151.175 + "takeWhile","dropWhile","tl","butlast",
151.176 + "rev","zip","upt","remdups","nodups","replicate",
151.177 +
151.178 + "Cons","Nil"];
151.179 +
151.180 +val scrfuns = ref (distinct (remove op = ""
151.181 + ["Testvar"]));
151.182 +
151.183 +val listexpr = ref (union op = (!listfuns) (!scrfuns));
151.184 +
151.185 +val notsimp = ref
151.186 + (distinct (remove op = ""
151.187 + (!tacs @ !screxpr @ (*!subpbls @*) !scrfuns @ !listfuns)));
151.188 +
151.189 +val negotiable = ref ((!tacs (*@ !subpbls*)));
151.190 +
151.191 +val tacpbl = ref
151.192 + (distinct (remove op = "" (!tacs (*@ !subpbls*))));
151.193 +(*--^^^----- SHIFT? or delete ?*)
151.194 +
151.195 +*}
151.196 +
151.197 +end
152.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
152.2 +++ b/src/Tools/isac/ProgLang/Tools.sml Wed Aug 25 16:20:07 2010 +0200
152.3 @@ -0,0 +1,113 @@
152.4 +(* = Tools.ML
152.5 + +++ outcommented tests *)
152.6 +
152.7 +
152.8 +fun eval_var (thmid:string) (op_:string)
152.9 + (t as (Const(op0,t0) $ arg)) thy =
152.10 + let
152.11 + val t' = ((list2isalist HOLogic.realT) o vars) t;
152.12 + val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg);
152.13 + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
152.14 + | eval_var _ _ _ _ = raise GO_ON;
152.15 +(*
152.16 +> val t = (term_of o the o (parse thy)) "Var (A=a*(b::real))";
152.17 +> val op_ = "Var";
152.18 +> val eval_fn = the (assoc (!eval_list, op_));
152.19 +> get_pair op_ eval_fn t;
152.20 +> val (t as (Const(op0,t0) $ arg)) = t;
152.21 +> eval_fn op0 t;
152.22 +
152.23 +> val thmid = "#Var_";
152.24 +> val (SOME(thmId,t')) = eval_var thmid op0 t;
152.25 +val it = SOME ("#Var_(A::real) = (a::real) * (b::real)",Const # $ (# $ #))
152.26 + : (string * term) option
152.27 +> Syntax.string_of_term (thy2ctxt thy) t';
152.28 +val it = "Var ((A::real) = (a::real) * (b::real)) = [A, a, b]" : string
152.29 +*)
152.30 +fun eval_Length (thmid:string) (op_:string)
152.31 + (t as (Const(op0,t0) $ arg)) thy =
152.32 + let
152.33 + val t' = ((term_of_num HOLogic.realT) o length o isalist2list) arg;
152.34 + val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg);
152.35 + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
152.36 + | eval_Length _ _ _ _ = raise GO_ON;
152.37 +(*
152.38 +> val thmid = "#Length_"; val op_ = "Length";
152.39 +> val s = "Length [A = a * b, a // #2 = #2]";
152.40 +> val (t as (Const(op0,t0) $ arg)) = (term_of o the o (parse thy)) s;
152.41 +> val (SOME (id,t')) = eval_Length thmid op_ t;
152.42 +val id = "#Length_[A = a * b, a // #2 = #2]" : string
152.43 +val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#))
152.44 +val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm
152.45 +---------------------------------------------
152.46 +> val thmid = "#Length_"; val op_ = "Length";
152.47 +> val s =
152.48 + "if #1 < Length [A = a * b, a // #2 = #2] \
152.49 + \then make_fun (R, [make, function], no_met) A a_ [A = a * b, a // #2 = #2]\
152.50 + \else hd [A = a * b, a // #2 = #2]";
152.51 +
152.52 +> (cterm_of thy) t';
152.53 +> val t = (term_of o the o (parse thy)) s;
152.54 +> val eval_fn = the (assoc (!eval_list, op_));
152.55 +> val (SOME(_,t')) = get_pair op_ eval_fn t;
152.56 +val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#))
152.57 +val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm
152.58 +
152.59 +> val ct = (the o (parse thy)) s;
152.60 +> val (SOME(_,thm)) = get_calculation thy (op_, eval_fn) ct;
152.61 +val thm = "Length [A = a * b, a // #2 = #2] = #2" [[ Free ( #2, real) !!!]]
152.62 +> rewrite_ thy tless_true e_rls false thm ct;
152.63 +("if #1 < #2
152.64 + then make_fun (R, [make, function], no_met)
152.65 + A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]",
152.66 + []) : (cterm * cterm list) option
152.67 +> val ct = (the o (parse thy)) s;
152.68 +> rewrite_set_ thy e_rls false eval_script ct;
152.69 +("if #1 < #2
152.70 + then make_fun (R, [make, function], no_met)
152.71 + A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]",
152.72 + []) : (cterm * cterm list) option
152.73 +*)
152.74 +
152.75 +fun eval_Nth (thmid:string) (op_:string) (t as
152.76 + (Const (op0,t0) $ t1 $ t2 )) thy =
152.77 +(writeln"@@@ eval_Nth";
152.78 + if is_num t1 andalso is_list t2
152.79 + then
152.80 + let
152.81 + val t' = (nth (num_of_term t1) (isalist2list t2))
152.82 + handle _ => raise GO_ON;
152.83 + val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) t1)^
152.84 + "_"^(Syntax.string_of_term (thy2ctxt thy) t2)^
152.85 + " = "^(Syntax.string_of_term (thy2ctxt thy) t');
152.86 + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
152.87 + else raise GO_ON
152.88 +)
152.89 + | eval_Nth _ _ _ _ = raise GO_ON;
152.90 +(*
152.91 +> val thmid = "#Nth_"; val op_ = "Nth";
152.92 +> val s = "Nth #2 [A = a * b, a // #2 = #2]";
152.93 +> val t = (term_of o the o (parse thy)) s;
152.94 +> eval_Nth thmid op_ t;
152.95 +
152.96 +> val eval_fn = the (assoc (!eval_list, op_));
152.97 +> val (SOME(id,t')) = get_pair op_ eval_fn t;
152.98 +> (cterm_of thy) t';
152.99 +val it = "Nth #2 [A = a * b, a // #2 = #2] = (a // #2 = #2)"
152.100 +*)
152.101 +
152.102 +
152.103 +(*17.6.00: calc_list instead eval_list*)
152.104 +eval_list:= overwritel (! eval_list,
152.105 + [("Var",eval_var "#Var_"),
152.106 + ("Length",eval_Length "#Length_"),
152.107 + ("Nth",eval_Nth "#Nth_")
152.108 + ]);
152.109 +(*17.6.00: association list for calculate_, calculate*)
152.110 +calc_list:= overwritel (! calc_list,
152.111 + [
152.112 + ("Var" ,("Var",eval_var "#Var_")),
152.113 + ("Length",("Length",eval_Length "#Length_")),
152.114 + ("Nth" ,("Nth",eval_Nth "#Nth_"))
152.115 + ]);
152.116 +
153.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
153.2 +++ b/src/Tools/isac/ProgLang/Tools.thy Wed Aug 25 16:20:07 2010 +0200
153.3 @@ -0,0 +1,230 @@
153.4 +(* auxiliary functions used in scripts
153.5 + author: Walther Neuper 000301
153.6 + WN0509 shift into Atools ?!? (because used also in where of models !)
153.7 +
153.8 + (c) copyright due to lincense terms.
153.9 +
153.10 +remove_thy"Tools";
153.11 +use_thy"ProgLang/Tools";
153.12 +*)
153.13 +
153.14 +theory Tools imports ListC begin
153.15 +
153.16 +(*belongs to theory ListC*)
153.17 +ML {*
153.18 +val first_isac_thy = @{theory ListC}
153.19 +*}
153.20 +
153.21 +(*for Descript.thy*)
153.22 +
153.23 + (***********************************************************************)
153.24 + (* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !!*)
153.25 + (***********************************************************************)
153.26 +typedecl nam (* named variables *)
153.27 +typedecl una (* unnamed variables *)
153.28 +typedecl unl (* unnamed variables of type list, elementwise input prohibited*)
153.29 +typedecl str (* structured variables *)
153.30 +typedecl toreal (* var with undef real value: forces typing *)
153.31 +typedecl toreall (* var with undef real list value: forces typing *)
153.32 +typedecl tobooll (* var with undef bool list value: forces typing *)
153.33 +typedecl unknow (* input without dsc in fmz=[] *)
153.34 +typedecl cpy (* UNUSED: copy-named variables
153.35 + identified by .._0, .._i .._' in pbt *)
153.36 + (***********************************************************************)
153.37 + (* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !!*)
153.38 + (***********************************************************************)
153.39 +
153.40 +consts
153.41 +
153.42 + UniversalList :: "bool list"
153.43 +
153.44 + lhs :: "bool => real" (*of an equality*)
153.45 + rhs :: "bool => real" (*of an equality*)
153.46 + Vars :: "'a => real list" (*get the variables of a term *)
153.47 + matches :: "['a, 'a] => bool"
153.48 + matchsub :: "['a, 'a] => bool"
153.49 +
153.50 +constdefs
153.51 +
153.52 + Testvar :: "[real, 'a] => bool" (*is a variable in a term: unused 6.5.03*)
153.53 + "Testvar v t == v mem (Vars t)" (*by rewriting only,no Calcunused 6.5.03*)
153.54 +
153.55 +ML {* (*the former Tools.ML*)
153.56 +(* auxiliary functions for scripts WN.9.00*)
153.57 +(*11.02: for equation solving only*)
153.58 +val UniversalList = (term_of o the o (parse @{theory})) "UniversalList";
153.59 +val EmptyList = (term_of o the o (parse @{theory})) "[]::bool list";
153.60 +
153.61 +(*+ for Or_to_List +*)
153.62 +fun or2list (Const ("True",_)) = (writeln"### or2list True";UniversalList)
153.63 + | or2list (Const ("False",_)) = (writeln"### or2list False";EmptyList)
153.64 + | or2list (t as Const ("op =",_) $ _ $ _) =
153.65 + (writeln"### or2list _ = _";list2isalist bool [t])
153.66 + | or2list ors =
153.67 + (writeln"### or2list _ | _";
153.68 + let fun get ls (Const ("op |",_) $ o1 $ o2) =
153.69 + case o2 of
153.70 + Const ("op |",_) $ _ $ _ => get (ls @ [o1]) o2
153.71 + | _ => ls @ [o1, o2]
153.72 + in (((list2isalist bool) o (get [])) ors)
153.73 + handle _ => raise error ("or2list: no ORs= "^(term2str ors)) end
153.74 + );
153.75 +(*>val t = HOLogic.true_const;
153.76 +> val t' = or2list t;
153.77 +> term2str t';
153.78 +"Atools.UniversalList"
153.79 +> val t = HOLogic.false_const;
153.80 +> val t' = or2list t;
153.81 +> term2str t';
153.82 +"[]"
153.83 +> val t=(term_of o the o (parse thy)) "x=3";
153.84 +> val t' = or2list t;
153.85 +> term2str t';
153.86 +"[x = 3]"
153.87 +> val t=(term_of o the o (parse thy))"(x=3) | (x=-3) | (x=0)";
153.88 +> val t' = or2list t;
153.89 +> term2str t';
153.90 +"[x = #3, x = #-3, x = #0]" : string *)
153.91 +
153.92 +
153.93 +(** evaluation on the meta-level **)
153.94 +
153.95 +(*. evaluate the predicate matches (match on whole term only) .*)
153.96 +(*("matches",("Tools.matches",eval_matches "#matches_")):calc*)
153.97 +fun eval_matches (thmid:string) "Tools.matches"
153.98 + (t as Const ("Tools.matches",_) $ pat $ tst) thy =
153.99 + if matches thy tst pat
153.100 + then let val prop = Trueprop $ (mk_equality (t, true_as_term))
153.101 + in SOME (Syntax.string_of_term @{context} prop, prop) end
153.102 + else let val prop = Trueprop $ (mk_equality (t, false_as_term))
153.103 + in SOME (Syntax.string_of_term @{context} prop, prop) end
153.104 + | eval_matches _ _ _ _ = NONE;
153.105 +(*
153.106 +> val t = (term_of o the o (parse thy))
153.107 + "matches (?x = 0) (1 * x ^^^ 2 = 0)";
153.108 +> eval_matches "/thmid/" "/op_/" t thy;
153.109 +val it =
153.110 + SOME
153.111 + ("matches (x = 0) (1 * x ^^^ 2 = 0) = False",
153.112 + Const (#,#) $ (# $ # $ Const #)) : (string * term) option
153.113 +
153.114 +> val t = (term_of o the o (parse thy))
153.115 + "matches (?a = #0) (#1 * x ^^^ #2 = #0)";
153.116 +> eval_matches "/thmid/" "/op_/" t thy;
153.117 +val it =
153.118 + SOME
153.119 + ("matches (?a = #0) (#1 * x ^^^ #2 = #0) = True",
153.120 + Const (#,#) $ (# $ # $ Const #)) : (string * term) option
153.121 +
153.122 +> val t = (term_of o the o (parse thy))
153.123 + "matches (?a * x = #0) (#1 * x ^^^ #2 = #0)";
153.124 +> eval_matches "/thmid/" "/op_/" t thy;
153.125 +val it =
153.126 + SOME
153.127 + ("matches (?a * x = #0) (#1 * x ^^^ #2 = #0) = False",
153.128 + Const (#,#) $ (# $ # $ Const #)) : (string * term) option
153.129 +
153.130 +> val t = (term_of o the o (parse thy))
153.131 + "matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0)";
153.132 +> eval_matches "/thmid/" "/op_/" t thy;
153.133 +val it =
153.134 + SOME
153.135 + ("matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0) = True",
153.136 + Const (#,#) $ (# $ # $ Const #)) : (string * term) option
153.137 +----- before ?patterns ---:
153.138 +> val t = (term_of o the o (parse thy))
153.139 + "matches (a * b^^^#2 = c) (#3 * x^^^#2 = #1)";
153.140 +> eval_matches "/thmid/" "/op_/" t thy;
153.141 +SOME
153.142 + ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2 = #1) = True",
153.143 + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
153.144 + : (string * term) option
153.145 +
153.146 +> val t = (term_of o the o (parse thy))
153.147 + "matches (a * b^^^#2 = c) (#3 * x^^^#2222 = #1)";
153.148 +> eval_matches "/thmid/" "/op_/" t thy;
153.149 +SOME ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2222 = #1) = False",
153.150 + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
153.151 +
153.152 +> val t = (term_of o the o (parse thy))
153.153 + "matches (a = b) (x + #1 + #-1 * #2 = #0)";
153.154 +> eval_matches "/thmid/" "/op_/" t thy;
153.155 +SOME ("matches (a = b) (x + #1 + #-1 * #2 = #0) = True",Const # $ (# $ #))
153.156 +*)
153.157 +
153.158 +(*.does a pattern match some subterm ?.*)
153.159 +fun matchsub thy t pat =
153.160 + let fun matchs (t as Const _) = matches thy t pat
153.161 + | matchs (t as Free _) = matches thy t pat
153.162 + | matchs (t as Var _) = matches thy t pat
153.163 + | matchs (Bound _) = false
153.164 + | matchs (t as Abs (_, _, body)) =
153.165 + if matches thy t pat then true else matches thy body pat
153.166 + | matchs (t as f1 $ f2) =
153.167 + if matches thy t pat then true
153.168 + else if matchs f1 then true else matchs f2
153.169 + in matchs t end;
153.170 +
153.171 +(*("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")):calc*)
153.172 +fun eval_matchsub (thmid:string) "Tools.matchsub"
153.173 + (t as Const ("Tools.matchsub",_) $ pat $ tst) thy =
153.174 + if matchsub thy tst pat
153.175 + then let val prop = Trueprop $ (mk_equality (t, true_as_term))
153.176 + in SOME (Syntax.string_of_term @{context} prop, prop) end
153.177 + else let val prop = Trueprop $ (mk_equality (t, false_as_term))
153.178 + in SOME (Syntax.string_of_term @{context} prop, prop) end
153.179 + | eval_matchsub _ _ _ _ = NONE;
153.180 +
153.181 +(*get the variables in an isabelle-term*)
153.182 +(*("Vars" ,("Tools.Vars" ,eval_var "#Vars_")):calc*)
153.183 +fun eval_var (thmid:string) "Tools.Vars"
153.184 + (t as (Const(op0,t0) $ arg)) thy =
153.185 + let
153.186 + val t' = ((list2isalist HOLogic.realT) o vars) t;
153.187 + val thmId = thmid^(Syntax.string_of_term @{context} arg);
153.188 + in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
153.189 + | eval_var _ _ _ _ = NONE;
153.190 +
153.191 +fun lhs (Const ("op =",_) $ l $ _) = l
153.192 + | lhs t = error("lhs called with (" ^ term2str t ^ ")");
153.193 +(*("lhs" ,("Tools.lhs" ,eval_lhs "")):calc*)
153.194 +fun eval_lhs _ "Tools.lhs"
153.195 + (t as (Const ("Tools.lhs",_) $ (Const ("op =",_) $ l $ _))) _ =
153.196 + SOME ((term2str t) ^ " = " ^ (term2str l),
153.197 + Trueprop $ (mk_equality (t, l)))
153.198 + | eval_lhs _ _ _ _ = NONE;
153.199 +(*
153.200 +> val t = (term_of o the o (parse thy)) "lhs (1 * x ^^^ 2 = 0)";
153.201 +> val SOME (id,t') = eval_lhs 0 0 t 0;
153.202 +val id = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string
153.203 +> term2str t';
153.204 +val it = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string
153.205 +*)
153.206 +
153.207 +fun rhs (Const ("op =",_) $ _ $ r) = r
153.208 + | rhs t = error("rhs called with (" ^ term2str t ^ ")");
153.209 +(*("rhs" ,("Tools.rhs" ,eval_rhs "")):calc*)
153.210 +fun eval_rhs _ "Tools.rhs"
153.211 + (t as (Const ("Tools.rhs",_) $ (Const ("op =",_) $ _ $ r))) _ =
153.212 + SOME ((term2str t) ^ " = " ^ (term2str r),
153.213 + Trueprop $ (mk_equality (t, r)))
153.214 + | eval_rhs _ _ _ _ = NONE;
153.215 +
153.216 +
153.217 +(*for evaluating scripts*)
153.218 +
153.219 +val list_rls = append_rls "list_rls" list_rls
153.220 + [Calc ("Tools.rhs",eval_rhs "")];
153.221 +ruleset' := overwritelthy @{theory} (!ruleset',
153.222 + [("list_rls",list_rls)
153.223 + ]);
153.224 +calclist':= overwritel (!calclist',
153.225 + [("matches",("Tools.matches",eval_matches "#matches_")),
153.226 + ("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")),
153.227 + ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")),
153.228 + ("lhs" ,("Tools.lhs" ,eval_lhs "")),
153.229 + ("rhs" ,("Tools.rhs" ,eval_rhs ""))
153.230 + ]);
153.231 +
153.232 +*}
153.233 +end
154.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
154.2 +++ b/src/Tools/isac/ProgLang/calculate.sml Wed Aug 25 16:20:07 2010 +0200
154.3 @@ -0,0 +1,408 @@
154.4 +(* calculate values for function constants
154.5 + (c) Walther Neuper 000106
154.6 +
154.7 +use"ProgLang/calculate.sml";
154.8 +*)
154.9 +
154.10 +
154.11 +(* dirty type-conversion 30.1.00 for "fixed_values [R=R]" *)
154.12 +
154.13 +val aT = Type ("'a", []);
154.14 +(* isas types for Free, parseold: (1) "R=R" or (2) "R=(R::real)":
154.15 +(1)
154.16 +> val (TFree(ss2,TT2)) = T2;
154.17 +val ss2 = "'a" : string
154.18 +val TT2 = ["term"] : sort
154.19 +(2)
154.20 +> val (Type(ss2',TT2')) = T2';
154.21 +val ss2' = "RealDef.real" : string
154.22 +val TT2' = [] : typ list
154.23 +(3)
154.24 +val realType = TFree ("RealDef.real", HOLogic.termS);
154.25 +is different internally, too;
154.26 +
154.27 +(1) .. (3) are displayed equally !!!
154.28 +*)
154.29 +
154.30 +
154.31 +
154.32 +(* 30.1.00: generating special terms for ME:
154.33 + (1) binary numerals reconverted to Free ("#num",...)
154.34 + by libarary_G.num_str: called from parse (below) and
154.35 + interface_ME_ISA for all thms used
154.36 + (compare HOLogic.dest_binum)
154.37 + (2) 'a types converted to RealDef.real by typ_a2real
154.38 + in parse below
154.39 + (3) binary operators fixed to type real in RatArith.thy
154.40 + (trick by Markus Wenzel)
154.41 +*)
154.42 +
154.43 +
154.44 +
154.45 +
154.46 +(** calculate numerals **)
154.47 +
154.48 +(*27.3.00: problems with patterns below:
154.49 +"Vars (a // #2 = r * xxxxx b)" doesn't work, but
154.50 +"Vars (a // #2 = r * sqrt b)" works
154.51 +*)
154.52 +
154.53 +fun popt2str (SOME (str, term)) = "SOME "^term2str term
154.54 + | popt2str NONE = "NONE";
154.55 +
154.56 +(* scan a term for applying eval_fn ef
154.57 +args
154.58 + thy:
154.59 + op_: operator (as string) selecting the root of the pair
154.60 + ef : fn : (string -> term -> theory -> (string * term) option)
154.61 + ^^^^^^... for creating the string for the resulting theorem
154.62 + t : term to be scanned
154.63 +result:
154.64 + (string * term) option: found by the eval_* -function of type
154.65 + fn : string -> string -> term -> theory -> (string * term) option
154.66 + ^^^^^^... the selecting operator op_ (variable for eval_binop)
154.67 +*)
154.68 +fun get_pair thy op_ (ef:string -> term -> theory -> (string * term) option)
154.69 + (t as (Const(op0,t0) $ arg)) = (* unary fns *)
154.70 +(* val (thy, op_, (ef), (t as (Const(op0,t0) $ arg))) =
154.71 + (thy, op_, eval_fn, ct);
154.72 + *)
154.73 + if op_ = op0 then
154.74 + let val popt = ef op_ t thy
154.75 + in case popt of
154.76 + SOME _ => popt
154.77 + | NONE => get_pair thy op_ ef arg end
154.78 + else get_pair thy op_ ef arg
154.79 +
154.80 + | get_pair thy "Atools.ident" ef (t as (Const("Atools.ident",t0) $ _ $ _ )) =
154.81 +(* val (thy, "Atools.ident", ef, t as (Const(op0,_) $ t1 $ t2)) =
154.82 + (thy, op_, eval_fn, ct);
154.83 + *)
154.84 + ef "Atools.ident" t thy (* not nested *)
154.85 +
154.86 + | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2)) = (* binary funs*)
154.87 +(* val (thy, op_, ef, (t as (Const(op0,_) $ t1 $ t2))) =
154.88 + (thy, op_, eval_fn, ct);
154.89 + *)
154.90 + ((*writeln("1.. get_pair: binop = "^op_);*)
154.91 + if op_ = op0 then
154.92 + let val popt = ef op_ t thy
154.93 + (*val _ = writeln("2.. get_pair: "^term2str t^" -> "^popt2str popt)*)
154.94 + in case popt of
154.95 + SOME (id,_) => popt
154.96 + | NONE =>
154.97 + let val popt = get_pair thy op_ ef t1
154.98 + (*val _ = writeln("3.. get_pair: "^term2str t1^
154.99 + " -> "^popt2str popt)*)
154.100 + in case popt of
154.101 + SOME (id,_) => popt
154.102 + | NONE => get_pair thy op_ ef t2
154.103 + end
154.104 + end
154.105 + else (*search subterms*)
154.106 + let val popt = get_pair thy op_ ef t1
154.107 + (*val _ = writeln("4.. get_pair: "^term2str t^" -> "^popt2str popt)*)
154.108 + in case popt of
154.109 + SOME (id,_) => popt
154.110 + | NONE => get_pair thy op_ ef t2
154.111 + end)
154.112 + | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2 $ t3)) =(* trinary funs*)
154.113 + ((*writeln("### get_pair 4a: t= "^term2str t);
154.114 + writeln("### get_pair 4a: op_= "^op_);
154.115 + writeln("### get_pair 4a: op0= "^op0);*)
154.116 + if op_ = op0 then
154.117 + case ef op_ t thy of
154.118 + SOME tt => SOME tt
154.119 + | NONE => (case get_pair thy op_ ef t2 of
154.120 + SOME tt => SOME tt
154.121 + | NONE => get_pair thy op_ ef t3)
154.122 + else (case get_pair thy op_ ef t1 of
154.123 + SOME tt => SOME tt
154.124 + | NONE => (case get_pair thy op_ ef t2 of
154.125 + SOME tt => SOME tt
154.126 + | NONE => get_pair thy op_ ef t3)))
154.127 + | get_pair thy op_ ef (Const _) = NONE
154.128 + | get_pair thy op_ ef (Free _) = NONE
154.129 + | get_pair thy op_ ef (Var _) = NONE
154.130 + | get_pair thy op_ ef (Bound _) = NONE
154.131 + | get_pair thy op_ ef (Abs(a,T,body)) = get_pair thy op_ ef body
154.132 + | get_pair thy op_ ef (t1$t2) =
154.133 + let(*val _= writeln("5.. get_pair t1 $ t2: "^term2str t1^"
154.134 + $ "^term2str t2)*)
154.135 + val popt = get_pair thy op_ ef t1
154.136 + in case popt of
154.137 + SOME _ => popt
154.138 + | NONE => ((*writeln"### get_pair: t1 $ t2 -> NONE";*)
154.139 + get_pair thy op_ ef t2)
154.140 + end;
154.141 + (*
154.142 +> val t = (term_of o the o (parse thy)) "#3 + #4";
154.143 +> val eval_fn = the (assoc (!eval_list, "op +"));
154.144 +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
154.145 +> Syntax.string_of_term (thy2ctxt thy) t';
154.146 +> atomty t';
154.147 +>
154.148 +> val t = (term_of o the o (parse thy)) "(a + #3) + #4";
154.149 +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
154.150 +> Syntax.string_of_term (thy2ctxt thy) t';
154.151 +>
154.152 +> val t = (term_of o the o (parse thy)) "#3 + (#4 + (a::real))";
154.153 +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
154.154 +> Syntax.string_of_term (thy2ctxt thy) t';
154.155 +>
154.156 +> val t = (term_of o the o (parse thy)) "x = #5 * (#3 + (#4 + a))";
154.157 +> atomty t;
154.158 +> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
154.159 +> Syntax.string_of_term (thy2ctxt thy) t';
154.160 +> val it = "#3 + (#4 + a) = #7 + a" : string
154.161 +>
154.162 +>
154.163 +> val t = (term_of o the o (parse thy)) "#-4//#-2";
154.164 +> val eval_fn = the (assoc (!eval_list, "cancel"));
154.165 +> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t;
154.166 +> Syntax.string_of_term (thy2ctxt thy) t';
154.167 +>
154.168 +> val t = (term_of o the o (parse thy)) "#2^^^#3";
154.169 +> eval_binop "xxx" "pow" t thy;
154.170 +> val eval_fn = (eval_binop "xxx")
154.171 +> : string -> term -> theory -> (string * term) option;
154.172 +> val SOME (id,t') = get_pair thy "pow" eval_fn t;
154.173 +> Syntax.string_of_term (thy2ctxt thy) t';
154.174 +> val eval_fn = the (assoc (!eval_list, "pow"));
154.175 +> val (SOME (id,t')) = get_pair thy "pow" eval_fn t;
154.176 +> Syntax.string_of_term (thy2ctxt thy) t';
154.177 +>
154.178 +> val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4";
154.179 +> val eval_fn = the (assoc (!eval_list, "op *"));
154.180 +> val (SOME (id,t')) = get_pair thy "op *" eval_fn t;
154.181 +> Syntax.string_of_term (thy2ctxt thy) t';
154.182 +>
154.183 +> val t = (term_of o the o (parse thy)) "#0 < #4";
154.184 +> val eval_fn = the (assoc (!eval_list, "op <"));
154.185 +> val (SOME (id,t')) = get_pair thy "op <" eval_fn t;
154.186 +> Syntax.string_of_term (thy2ctxt thy) t';
154.187 +> val t = (term_of o the o (parse thy)) "#0 < #-4";
154.188 +> val (SOME (id,t')) = get_pair thy "op <" eval_fn t;
154.189 +> Syntax.string_of_term (thy2ctxt thy) t';
154.190 +>
154.191 +> val t = (term_of o the o (parse thy)) "#3 is_const";
154.192 +> val eval_fn = the (assoc (!eval_list, "is'_const"));
154.193 +> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t;
154.194 +> Syntax.string_of_term (thy2ctxt thy) t';
154.195 +> val t = (term_of o the o (parse thy)) "a is_const";
154.196 +> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t;
154.197 +> Syntax.string_of_term (thy2ctxt thy) t';
154.198 +>
154.199 +> val t = (term_of o the o (parse thy)) "#6//(#8::real)";
154.200 +> val eval_fn = the (assoc (!eval_list, "cancel"));
154.201 +> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t;
154.202 +> Syntax.string_of_term (thy2ctxt thy) t';
154.203 +>
154.204 +> val t = (term_of o the o (parse thy)) "sqrt #12";
154.205 +> val eval_fn = the (assoc (!eval_list, "SqRoot.sqrt"));
154.206 +> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t;
154.207 +> Syntax.string_of_term (thy2ctxt thy) t';
154.208 +> val it = "sqrt #12 = #2 * sqrt #3 " : string
154.209 +>
154.210 +> val t = (term_of o the o (parse thy)) "sqrt #9";
154.211 +> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t;
154.212 +> Syntax.string_of_term (thy2ctxt thy) t';
154.213 +>
154.214 +> val t = (term_of o the o (parse thy)) "Nth #2 [#11,#22,#33]";
154.215 +> val eval_fn = the (assoc (!eval_list, "Tools.Nth"));
154.216 +> val (SOME (id,t')) = get_pair thy "Tools.Nth" eval_fn t;
154.217 +> Syntax.string_of_term (thy2ctxt thy) t';
154.218 +*)
154.219 +
154.220 +(* val ((op_, eval_fn),ct)=(cc,pre);
154.221 + (get_calculation_ Isac.thy (op_, eval_fn) ct) handle e => print_exn e;
154.222 + parse thy ""
154.223 + *)
154.224 +(*.get a thm from an op_ somewhere in the term;
154.225 + apply ONLY to (uminus_to_string term), uminus_to_string (- 4711) --> (-4711).*)
154.226 +fun get_calculation_ thy (op_, eval_fn) ct =
154.227 +(* val (thy, (op_, eval_fn), ct) =
154.228 + (thy, (the (assoc(!calclist',"order_system"))), t);
154.229 + *)
154.230 + case get_pair thy op_ eval_fn ct of
154.231 + NONE => ((*writeln("@@@ get_calculation: NONE, op_="^op_);
154.232 + writeln("@@@ get_calculation: ct= ");atomty ct;*)
154.233 + NONE)
154.234 + | SOME (thmid,t) =>
154.235 + ((*writeln("@@@ get_calculation: NONE, op_="^op_);
154.236 + writeln("@@@ get_calculation: ct= ");atomty ct;*)
154.237 + SOME (thmid, (make_thm o (cterm_of thy)) t));
154.238 +(*
154.239 +> val ct = (the o (parse thy)) "#9 is_const";
154.240 +> get_calculation_ thy ("is'_const",the (assoc(!eval_list,"is'_const"))) ct;
154.241 +val it = SOME ("is_const9_","(is_const 9 ) = True [(is_const 9 ) = True]")
154.242 +
154.243 +> val ct = (the o (parse thy)) "sqrt #9";
154.244 +> get_calculation_ thy ("sqrt",the (assoc(!eval_list,"sqrt"))) ct;
154.245 +val it = SOME ("sqrt_9_","sqrt 9 = 3 [sqrt 9 = 3]") : (string * thm) option
154.246 +
154.247 +> val ct = (the o (parse thy)) "#4<#4";
154.248 +> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct;fun is_no str = (hd o explode) str = "#";
154.249 +
154.250 +val it = SOME ("less_5_4","(5 < 4) = False [(5 < 4) = False]")
154.251 +
154.252 +> val ct = (the o (parse thy)) "a<#4";
154.253 +> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct;
154.254 +val it = NONE : (string * thm) option
154.255 +
154.256 +> val ct = (the o (parse thy)) "#5<=#4";
154.257 +> get_calculation_ thy ("op <=",the (assoc(!eval_list,"op <="))) ct;
154.258 +val it = SOME ("less_equal_5_4","(5 <= 4) = False [(5 <= 4) = False]")
154.259 +
154.260 +-------------------------------------------------------------------6.8.02:
154.261 + val thy = SqRoot.thy;
154.262 + val t = (term_of o the o (parse thy)) "1+2";
154.263 + get_calculation_ thy (the(assoc(!calc_list,"PLUS"))) t;
154.264 + val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option
154.265 +-------------------------------------------------------------------6.8.02:
154.266 + val t = (term_of o the o (parse thy)) "-1";
154.267 + atomty t;
154.268 + val t = (term_of o the o (parse thy)) "0";
154.269 + atomty t;
154.270 + val t = (term_of o the o (parse thy)) "1";
154.271 + atomty t;
154.272 + val t = (term_of o the o (parse thy)) "2";
154.273 + atomty t;
154.274 + val t = (term_of o the o (parse thy)) "999999999";
154.275 + atomty t;
154.276 +-------------------------------------------------------------------6.8.02:
154.277 +
154.278 +> val ct = (the o (parse thy)) "a+#3+#4";
154.279 +> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct;
154.280 +val it = SOME ("add_3_4","a + 3 + 4 = a + 7 [a + 3 + 4 = a + 7]")
154.281 +
154.282 +> val ct = (the o (parse thy)) "#3+(#4+a)";
154.283 +> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct;
154.284 +val it = SOME ("add_3_4","3 + (4 + a) = 7 + a [3 + (4 + a) = 7 + a]")
154.285 +
154.286 +> val ct = (the o (parse thy)) "a+(#3+#4)+#5";
154.287 +> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct;
154.288 +val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option
154.289 +
154.290 +> val ct = (the o (parse thy)) "#3*(#4*a)";
154.291 +> get_calculation_ thy ("op *",the (assoc(!eval_list,"op *"))) ct;
154.292 +val it = SOME ("mult_3_4","3 * (4 * a) = 12 * a [3 * (4 * a) = 12 * a]")
154.293 +
154.294 +> val ct = (the o (parse thy)) "#3 + #4^^^#2 + #5";
154.295 +> get_calculation_ thy ("pow",the (assoc(!eval_list,"pow"))) ct;
154.296 +val it = SOME ("4_(+2)","4 ^ 2 = 16 [4 ^ 2 = 16]") : (string * thm) option
154.297 +
154.298 +> val ct = (the o (parse thy)) "#-4//#-2";
154.299 +> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct;
154.300 +val it = SOME ("cancel_(-4)_(-2)","(-4) // (-2) = (+2) [(-4) // (-2) = (+2)]")
154.301 +
154.302 +> val ct = (the o (parse thy)) "#6//#-8";
154.303 +> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct;
154.304 +val it = SOME ("cancel_6_(-8)","6 // (-8) = (-3) // 4 [6 // (-8) = (-3) // 4]")
154.305 +
154.306 +*)
154.307 +
154.308 +
154.309 +(*
154.310 +> val ct = (the o (parse thy)) "a + 3*4";
154.311 +> applicable "calculate" (Calc("op *", "mult_")) ct;
154.312 +val it = SOME "3 * 4 = 12 [3 * 4 = 12]" : thm option
154.313 +
154.314 +--------------------------
154.315 +> val ct = (the o (parse thy)) "3 =!= 3";
154.316 +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
154.317 +val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm
154.318 +
154.319 +> val ct = (the o (parse thy)) "~ (3 =!= 3)";
154.320 +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
154.321 +val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm
154.322 +
154.323 +> val ct = (the o (parse thy)) "3 =!= 4";
154.324 +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
154.325 +val thm = "(3 =!= 4) = False [(3 =!= 4) = False]" : thm
154.326 +
154.327 +> val ct = (the o (parse thy)) "( 4 + (4 * x + x ^ 2) =!= (+0))";
154.328 +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
154.329 + "(4 + (4 * x + x ^ 2) =!= (+0)) = False"
154.330 +
154.331 +> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))";
154.332 +> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
154.333 + "(4 + (4 * x + x ^ 2) =!= (+0)) = False"
154.334 +
154.335 +> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))";
154.336 +> val rls = eval_rls;
154.337 +> val (ct,_) = the (rewrite_set_ thy false rls ct);
154.338 +val ct = "True" : cterm
154.339 +--------------------------
154.340 +*)
154.341 +
154.342 +
154.343 +(*.get a thm applying an op_ to a term;
154.344 + apply ONLY to (numbers_to_string term), numbers_to_string (- 4711) --> (-4711).*)
154.345 +(* val (thy, (op_, eval_fn), ct) =
154.346 + (thy, ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_"), term);
154.347 + *)
154.348 +fun get_calculation1_ thy ((op_, eval_fn):cal) ct =
154.349 + case eval_fn op_ ct thy of
154.350 + NONE => NONE
154.351 + | SOME (thmid,t) =>
154.352 + SOME (thmid, (make_thm o (cterm_of thy)) t);
154.353 +
154.354 +
154.355 +
154.356 +
154.357 +
154.358 +(*.substitute bdv in an rls and leave Calc as they are.(*28.10.02*)
154.359 +fun inst_thm' subs (Thm (id, thm)) =
154.360 + Thm (id, (*read_instantiate throws: *** No such variable in term: ?bdv*)
154.361 + (read_instantiate subs thm) handle _ => thm)
154.362 + | inst_thm' _ calc = calc;
154.363 +fun inst_thm' (subs as (bdv,_)::_) (Thm (id, thm)) =
154.364 + Thm (id, (writeln("@@@ inst_thm': thm= "^(string_of_thmI thm));
154.365 + if bdv mem (vars_str o #prop o rep_thm) thm
154.366 + then (writeln("@@@ inst_thm': read_instantiate, thm="^((string_of_thmI thm)));
154.367 + read_instantiate subs thm)
154.368 + else (writeln("@@@ inst_thm': not mem.. "^bdv);
154.369 + thm)))
154.370 + | inst_thm' _ calc = calc;
154.371 +
154.372 +fun instantiate_rls subs
154.373 + (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca,
154.374 + asm_thm=at,rules=rules,scr=scr}:rls) =
154.375 + (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca,
154.376 + asm_thm=at,scr=scr,
154.377 + rules = map (inst_thm' subs) rules}:rls);---------------------------*)
154.378 +
154.379 +
154.380 +
154.381 +(** rewriting: ordered, conditional **)
154.382 +
154.383 +fun mk_rule (prems,l,r) =
154.384 + Trueprop $ (list_implies (prems, mk_equality (l,r)));
154.385 +
154.386 +(* 'norms' a rule, e.g.
154.387 +(*1*) a = 1 ==> a*(b+c) = b+c
154.388 + => a = 1 ==> a*(b+c) = b+c no change
154.389 +(*2*) t = t => (t=t) = True !!
154.390 +(*3*) [| k < l; m + l = k + n |] ==> m < n
154.391 + => [| k<l; m+l=k+n |] ==> m < n = True !! *)
154.392 +(* val it = fn : term -> term *)
154.393 +fun norm rule =
154.394 + let
154.395 + val (prems,concl)=(map strip_trueprop(Logic.strip_imp_prems rule),
154.396 + (strip_trueprop o Logic.strip_imp_concl)rule)
154.397 + in if is_equality concl then
154.398 + let val (l,r) = dest_equals' concl
154.399 + in if l = r then
154.400 + (*2*) mk_rule(prems,concl,true_as_term)
154.401 + else (*1*) rule end
154.402 + else (*3*) mk_rule(prems,concl,true_as_term)
154.403 + end;
154.404 +
154.405 +
154.406 +
154.407 +
154.408 +
154.409 +
154.410 +
154.411 +
155.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
155.2 +++ b/src/Tools/isac/ProgLang/rewrite.sml Wed Aug 25 16:20:07 2010 +0200
155.3 @@ -0,0 +1,736 @@
155.4 +(* isac's rewriter
155.5 + (c) Walther Neuper 2000
155.6 +
155.7 +use"ProgLang/rewrite.sml";
155.8 +use"rewrite.sml";
155.9 +*)
155.10 +
155.11 +
155.12 +exception NO_REWRITE;
155.13 +exception STOP_REW_SUB; (*WN050820 quick and dirty*)
155.14 +
155.15 +(*17.6.00: rewrite by going down the term with rew_sub*)
155.16 +(* val (thy, i, bdv, tless, rls, put_asm, thm, ct) =
155.17 + (thy, 1, []:(Term.term * Term.term) list, rew_ord, erls, bool,thm,term);
155.18 + *)
155.19 +fun rewrite__ thy i bdv tless rls put_asm thm ct =
155.20 + ((*writeln ("@@@ r..te__ begin: t = "^(term2str ct));*)
155.21 + let
155.22 + val (t',asms,lrd,rew) =
155.23 + rew_sub thy i bdv tless rls put_asm [(*root of the term*)]
155.24 + (((inst_bdv bdv) o norm o #prop o rep_thm) thm) ct;
155.25 + in if rew then SOME (t', distinct asms)
155.26 + else NONE end)
155.27 +(* val(r,t)=(((inst_bdv bdv) o norm o #prop o rep_thm) thm,ct);
155.28 + val t1 = (#prop o rep_thm) thm;
155.29 + val t2 = norm t1;
155.30 + val t3 = inst_bdv bdv t2;
155.31 +
155.32 + val thm4 = read_instantiate [("bdv","x")] thm;
155.33 + val t4 = (norm o #prop o rep_thm) thm4;
155.34 + *)
155.35 +(* val (thy, i, bdv, tless, rls, put_asm, r, t) =
155.36 + (thy, i,bdv, tless, rls, put_asm,
155.37 + (((inst_bdv bdv) o norm o #prop o rep_thm) thm), ct);
155.38 + val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) =
155.39 + (thy, 1, [], ord, erls,false, [], r, t);
155.40 + val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) =
155.41 + (thy, i, bdv, tless, rls, put_asm, [],
155.42 + ((inst_bdv bdv) o norm o #prop o rep_thm) thm, ct);
155.43 + *)
155.44 +and rew_sub thy i bdv tless rls put_asm lrd r t =
155.45 + ((*writeln ("@@@ rew_sub begin: t = "^(term2str t));*)
155.46 + let (* copy from Pure/thm.ML: fun rewritec *)
155.47 + (*val (lhs,rhs) = (dest_equals' o strip_trueprop
155.48 + o Logic.strip_imp_concl) r;
155.49 + val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs,t);
155.50 + val r' = ren_inst (insts, r, lhs, t);
155.51 + val p' = map strip_trueprop (Logic.strip_imp_prems r');
155.52 + val t' = (snd o dest_equals' o strip_trueprop
155.53 + o Logic.strip_imp_concl) r';*)
155.54 + val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop
155.55 + o Logic.strip_imp_concl) r;
155.56 + val r' = Envir.subst_term (Pattern.match thy (lhs, t)
155.57 + (Vartab.empty, Vartab.empty)) r;
155.58 + val p' = (fst o Logic.strip_prems) (Logic.count_prems r', [], r');
155.59 + val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop
155.60 + o Logic.strip_imp_concl) r';
155.61 + (*val _= writeln("@@@ rew_sub match: t'= "^(term2str t'));*)
155.62 + val _= if ! trace_rewrite andalso i < ! depth andalso p' <> []
155.63 + then writeln((idt"#"(i+1))^" eval asms: "^(term2str r')) else();
155.64 + val (t'',p'') = (*conditional rewriting*)
155.65 + let val (simpl_p', nofalse) = eval__true thy (i+1) p' bdv rls
155.66 + in if nofalse
155.67 + then (if ! trace_rewrite andalso i < ! depth andalso p' <> []
155.68 + then writeln((idt"#"(i+1))^" asms accepted: "^(terms2str p')^
155.69 + " stored: "^(terms2str simpl_p'))
155.70 + else(); (t',simpl_p')) (* + uncond.rew. *)
155.71 + else
155.72 + (if ! trace_rewrite andalso i < ! depth
155.73 + then writeln((idt"#"(i+1))^" asms false: "^(terms2str p'))
155.74 + else(); raise STOP_REW_SUB (*dont go into subterms of cond*))
155.75 + end
155.76 + in if perm lhs rhs andalso not (tless bdv (t',t)) (*ordered rewriting*)
155.77 + then (if ! trace_rewrite andalso i < ! depth
155.78 + then writeln((idt"#"i)^" not: \""^
155.79 + (term2str t)^"\" > \""^
155.80 + (term2str t')^"\"") else ();
155.81 + raise NO_REWRITE )
155.82 + else ((*writeln("##@ rew_sub: (t''= "^(term2str t'')^
155.83 + ", p'' ="^(terms2str p'')^", true)");*)
155.84 + (t'',p'',[],true))
155.85 + end
155.86 + ) handle _ (*NO_REWRITE WN050820 causes diff.behav. in tests + MATCH!*) =>
155.87 + ((*writeln ("@@@ rew_sub gosub: t = "^(term2str t));*)
155.88 + case t of
155.89 + Const(s,T) => (Const(s,T),[],lrd,false)
155.90 + | Free(s,T) => (Free(s,T),[],lrd,false)
155.91 + | Var(n,T) => (Var(n,T),[],lrd,false)
155.92 + | Bound i => (Bound i,[],lrd,false)
155.93 + | Abs(s,T,body) =>
155.94 + let val (t', asms, lrd, rew) =
155.95 + rew_sub thy i bdv tless rls put_asm (lrd@[D]) r body
155.96 + in (Abs(s,T,t'), asms, [], rew) end
155.97 + | t1 $ t2 =>
155.98 + let val (t2', asm2, lrd, rew2) =
155.99 + rew_sub thy i bdv tless rls put_asm (lrd@[R]) r t2
155.100 + in if rew2 then (t1 $ t2', asm2, lrd, true)
155.101 + else let val (t1', asm1, lrd, rew1) =
155.102 + rew_sub thy i bdv tless rls put_asm (lrd@[L]) r t1
155.103 + in if rew1 then (t1' $ t2, asm1, lrd, true)
155.104 + else (t1 $ t2,[], lrd, false) end
155.105 + end)
155.106 +(* val (cprems',rls)=([pre],prls);
155.107 + rewrite__set_ thy i false rls pre;
155.108 + *)
155.109 +and eval__true thy i asms bdv rls =
155.110 +(* val (thy, i, asms, bdv, rls) = (thy, (i+1), p', bdv, rls);
155.111 + *)
155.112 + if asms = [HOLogic.true_const] orelse asms = []
155.113 + then ([], true) else if asms = [HOLogic.false_const] then ([], false)
155.114 + else let
155.115 + fun chk indets [] = (indets, true)(*return asms<>True until false*)
155.116 + | chk indets (a::asms) =
155.117 +(* val (indets, (a::asms)) = ([], asms);
155.118 + *)
155.119 + (case rewrite__set_ thy (i+1) false bdv rls a of
155.120 + NONE => (chk (indets @ [a]) asms)
155.121 + | SOME (t, a') =>
155.122 + if t = HOLogic.true_const
155.123 + then (chk (indets @ a') asms)
155.124 + else if t = HOLogic.false_const then ([], false)
155.125 + (*asm false .. thm not applied ^^^; continue until False vvv*)
155.126 + else (chk (indets @ [t] @ a') asms));
155.127 + in chk [] asms end
155.128 +
155.129 +and rewrite__set_ _ _ __ Erls t =
155.130 + raise error("rewrite__set_ called with 'Erls' for '"^term2str t^"'")
155.131 + | rewrite__set_ thy i _ _ (rrls as Rrls _) t =
155.132 + let val _= if ! trace_rewrite andalso i < ! depth
155.133 + then writeln ((idt"#"i)^" rls: "^(id_rls rrls)^" on: "^
155.134 + (term2str t)) else ()
155.135 + val (t', asm, rew) = app_rev thy (i+1) rrls t
155.136 + in if rew then SOME (t', distinct asm)
155.137 + else NONE end
155.138 + | rewrite__set_ thy i put_asm bdv rls ct =
155.139 +(* val (thy, i, put_asm, bdv, rls, ct) = (thy, 1, bool, [], rls, term);
155.140 + *)
155.141 + let
155.142 + datatype switch = Appl | Noap;
155.143 + fun rew_once ruls asm ct Noap [] = (ct,asm)
155.144 + | rew_once ruls asm ct Appl [] =
155.145 + (case rls of Rls _ => rew_once ruls asm ct Noap ruls
155.146 + | Seq _ => (ct,asm))
155.147 + | rew_once ruls asm ct apno (rul::thms) =
155.148 +(* val (ruls, asm, ct, apno, (rul::thms)) = (ruls, [], ct, Noap, ruls);
155.149 + val Thm (thmid, thm) = rul;
155.150 + *)
155.151 + case rul of
155.152 + Thm (thmid, thm) =>
155.153 + (if !trace_rewrite andalso i < ! depth
155.154 + then writeln((idt"#"(i+1))^" try thm: "^thmid) else ();
155.155 + case rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
155.156 + ((#erls o rep_rls) rls) put_asm thm ct of
155.157 + NONE => rew_once ruls asm ct apno thms
155.158 + | SOME (ct',asm') => (if ! trace_rewrite andalso i < ! depth
155.159 + then writeln((idt"="(i+1))^" rewrites to: "^
155.160 + (term2str ct')) else ();
155.161 + rew_once ruls (union (op =) asm asm') ct' Appl (rul::thms)))
155.162 + | Calc (cc as (op_,_)) =>
155.163 + (let val _= if !trace_rewrite andalso i < ! depth then
155.164 + writeln((idt"#"(i+1))^" try calc: "^op_^"'") else ();
155.165 + val ct = uminus_to_string ct
155.166 + in case get_calculation_ thy cc ct of
155.167 + NONE => ((*writeln "@@@ rewrite__set_: get_calculation_-> NONE";*)
155.168 + rew_once ruls asm ct apno thms)
155.169 + | SOME (thmid, thm') =>
155.170 + let
155.171 + val pairopt =
155.172 + rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
155.173 + ((#erls o rep_rls) rls) put_asm thm' ct;
155.174 + val _ = if pairopt <> NONE then ()
155.175 + else raise error("rewrite_set_, rewrite_ \""^
155.176 + (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE")
155.177 + val _ = if ! trace_rewrite andalso i < ! depth
155.178 + then writeln((idt"="(i+1))^" calc. to: "^
155.179 + (term2str ((fst o the) pairopt)))
155.180 + else()
155.181 + in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end
155.182 + end)
155.183 +(* use"ProgLang/rewrite.sml";
155.184 + @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
155.185 + | Cal1 (cc as (op_,_)) =>
155.186 + (let val _= if !trace_rewrite andalso i < ! depth then
155.187 + writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else ();
155.188 + val ct = uminus_to_string ct
155.189 + in case get_calculation1_ thy cc ct of
155.190 + NONE => (ct, asm)
155.191 + | SOME (thmid, thm') =>
155.192 + let
155.193 + val pairopt =
155.194 + rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
155.195 + ((#erls o rep_rls) rls) put_asm thm' ct;
155.196 + val _ = if pairopt <> NONE then ()
155.197 + else raise error("rewrite_set_, rewrite_ \""^
155.198 + (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE")
155.199 + val _ = if ! trace_rewrite andalso i < ! depth
155.200 + then writeln((idt"="(i+1))^" cal1. to: "^
155.201 + (term2str ((fst o the) pairopt)))
155.202 + else()
155.203 + in the pairopt end
155.204 + end)
155.205 +(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
155.206 + | Rls_ rls' =>
155.207 + (case rewrite__set_ thy (i+1) put_asm bdv rls' ct of
155.208 + SOME (t',asm') => rew_once ruls (union (op =) asm asm') t' Appl thms
155.209 + | NONE => rew_once ruls asm ct apno thms);
155.210 +
155.211 + val ruls = (#rules o rep_rls) rls;
155.212 + val _= if ! trace_rewrite andalso i < ! depth
155.213 + then writeln ((idt"#"i)^" rls: "^(id_rls rls)^" on: "^
155.214 + (term2str ct)) else ()
155.215 + val (ct',asm') = rew_once ruls [] ct Noap ruls;
155.216 + in if ct = ct' then NONE else SOME (ct', distinct asm') end
155.217 +
155.218 +and app_rev thy i rrls t =
155.219 + let (*.check a (precond, pattern) of a rev-set; stops with 1st true.*)
155.220 + fun chk_prepat thy erls [] t = true
155.221 + | chk_prepat thy erls prepat t =
155.222 + let fun chk (pres, pat) =
155.223 + (let val subst: Type.tyenv * Envir.tenv =
155.224 + Pattern.match thy (pat, t)
155.225 + (Vartab.empty, Vartab.empty)
155.226 + in snd (eval__true thy (i+1)
155.227 + (map (Envir.subst_term subst) pres)
155.228 + [] erls)
155.229 + end)
155.230 + handle _ => false
155.231 + fun scan_ f [] = false (*scan_ NEVER called by []*)
155.232 + | scan_ f (pp::pps) = if f pp then true
155.233 + else scan_ f pps;
155.234 + in scan_ chk prepat end;
155.235 +
155.236 + (*.apply the normal_form of a rev-set.*)
155.237 + fun app_rev' thy (Rrls{erls,prepat,scr=Rfuns{normal_form,...},...}) t =
155.238 + if chk_prepat thy erls prepat t
155.239 + then ((*writeln("### app_rev': t = "^(term2str t));*)
155.240 + normal_form t)
155.241 + else NONE;
155.242 +
155.243 + val opt = app_rev' thy rrls t
155.244 + in case opt of
155.245 + SOME (t', asm) => (t', asm, true)
155.246 + | NONE => app_sub thy i rrls t
155.247 + end
155.248 +and app_sub thy i rrls t =
155.249 + ((*writeln("### app_sub: subterm = "^(term2str t));*)
155.250 + case t of
155.251 + Const (s, T) => (Const(s, T), [], false)
155.252 + | Free (s, T) => (Free(s, T), [], false)
155.253 + | Var (n, T) => (Var(n, T), [], false)
155.254 + | Bound i => (Bound i, [], false)
155.255 + | Abs (s, T, body) =>
155.256 + let val (t', asm, rew) = app_rev thy i rrls body
155.257 + in (Abs(s, T, t'), asm, rew) end
155.258 + | t1 $ t2 =>
155.259 + let val (t2', asm2, rew2) = app_rev thy i rrls t2
155.260 + in if rew2 then (t1 $ t2', asm2, true)
155.261 + else let val (t1', asm1, rew1) = app_rev thy i rrls t1
155.262 + in if rew1 then (t1' $ t2, asm1, true)
155.263 + else (t1 $ t2, [], false) end
155.264 + end);
155.265 +
155.266 +
155.267 +
155.268 +(*.rewriting without argument [] for rew_ord.*)
155.269 +(*WN.11.6.03: shouldnt asm<>[] lead to false ????*)
155.270 +fun eval_true thy terms rls = (snd o (eval__true thy 1 terms [])) rls;
155.271 +
155.272 +
155.273 +(*.rewriting without internal argument [] for rew_ord.*)
155.274 +(* val (thy, rew_ord, erls, bool, thm, term) =
155.275 + (thy, (assoc_rew_ord ro), rls', false, (assoc_thm' thy thm'), f);
155.276 + val (thy, rew_ord, erls, bool, thm, term) =
155.277 + (thy, rew_ord, erls, false, thm, t'');
155.278 + *)
155.279 +fun rewrite_ thy rew_ord erls bool thm term =
155.280 + rewrite__ thy 1 [] rew_ord erls bool thm term;
155.281 +fun rewrite_set_ thy bool rls term =
155.282 +(* val (thy, bool, rls, term) = (thy, false, srls, t);
155.283 + *)
155.284 + rewrite__set_ thy 1 bool [] rls term;
155.285 +
155.286 +
155.287 +fun subs'2subst thy (s:subs') =
155.288 + (((map (apfst (term_of o the o (parse thy))))
155.289 + o (map (apsnd (term_of o the o (parse thy))))) s):subst;
155.290 +
155.291 +(*.variants of rewrite.*)
155.292 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst,
155.293 + thus the argument put_asm IS NOT NECESSARY -- FIXME*)
155.294 +(* val (rew_ord,rls,put_asm,thm,ct)=
155.295 + (e_rew_ord,poly_erls,false,num_str d1_isolate_add2,t);
155.296 + *)
155.297 +fun rewrite_inst_ (thy:theory) rew_ord (rls:rls) (put_asm:bool)
155.298 + (subst:(term * term) list) (thm:thm) (ct:term) =
155.299 + rewrite__ thy 1 subst rew_ord rls put_asm thm ct;
155.300 +
155.301 +fun rewrite_set_inst_ (thy:theory)
155.302 + (put_asm:bool) (subst:(term * term) list) (rls:rls) (ct:term) =
155.303 + (*let
155.304 + val subst = subs'2subst thy subs';
155.305 + val subrls = instantiate_rls subs' rls
155.306 + in*) rewrite__set_ thy 1 put_asm subst (*sub*)rls ct
155.307 + (*end*);
155.308 +
155.309 +(* val (thy, ord, erls, subte, t) = (thy, dummy_ord, Erls, subte, t);
155.310 + *)
155.311 +(*.rewrite using a list of terms.*)
155.312 +fun rewrite_terms_ thy ord erls subte t =
155.313 + let (*val _=writeln("### rewrite_terms_ subte= '"^terms2str subte^"' ..."^
155.314 + term_detail2str (hd subte)^
155.315 + "### rewrite_terms_ t= '"^term2str t^"' ..."^
155.316 + term_detail2str t);*)
155.317 + fun rew_ (t', asm') [] _ = (t', asm')
155.318 + (* 1st val (t', asm', rules as r::rs, t) = (e_term, [], subte, t);
155.319 + 2nd val (t', asm', rules as r::rs, t) = (t'', [], rules, t'');
155.320 + rew_ (t', asm') (r::rs) t;
155.321 + *)
155.322 + | rew_ (t', asm') (rules as r::rs) t =
155.323 + let val _ = writeln("rew_ "^term2str t);
155.324 + val (t'', asm'', lrd, rew) =
155.325 + rew_sub thy 1 [] ord erls false [] r t
155.326 + in if rew
155.327 + then (writeln("true rew_ "^term2str t'');
155.328 + rew_ (t'', asm' @ asm'') rules t'')
155.329 + else (writeln("false rew_ "^term2str t'');
155.330 + rew_ (t', asm') rs t')
155.331 + end
155.332 + val (t'', asm'') = rew_ (e_term, []) subte t
155.333 + in if t'' = e_term
155.334 + then NONE else SOME (t'', asm'')
155.335 + end;
155.336 +
155.337 +
155.338 +(*. search ct for adjacent numerals and calculate them by operator isa_fn .*)
155.339 +fun calculate_ thy isa_fn ct =
155.340 + let val ct = uminus_to_string ct
155.341 + in case get_calculation_ thy isa_fn ct of
155.342 + NONE => NONE
155.343 + | SOME (thmID, thm) =>
155.344 + (let val SOME (rew,_) = rewrite_ thy dummy_ord e_rls false thm ct
155.345 + in SOME (rew,(thmID, thm)) end)
155.346 + handle _ => error ("calculate_: "^thmID^" does not rewrite")
155.347 + end;
155.348 +(*
155.349 +> val thy = InsSort.thy;
155.350 +> val op_ = "le"; (* < *)
155.351 +> val ct = (the o (parse thy))
155.352 + "foldr ins [#2] (if #1 < #3 then #1 # ins [] #3 else [#3, #1])";
155.353 +> calculate_ thy op_ ct;
155.354 + SOME
155.355 + ("foldr ins [#2] (if True then #1 # ins [] #3 else [#3, #1])",
155.356 + "(#1 < #3) = True") : (cterm * thm) option *)
155.357 +
155.358 +
155.359 +(* for test-printouts:
155.360 +val _ = writeln("in rew_sub : "^( Syntax.string_of_term (thy2ctxt thy) t))
155.361 +val _ = writeln("in eval_true: prems= "^(commas (map (Syntax.string_of_term (thy2ctxt thy)) prems')))
155.362 +*)
155.363 +
155.364 +
155.365 +
155.366 +
155.367 +
155.368 +
155.369 +fun get_rls_scr rs' = ((#scr o rep_rls o #2 o the o assoc') (!ruleset',rs'))
155.370 + handle _ => raise error ("get_rls_scr: no script for "^rs');
155.371 +
155.372 +
155.373 +(*make_thm added to Pure/thm.ML*)
155.374 +fun mk_thm thy str =
155.375 + let val t = (term_of o the o (parse thy)) str
155.376 + val t' = case t of
155.377 + Const ("==>",_) $ _ $ _ => t
155.378 + | _ => Trueprop $ t
155.379 + in make_thm (cterm_of thy t') end;
155.380 +(*
155.381 + val str = "?r ^^^ 2 = ?r * ?r";
155.382 + val thm = realpow_twoI;
155.383 +
155.384 + val t1 = (#prop o rep_thm) (num_str thm);
155.385 + val t2 = Trueprop $ ((term_of o the o (parse thy)) str);
155.386 + t1 = t2;
155.387 +val it = true : bool ... !!!
155.388 + val th1 = (num_str thm);
155.389 + val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e;
155.390 + th1 = th2;
155.391 +ML> val it = false : bool ... HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?!
155.392 +
155.393 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
155.394 + val str = "k ~= 0 ==> m * k / (n * k) = m / n";
155.395 + val thm = real_mult_div_cancel2;
155.396 +
155.397 + val t1 = (#prop o rep_thm) (num_str thm);
155.398 + val t2 = ((term_of o the o (parse thy)) str);
155.399 + t1 = t2;
155.400 +val it = false : bool ... Var .. Free
155.401 + val th1 = (num_str thm);
155.402 + val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e;
155.403 + th1 = th2;
155.404 +ML> val it = false : bool ... PLUS HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?!
155.405 +*)
155.406 +
155.407 +
155.408 +(*prints subgoal etc.
155.409 +((goal thy);(topthm()) o ) str; *)
155.410 +(*assume rejects scheme variables
155.411 + assume ((cterm_of thy) (Trueprop $
155.412 + (term_of o the o (parse thy)) str)); *)
155.413 +
155.414 +
155.415 +(* outcommented 18.11.xx, xx < 02 -------
155.416 +fun rul2rul' (Thm (thmid, thm)) = Thm'(thmid, string_of_thmI thm)
155.417 + | rul2rul' (Calc op_) = Calc' op_;
155.418 +fun rul'2rul thy (Thm'(thmid, ct')) =
155.419 + Thm (thmid, mk_thm thy ct')
155.420 + | rul'2rul thy' (Calc' op_) = Calc op_;
155.421 +
155.422 +
155.423 +fun rls2rls' (Rls{preconds=preconds,rew_ord=rew_ord,rules=rules}:rls) =
155.424 + Rls'{preconds'= map string_of_cterm preconds,
155.425 + rew_ord' = fst rew_ord,
155.426 + rules' = map rul2rul' rules}:rlsdat';
155.427 +
155.428 +fun rls'2rls thy' (Rls'{preconds'=preconds,rew_ord'=rew_ord,
155.429 + rules'=rules}:rlsdat') =
155.430 + let val thy = the (assoc' (theory',thy'))
155.431 + in Rls{preconds = map (the o (parse thy)) preconds,
155.432 + rew_ord = (rew_ord, the (assoc'(rew_ord',rew_ord))),
155.433 + rules = map (rul'2rul thy) rules}:rls end;
155.434 +------- *)
155.435 +
155.436 +(*.get the theorem associated with the xstring-identifier;
155.437 + if the identifier starts with "sym_" then swap lhs = rhs around =
155.438 + (ATTENTION: "RS sym" attaches a [.] -- remove it with string_of_thmI);
155.439 + identifiers starting with "#" come from Calc and
155.440 + get a hand-made theorem (containing numerals only).*)
155.441 +fun assoc_thm' (thy:theory) ((thmid, ct'):thm') =
155.442 + (case explode thmid of
155.443 + "s"::"y"::"m"::"_"::id =>
155.444 + if hd id = "#"
155.445 + then mk_thm thy ct'
155.446 + else ((num_str o (PureThy.get_thm thy)) (implode id)) RS sym
155.447 + | id =>
155.448 + if hd id = "#"
155.449 + then mk_thm thy ct'
155.450 + else (num_str o (PureThy.get_thm thy)) thmid
155.451 + ) handle _ =>
155.452 + raise error ("assoc_thm': '"^thmid^"' not in '"^
155.453 + (theory2domID thy)^"' (and parents)");
155.454 +(*> assoc_thm' Isac.thy ("sym_#mult_2_3","6 = 2 * 3");
155.455 +val it = "6 = 2 * 3" : thm
155.456 +
155.457 +> assoc_thm' Isac.thy ("real_add_zero_left","");
155.458 +val it = "0 + ?z = ?z" : thm
155.459 +
155.460 +> assoc_thm' Isac.thy ("sym_real_add_zero_left","");
155.461 +val it = "?t = 0 + ?t" [.] : thm
155.462 +
155.463 +> assoc_thm' HOL.thy ("sym_real_add_zero_left","");
155.464 +*** Unknown theorem(s) "real_add_zero_left"
155.465 +*** assoc_thm': 'sym_real_add_zero_left' not in 'HOL.thy' (and parents)
155.466 + uncaught exception ERROR*)
155.467 +
155.468 +
155.469 +fun parse' (thy:theory') (ct:cterm') =
155.470 + case parse ((the o assoc')(!theory',thy)) ct of
155.471 + NONE => NONE
155.472 + | SOME ct => SOME ((term2str (term_of ct)):cterm');
155.473 +
155.474 +
155.475 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
155.476 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
155.477 +fun rewrite (thy':theory') (rew_ord:rew_ord') (rls:rls')
155.478 + (put_asm:bool) (thm:thm') (ct:cterm') =
155.479 +(* val (rew_ord, rls, thm, ct) = (rew_ord', id_rls rls', thm', f);
155.480 + *)
155.481 + let val thy = (the o assoc')(!theory',thy');
155.482 + in
155.483 + case rewrite_ thy
155.484 + ((the o assoc')(!rew_ord',rew_ord))((#2 o the o assoc')(!ruleset',rls))
155.485 + put_asm ((assoc_thm' thy) thm)
155.486 + ((term_of o the o (parse thy)) ct) of
155.487 + NONE => NONE
155.488 + | SOME (t, ts) => SOME (term2str t, terms2str ts)
155.489 + end;
155.490 +
155.491 +(*
155.492 +val thy = "RatArith.thy";
155.493 +val rew_ord = "dummy_ord";
155.494 +> val rls = "eval_rls";
155.495 +val put_asm = true;
155.496 +val thm = ("square_equation_left","");
155.497 +val ct = "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
155.498 +
155.499 +val Zthy = ((the o assoc')(!theory',thy));
155.500 +val Zrew_ord = ((the o assoc')(!rew_ord',rew_ord));
155.501 +val Zrls = ((the o assoc')(!ruleset',rls));
155.502 +val Zput_asm = put_asm;
155.503 +val Zthm = ((the o (assoc'_thm' thy)) thm);
155.504 +val Zct = ((the o (parse ((the o assoc')(!theory',thy)))) ct);
155.505 +
155.506 +rewrite_ Zthy Zrew_ord Zrls Zput_asm Zthm Zct;
155.507 +
155.508 + use"Isa99/interface_ME_ISA.sml";
155.509 +*)
155.510 +
155.511 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
155.512 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
155.513 +fun rewrite_set (thy':theory') (put_asm:bool)
155.514 + (rls:rls') (ct:cterm') =
155.515 + let val thy = (the o assoc')(!theory',thy');
155.516 + in
155.517 + case rewrite_set_ thy put_asm ((#2 o the o assoc')(!ruleset',rls))
155.518 + ((term_of o the o (parse thy)) ct) of
155.519 + NONE => NONE
155.520 + | SOME (t, ts) => SOME (term2str t, terms2str ts)
155.521 + end;
155.522 +
155.523 +(*evaluate list-expressions
155.524 + should work on term, and stand in Isa99/rewrite-parse.sml,
155.525 + but there list_rls <- eval_binop is not yet defined*)
155.526 +(*fun eval_listexpr' ct =
155.527 + let val rew = rewrite_set "ListC.thy" false "list_rls" ct;
155.528 + in case rew of
155.529 + SOME (res,_) => res
155.530 + | NONE => ct end;-----------------30.9.02---*)
155.531 +fun eval_listexpr_ thy srls t =
155.532 +(* val (thy, srls, t) =
155.533 + ((assoc_thy th), sr, (subst_atomic (upd_env_opt E (a,v)) t));
155.534 + *)
155.535 + let val rew = rewrite_set_ thy false srls t;
155.536 + in case rew of
155.537 + SOME (res,_) => res
155.538 + | NONE => t end;
155.539 +
155.540 +
155.541 +fun get_calculation' (thy:theory') op_ (ct:cterm') =
155.542 + case get_calculation_ ((the o assoc')(!theory',thy)) op_
155.543 + ((uminus_to_string o term_of o the o
155.544 + (parse ((the o assoc')(!theory',thy)))) ct) of
155.545 + NONE => NONE
155.546 + | SOME (thmid, thm) =>
155.547 + SOME ((thmid, string_of_thmI thm):thm');
155.548 +
155.549 +fun calculate (thy':theory') op_ (ct:cterm') =
155.550 + let val thy = (the o assoc')(!theory',thy');
155.551 + in
155.552 + case calculate_ thy op_
155.553 + ((term_of o the o (parse thy)) ct) of
155.554 + NONE => NONE
155.555 + | SOME (ct,(thmID,thm)) =>
155.556 + SOME (term2str ct,
155.557 + (thmID, string_of_thmI thm):thm')
155.558 + end;
155.559 +(*
155.560 +fun instantiate'' thy' subs ((thmid,ct'):thm') =
155.561 + let val thmid_ = implode ("#"::(explode thmid)) (*see type thm'*)
155.562 + in (thmid_, (string_of_thmI o (read_instantiate subs))
155.563 + ((the o (assoc_thm' thy')) (thmid_,ct'))):thm' end;
155.564 +
155.565 +fun instantiate_rls' thy' subs (rls:rls') =
155.566 + rls2rls' (instantiate_rls subs ((the o (assoc_rls thy')) rls)):rlsdat';
155.567 +
155.568 +... problem with these functions:
155.569 +> val thm = mk_thm thy "(bdv + a = b) = (bdv = b - a)";
155.570 +val thm = "(bdv + a = b) = (bdv = b - a)" : thm
155.571 +> show_types:=true; thm;
155.572 +val it = "((bdv::'a) + (a::'a) = (b::'a)) = (bdv = b - a)" : thm
155.573 +... and this doesn't match because of too general typing (?!)
155.574 + and read_insitantiate doesn't instantiate the types (?!)
155.575 +=== solutions:
155.576 +(1) hard-coded type-instantiation ("'a", "RatArith.rat")
155.577 +(2) instantiate', instantiate ... no help by isabelle-users@ !!!
155.578 +=== conclusion:
155.579 + rewrite_inst, rewrite_set_inst circumvent the problem,
155.580 + according functions out-commented with 'instantiate''
155.581 +*)
155.582 +
155.583 +(* instantiate''
155.584 +fun instantiate'' thy' subs ((thmid,ct'):thm') =
155.585 + let
155.586 + val thmid_ = implode ("#"::(explode thmid)); (*see type thm'*)
155.587 + val thy = (the o assoc')(!theory',thy');
155.588 + val typs = map (#T o rep_cterm o the o (parse thy))
155.589 + ((snd o split_list) subs);
155.590 + val ctyps = map
155.591 + ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o (parse thy))
155.592 + ((snd o split_list) subs);
155.593 +
155.594 +> val thy' = "RatArith.thy";
155.595 +> val subs = [("bdv","x::rat"),("zzz","z::nat")];
155.596 +> (the o (parse ((the o assoc')(!theory',thy')))) "x::rat";
155.597 +> (#T o rep_cterm o the o (parse ((the o assoc')(!theory',thy'))));
155.598 +
155.599 +> val ctyp = ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o
155.600 + (parse ((the o assoc')(!theory',thy')))) "x::rat";
155.601 +> val bdv = (the o (parse thy)) "bdv";
155.602 +> val x = (the o (parse thy)) "x";
155.603 +> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add)
155.604 + handle e => print_exn e;
155.605 +uncaught exception THM
155.606 + raised at: thm.ML:1085.18-1085.69
155.607 + thm.ML:1092.34
155.608 + goals.ML:536.61
155.609 +
155.610 +> val bdv = (the o (parse thy)) "bdv::nat";
155.611 +> val x = (the o (parse thy)) "x::nat";
155.612 +> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add)
155.613 + handle e => print_exn e;
155.614 +uncaught exception THM
155.615 + raised at: thm.ML:1085.18-1085.69
155.616 + thm.ML:1092.34
155.617 + goals.ML:536.61
155.618 +
155.619 +> (instantiate' [SOME ctyp] [] isolate_bdv_add)
155.620 + handle e => print_exn e;
155.621 +uncaught exception TYPE
155.622 + raised at: drule.ML:613.13-615.44
155.623 + goals.ML:536.61
155.624 +
155.625 +> val repct = (rep_cterm o the o (parse ((the o assoc')(!theory',thy')))) "x::rat";
155.626 +*)
155.627 +
155.628 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
155.629 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
155.630 +fun rewrite_inst (thy':theory') (rew_ord:rew_ord') (rls:rls')
155.631 + (put_asm:bool) subs (thm:thm') (ct:cterm') =
155.632 + let
155.633 + val thy = (the o assoc')(!theory',thy');
155.634 + val thm = assoc_thm' thy thm; (*28.10.02*)
155.635 + (*val subthm = read_instantiate subs ((assoc_thm' thy) thm)*)
155.636 + in
155.637 + case rewrite_ thy
155.638 + ((the o assoc')(!rew_ord',rew_ord)) ((#2 o the o assoc')(!ruleset',rls))
155.639 + put_asm (*sub*)thm ((term_of o the o (parse thy)) ct) of
155.640 + NONE => NONE
155.641 + | SOME (ctm, ctms) =>
155.642 + SOME ((term2str ctm):cterm', (map term2str ctms):cterm' list)
155.643 + end;
155.644 +
155.645 +(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
155.646 + thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
155.647 +fun rewrite_set_inst (thy':theory') (put_asm:bool)
155.648 + subs' (rls:rls') (ct:cterm') =
155.649 + let
155.650 + val thy = (the o assoc')(!theory',thy');
155.651 + val rls = assoc_rls rls
155.652 + val subst = subs'2subst thy subs'
155.653 + (*val subrls = instantiate_rls subs ((the o assoc')(!ruleset',rls))*)
155.654 + in case rewrite_set_inst_ thy put_asm subst (*sub*)rls
155.655 + ((term_of o the o (parse thy)) ct) of
155.656 + NONE => NONE
155.657 + | SOME (t, ts) => SOME (term2str t, terms2str ts)
155.658 + end;
155.659 +
155.660 +
155.661 +(*vor check_elementwise: SqRoot_eval_rls .. wie *_simplify ?! TODO *)
155.662 +fun eval_true' (thy':theory') (rls':rls') (Const ("True",_)) = true
155.663 +
155.664 + | eval_true' (thy':theory') (rls':rls') (t:term) =
155.665 +(* val thy'="Isac.thy"; val rls'="eval_rls"; val t=hd pres';
155.666 + *)
155.667 + let val ct' = term2str t;
155.668 + in case rewrite_set thy' false rls' ct' of
155.669 + SOME ("True",_) => true
155.670 + | _ => false
155.671 + end;
155.672 +fun eval_true_ _ _ (Const ("True",_)) = true
155.673 + | eval_true_ (thy':theory') rls t =
155.674 + case rewrite_set_ (assoc_thy thy') false rls t of
155.675 + SOME (Const ("True",_),_) => true
155.676 + | _ => false;
155.677 +
155.678 +(*
155.679 +val test_rls =
155.680 + Rls{preconds = [], rew_ord = ("sqrt_right",sqrt_right),
155.681 + rules = [Calc ("matches",eval_matches "")
155.682 + ],
155.683 + scr = Script ((term_of o the o (parse thy))
155.684 + "empty_script")
155.685 + }:rls;
155.686 +
155.687 +
155.688 +
155.689 + rewrite_set_ Isac.thy eval_rls false test_rls
155.690 + ((the o (parse thy)) "matches (?a = ?b) (x = #0)");
155.691 + val xxx = (term_of o the o (parse thy))
155.692 + "matches (?a = ?b) (x = #0)";
155.693 + eval_matches """" xxx thy;
155.694 +SOME ("matches (?a = ?b) (x + #1 + #-1 * #2 = #0) = True",
155.695 + Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
155.696 +
155.697 +
155.698 +
155.699 + rewrite_set_ Isac.thy eval_rls false eval_rls
155.700 + ((the o (parse thy)) "contains_root (sqrt #0)");
155.701 +val it = SOME ("True",[]) : (cterm * cterm list) option
155.702 +
155.703 +*)
155.704 +
155.705 +
155.706 +(*----------WN:16.5.03 stuff below considered illdesigned, thus coded from scratch in appl.sml fun check_elementwise
155.707 +datatype det = TRUE | FALSE | INDET;(*FIXXME.WN:16.5.03
155.708 + introduced with quick-and-dirty code*)
155.709 +fun determine dts =
155.710 + let val false_indet =
155.711 + filter_out ((curry op= TRUE) o (#1:det * term -> det)) dts
155.712 + val ts = map (#2: det * term -> term) dts
155.713 + in if nil = false_indet then (TRUE, ts)
155.714 + else if nil = filter ((curry op= FALSE) o (#1:det * term -> det))
155.715 + false_indet
155.716 + then (INDET, ts)
155.717 + else (FALSE, ts) end;
155.718 +(* val dts = [(INDET,e_term), (FALSE,HOLogic.false_const),
155.719 + (INDET,e_term), (TRUE,HOLogic.true_const)];
155.720 + determine dts;
155.721 +val it =
155.722 + (FALSE,
155.723 + [Const ("empty","'a"),Const ("False","bool"),Const ("empty","'a"),
155.724 + Const ("True","bool")]) : det * term list*)
155.725 +
155.726 +fun eval__indet_ thy cs rls = (*FIXXME.WN:16.5.03 pull into eval__true_, update check (check_elementwise), and regard eval_true_ + eval_true*)
155.727 +if cs = [HOLogic.true_const] orelse cs = [] then (TRUE, [])
155.728 + else if cs = [HOLogic.false_const] then (FALSE, cs)
155.729 + else
155.730 + let fun eval t =
155.731 + let val taopt = rewrite__set_ thy 1 false [] rls t
155.732 + in case taopt of
155.733 + SOME (t,_) =>
155.734 + if t = HOLogic.true_const then (TRUE, t)
155.735 + else if t = HOLogic.false_const then (FALSE, t)
155.736 + else (INDET, t)
155.737 + | NONE => (INDET, t) end
155.738 + in (determine o (map eval)) cs end;
155.739 +WN.16.5.0-------------------------------------------------------------*)
156.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
156.2 +++ b/src/Tools/isac/ProgLang/scrtools.sml Wed Aug 25 16:20:07 2010 +0200
156.3 @@ -0,0 +1,491 @@
156.4 +(* tools which depend on Script.thy and thus are not in term.sml
156.5 + (c) Walther Neuper 2000
156.6 +
156.7 +use"ProgLang/scrtools.sml";
156.8 +use"scrtools.sml";
156.9 +*)
156.10 +
156.11 +
156.12 +fun is_reall_dsc
156.13 + (Const(_,Type("fun",[Type("List.list",
156.14 + [Type ("real",[])]),_]))) = true
156.15 + | is_reall_dsc
156.16 + (Const(_,Type("fun",[Type("List.list",
156.17 + [Type ("real",[])]),_])) $ t) = true
156.18 + | is_reall_dsc _ = false;
156.19 +fun is_booll_dsc
156.20 + (Const(_,Type("fun",[Type("List.list",
156.21 + [Type ("bool",[])]),_]))) = true
156.22 + | is_booll_dsc
156.23 + (Const(_,Type("fun",[Type("List.list",
156.24 + [Type ("bool",[])]),_])) $ t) = true
156.25 + | is_booll_dsc _ = false;
156.26 +(*
156.27 +> val t = (term_of o the o (parse thy)) "relations";
156.28 +> atomtyp (type_of t);
156.29 +*** Type (fun,[
156.30 +*** Type (List.list,[
156.31 +*** Type (bool,[])
156.32 +*** ]
156.33 +*** Type (Tools.una,[])
156.34 +*** ]
156.35 +> is_booll_dsc t;
156.36 +val it = true : bool
156.37 +> is_reall_dsc t;
156.38 +val it = false : bool
156.39 +*)
156.40 +
156.41 +fun is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_]))) = true
156.42 + | is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_])) $ t) = true
156.43 + (*WN:8.5.03: ??? ~~~~ ???*)
156.44 + | is_list_dsc _ = false;
156.45 +(*
156.46 +> val t = str2term "someList";
156.47 +> is_list_dsc t;
156.48 +val it = true : bool
156.49 +
156.50 +> val t = (term_of o the o (parse thy))
156.51 + "additional_relations [a=b,c=(d::real)]";
156.52 +> is_list_dsc t;
156.53 +val it = true : bool
156.54 +> is_list_dsc (head_of t);
156.55 +val it = true : bool
156.56 +
156.57 +> val t = (term_of o the o (parse thy))"max_relation (A=#2*a*b-a^^^#2)";
156.58 +> is_list_dsc t;
156.59 +val it = false : bool
156.60 +> is_list_dsc (head_of t);
156.61 +val it = false : bool
156.62 +> val t = (term_of o the o (parse thy)) "testdscforlist";
156.63 +> is_list_dsc (head_of t);
156.64 +val it = true : bool
156.65 +*)
156.66 +
156.67 +
156.68 +fun is_unl (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true
156.69 + | is_unl _ = false;
156.70 +(*
156.71 +> val t = str2term "someList"; is_unl t;
156.72 +val it = true : bool
156.73 +> val t = (term_of o the o (parse thy)) "maximum";
156.74 +> is_unl t;
156.75 +val it = false : bool
156.76 +*)
156.77 +
156.78 +fun is_dsc (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) = true
156.79 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.una",_)]))) = true
156.80 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true
156.81 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.str",_)]))) = true
156.82 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) = true
156.83 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))= true
156.84 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.tobooll",_)])))= true
156.85 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.unknow",_)])))= true
156.86 + | is_dsc (Const(_,Type("fun",[_,Type("Tools.cpy",_)])))= true
156.87 + | is_dsc _ = false;
156.88 +fun is_dsc term =
156.89 + (case (range_type o type_of) term of
156.90 + Type("Tools.nam",_) => true
156.91 + | Type("Tools.una",_) => true
156.92 + | Type("Tools.unl",_) => true
156.93 + | Type("Tools.str",_) => true
156.94 + | Type("Tools.toreal",_) => true
156.95 + | Type("Tools.toreall",_) => true
156.96 + | Type("Tools.tobooll",_) => true
156.97 + | Type("Tools.unknow",_) => true
156.98 + | Type("Tools.cpy",_) => true
156.99 + | _ => false)
156.100 + handle Match => false;
156.101 +
156.102 +
156.103 +(*
156.104 +val t as t1 $ t2 = str2term "antiDerivativeName M_b";
156.105 +val Const (_, Type ("fun", [Type ("fun", _), Type ("Tools.una",[])])) $ _ = t;
156.106 +is_dsc t1;
156.107 +
156.108 +> val t = (term_of o the o (parse thy)) "maximum";
156.109 +> is_dsc t;
156.110 +val it = true : bool
156.111 +> val t = (term_of o the o (parse thy)) "testdscforlist";
156.112 +> is_dsc t;
156.113 +val it = true : bool
156.114 +
156.115 +> val t = (head_of o term_of o the o (parse thy)) "maximum A";
156.116 +> is_dsc t;
156.117 +val it = true : bool
156.118 +> val t = (head_of o term_of o the o (parse thy))
156.119 + "fixedValues [R=(R::real)]";
156.120 +> is_dsc t;
156.121 +val it = true : bool
156.122 +*)
156.123 +
156.124 +
156.125 +(*make the term 'Subproblem (domID, pblID)' to a formula for frontend;
156.126 + needs to be here after def. Subproblem in Script.thy*)
156.127 +val t as (subpbl_t $ (pair_t $ Free (domID,_) $ pblID)) =
156.128 + (term_of o the o (parse @{theory Script}))
156.129 + "Subproblem (Isac,[equation,univar])";
156.130 +val t as (pbl_t $ _) =
156.131 + (term_of o the o (parse @{theory Script}))
156.132 + "Problem (Isac,[equation,univar])";
156.133 +val Free (_, ID_type) = (term_of o the o (parse @{theory Script})) "x::ID";
156.134 +
156.135 +
156.136 +fun subpbl domID pblID =
156.137 + subpbl_t $ (pair_t $ Free (domID,ID_type) $
156.138 + (((list2isalist ID_type) o (map (mk_free ID_type))) pblID));
156.139 +(*> subpbl "Isac" ["equation","univar"] = t;
156.140 +val it = true : bool *)
156.141 +
156.142 +
156.143 +fun pblterm (domID:domID) (pblID:pblID) =
156.144 + pbl_t $ (pair_t $ Free (domID,ID_type) $
156.145 + (((list2isalist ID_type) o (map (mk_free ID_type))) pblID));
156.146 +
156.147 +
156.148 +(**.construct scr-env from scr(created automatically) and Rewrite_Set.**)
156.149 +
156.150 +fun one_scr_arg (Const _ $ arg $ _) = arg
156.151 + | one_scr_arg t = raise error ("one_scr_arg: called by "^(term2str t));
156.152 +fun two_scr_arg (Const _ $ a1 $ a2 $ _) = (a1, a2)
156.153 + | two_scr_arg t = raise error ("two_scr_arg: called by "^(term2str t));
156.154 +
156.155 +
156.156 +(**.generate calc from a script.**)
156.157 +
156.158 +(*.instantiate a stactic or scriptexpr, and ev. attach (curried) argument
156.159 +args:
156.160 + E environment
156.161 + v current value, is attached to curried stactics
156.162 + stac stactic to be instantiated
156.163 +precond:
156.164 + not (a = NONE) /\ (v = e_term) /\ (stac curried, i.e. without last arg.)
156.165 + this ........................ is the initialization for assy with l=[],
156.166 + but the 1st stac is
156.167 + (a) curried: then (a = SOME _), or
156.168 + (b) not curried: then the values of the initialization are not used
156.169 +.*)
156.170 +datatype stacexpr = STac of term | Expr of term
156.171 +fun rep_stacexpr (STac t ) = t
156.172 + | rep_stacexpr (Expr t) =
156.173 + raise error ("rep_stacexpr called with t= "^(term2str t));
156.174 +
156.175 +type env = (term * term) list;
156.176 +
156.177 +(*update environment; t <> empty if coming from listexpr*)
156.178 +fun upd_env (env:env) (v,t) =
156.179 + let val env' = if t = e_term then env else overwrite (env,(v,t));
156.180 + (*val _= writeln("### upd_env: = "^(subst2str env'));*)
156.181 + in env' end;
156.182 +
156.183 +(*.substitute the scripts environment in a leaf of the scripts parse-tree
156.184 + and attach the curried argument of a tactic, if any.
156.185 + a leaf is either a tactic or an 'exp' in 'let v = expr'
156.186 + where 'exp' does not contain a tactic.
156.187 +CAUTION: (1) currying with @@ requires 2 patterns for each tactic
156.188 + (2) the non-curried version must return NONE for a
156.189 + (3) non-matching patterns become an Expr by fall-through.
156.190 +WN060906 quick and dirty fix: due to (2) a is returned, too.*)
156.191 +fun subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ $ _ ))=
156.192 + (NONE, STac (subst_atomic E t))
156.193 +
156.194 + | subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ ))=
156.195 + (a, (*in these cases we hope, that a = SOME _*)
156.196 + STac (case a of SOME a' => (subst_atomic E (t $ a'))
156.197 + | NONE => ((subst_atomic E t) $ v)))
156.198 +
156.199 + | subst_stacexpr E a v
156.200 + (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ _ )) =
156.201 + (NONE, STac (subst_atomic E t))
156.202 +
156.203 + | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _))=
156.204 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.205 + | NONE => ((subst_atomic E t) $ v)))
156.206 +
156.207 + | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ _ ))=
156.208 + (NONE, STac (subst_atomic E t))
156.209 +
156.210 + | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ )) =
156.211 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.212 + | NONE => ((subst_atomic E t) $ v)))
156.213 +
156.214 + | subst_stacexpr E a v
156.215 + (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ _ )) =
156.216 + (NONE, STac (subst_atomic E t))
156.217 +
156.218 + | subst_stacexpr E a v
156.219 + (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ )) =
156.220 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.221 + | NONE => ((subst_atomic E t) $ v)))
156.222 +
156.223 + | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ $ _ )) =
156.224 + (NONE, STac (subst_atomic E t))
156.225 +
156.226 + | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ )) =
156.227 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.228 + | NONE => ((subst_atomic E t) $ v)))
156.229 +
156.230 + | subst_stacexpr E a v
156.231 + (t as (Const("Script.Check'_elementwise",_) $ _ $ _ )) =
156.232 + (NONE, STac (subst_atomic E t))
156.233 +
156.234 + | subst_stacexpr E a v (t as (Const("Script.Check'_elementwise",_) $ _ )) =
156.235 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.236 + | NONE => ((subst_atomic E t) $ v)))
156.237 +
156.238 + | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_) $ _ )) =
156.239 + (NONE, STac (subst_atomic E t))
156.240 +
156.241 + | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_))) = (*t $ v*)
156.242 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.243 + | NONE => ((subst_atomic E t) $ v)))
156.244 +
156.245 + | subst_stacexpr E a v (t as (Const ("Script.SubProblem",_) $ _ $ _ )) =
156.246 + (NONE, STac (subst_atomic E t))
156.247 +
156.248 + | subst_stacexpr E a v (t as (Const ("Script.Take",_) $ _ )) =
156.249 + (NONE, STac (subst_atomic E t))
156.250 +
156.251 + | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ $ _ )) =
156.252 + (NONE, STac (subst_atomic E t))
156.253 +
156.254 + | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ )) =
156.255 + (a, STac (case a of SOME a' => subst_atomic E (t $ a')
156.256 + | NONE => ((subst_atomic E t) $ v)))
156.257 +
156.258 + (*now all tactics are matched out and this leaf must be without a tactic*)
156.259 + | subst_stacexpr E a v t =
156.260 + (a, Expr (subst_atomic (case a of SOME a => upd_env E (a,v)
156.261 + | NONE => E) t));
156.262 +(*> val t = str2term "SubProblem(Test_, [linear, univariate, equation, test], [Test, solve_linear]) [bool_ e_, real_ v_]";
156.263 +> subst_stacexpr [] NONE e_term t;*)
156.264 +
156.265 +
156.266 +fun stacpbls (h $ body) =
156.267 + let
156.268 + fun scan ts (Const ("Let",_) $ e $ (Abs (v,T,b))) =
156.269 + (scan ts e) @ (scan ts b)
156.270 + | scan ts (Const ("If",_) $ c $ e1 $ e2) = (scan ts e1) @ (scan ts e2)
156.271 + | scan ts (Const ("Script.While",_) $ c $ e $ _) = scan ts e
156.272 + | scan ts (Const ("Script.While",_) $ c $ e) = scan ts e
156.273 + | scan ts (Const ("Script.Repeat",_) $ e $ _) = scan ts e
156.274 + | scan ts (Const ("Script.Repeat",_) $ e) = scan ts e
156.275 + | scan ts (Const ("Script.Try",_) $ e $ _) = scan ts e
156.276 + | scan ts (Const ("Script.Try",_) $ e) = scan ts e
156.277 + | scan ts (Const ("Script.Or",_) $e1 $ e2 $ _) =
156.278 + (scan ts e1) @ (scan ts e2)
156.279 + | scan ts (Const ("Script.Or",_) $e1 $ e2) =
156.280 + (scan ts e1) @ (scan ts e2)
156.281 + | scan ts (Const ("Script.Seq",_) $e1 $ e2 $ _) =
156.282 + (scan ts e1) @ (scan ts e2)
156.283 + | scan ts (Const ("Script.Seq",_) $e1 $ e2) =
156.284 + (scan ts e1) @ (scan ts e2)
156.285 + | scan ts t = case subst_stacexpr [] NONE e_term t of
156.286 + (_, STac _) => [t] | (_, Expr _) => []
156.287 + in (distinct o (scan [])) body end;
156.288 + (*sc = Solve_root_equation ...
156.289 +> val ts = stacpbls sc;
156.290 +> writeln (terms2str thy ts);
156.291 +["Rewrite square_equation_left True e_",
156.292 + "Rewrite_Set SqRoot_simplify False e_",
156.293 + "Rewrite_Set rearrange_assoc False e_",
156.294 + "Rewrite_Set isolate_root False e_",
156.295 + "Rewrite_Set norm_equation False e_",
156.296 + "Rewrite_Set_Inst [(bdv, v_)] isolate_bdv False e_"]
156.297 +*)
156.298 +
156.299 +
156.300 +
156.301 +fun is_calc (Const ("Script.Calculate",_) $ _) = true
156.302 + | is_calc (Const ("Script.Calculate",_) $ _ $ _) = true
156.303 + | is_calc _ = false;
156.304 +fun op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_)) = op_
156.305 + | op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_) $ _) = op_
156.306 + | op_of_calc t = raise error ("op_of_calc called with"^term2str t);
156.307 +(*
156.308 + val Script sc = (#scr o rep_rls) Test_simplify;
156.309 + val stacs = stacpbls sc;
156.310 +
156.311 + val calcs = filter is_calc stacs;
156.312 + val ids = map op_of_calc calcs;
156.313 + map (curry assoc1 (!calclist')) ids;
156.314 +
156.315 + (((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
156.316 + (filter is_calc) o stacpbls) sc):calc list;
156.317 +*)
156.318 +
156.319 +(**.for automatic creation of scripts from rls.**)
156.320 +(* naming of identifiers in scripts ???...
156.321 +((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t::'z) = t";
156.322 +((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o
156.323 + (parse @{theory})) "(t't::'z) = t't";
156.324 +((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_t::'z) = t_t";
156.325 +(* not accepted !!!...*)
156.326 +((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_::'z) = t_";
156.327 +((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o
156.328 + (parse @{theory})) "(_t::'z) = _t";
156.329 +*)
156.330 +((inst_abs @{theory}) o term_of o the o (parse @{theory}))
156.331 +"Script Stepwise (t::'z) =\
156.332 + \(Repeat\
156.333 + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
156.334 + \ (Try (Repeat (Rewrite real_add_commute False))) @@ \
156.335 + \ (Try (Repeat (Rewrite real_mult_commute False)))) \
156.336 + \ t_t)";
156.337 +val ScrStep $ _ $ _ = (*'z not affected by parse: 'a --> real*)
156.338 + ((inst_abs @{theory}) o term_of o the o (parse @{theory}))
156.339 + "Script Stepwise (t::'z) =\
156.340 + \(Repeat\
156.341 + \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
156.342 + \ (Try (Repeat (Rewrite real_add_commute False))) @@ \
156.343 + \ (Try (Repeat (Rewrite real_mult_commute False)))) \
156.344 + \ t_t)";
156.345 +(*WN060605 script-arg (t_::'z) and "Free (t_, 'a)" at end of body
156.346 +are inconsistent !!!*)
156.347 +val ScrStep_inst $ Term $ Bdv $ _=(*'z not affected by parse: 'a --> real*)
156.348 + ((inst_abs @{theory}) o term_of o the o (parse @{theory}))
156.349 + "Script Stepwise_inst (t::'z) (v::real) =\
156.350 + \(Repeat\
156.351 + \ ((Try (Repeat (Rewrite_Inst [(bdv,v)] real_diff_minus False))) @@ \
156.352 + \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_add_commute False))) @@\
156.353 + \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_mult_commute False)))) \
156.354 + \ t)";
156.355 +val Repeat $ _ =
156.356 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.357 + "Repeat (Rewrite real_diff_minus False t)";
156.358 +val Try $ _ =
156.359 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.360 + "Try (Rewrite real_diff_minus False t)";
156.361 +val Cal $ _ =
156.362 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.363 + "Calculate PLUS";
156.364 +val Ca1 $ _ =
156.365 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.366 + "Calculate1 PLUS";
156.367 +val Rew $ (Free (_,IDtype)) $ _ $ t =
156.368 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.369 + "Rewrite real_diff_minus False t";
156.370 +val Rew_Inst $ Subs $ _ $ _ =
156.371 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.372 + "Rewrite_Inst [(bdv,v)] real_diff_minus False";
156.373 +val Rew_Set $ _ $ _ =
156.374 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.375 + "Rewrite_Set real_diff_minus False";
156.376 +val Rew_Set_Inst $ _ $ _ $ _ =
156.377 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.378 + "Rewrite_Set_Inst [(bdv,v)] real_diff_minus False";
156.379 +val SEq $ _ $ _ $ _ =
156.380 + ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
156.381 + " ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
156.382 + \ (Try (Repeat (Rewrite real_add_commute False))) @@ \
156.383 + \ (Try (Repeat (Rewrite real_mult_commute False)))) t";
156.384 +
156.385 +fun rule2stac _ (Thm (thmID, _)) =
156.386 + Try $ (Repeat $ (Rew $ Free (thmID, IDtype) $ HOLogic.false_const))
156.387 + | rule2stac calc (Calc (c, _)) =
156.388 + Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype)))
156.389 + | rule2stac calc (Cal1 (c, _)) =
156.390 + Try $ (Repeat $ (Ca1 $ Free (assoc_calc (calc ,c), IDtype)))
156.391 + | rule2stac _ (Rls_ rls) =
156.392 + Try $ (Rew_Set $ Free (id_rls rls, IDtype) $ HOLogic.false_const);
156.393 +(*val t = rule2stac [] (Thm ("real_diff_minus", num_str real_diff_minus));
156.394 +atomt t; term2str t;
156.395 +val t = rule2stac calclist (Calc ("op +", eval_binop "#add_"));
156.396 +atomt t; term2str t;
156.397 +val t = rule2stac [] (Rls_ rearrange_assoc);
156.398 +atomt t; term2str t;
156.399 +*)
156.400 +fun rule2stac_inst _ (Thm (thmID, _)) =
156.401 + Try $ (Repeat $ (Rew_Inst $ Subs $ Free (thmID, IDtype) $
156.402 + HOLogic.false_const))
156.403 + | rule2stac_inst calc (Calc (c, _)) =
156.404 + Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype)))
156.405 + | rule2stac_inst calc (Cal1 (c, _)) =
156.406 + Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype)))
156.407 + | rule2stac_inst _ (Rls_ rls) =
156.408 + Try $ (Rew_Set_Inst $ Subs $ Free (id_rls rls, IDtype) $
156.409 + HOLogic.false_const);
156.410 +(*val t = rule2stac_inst [] (Thm ("real_diff_minus", num_str real_diff_minus));
156.411 +atomt t; term2str t;
156.412 +val t = rule2stac_inst calclist (Calc ("op +", eval_binop "#add_"));
156.413 +atomt t; term2str t;
156.414 +val t = rule2stac_inst [] (Rls_ rearrange_assoc);
156.415 +atomt t; term2str t;
156.416 +*)
156.417 +
156.418 +(*for appropriate nesting take stacs in _reverse_ order*)
156.419 +fun @@@ sts [s] = SEq $ s $ sts
156.420 + | @@@ sts (s::ss) = @@@ (SEq $ s $ sts) ss;
156.421 +fun @@ [stac] = stac
156.422 + | @@ [s1, s2] = SEq $ s1 $ s2 (*---------vvv--*)
156.423 + | @@ stacs =
156.424 + let val s3::s2::ss = rev stacs
156.425 + in @@@ (SEq $ s2 $ s3) ss end;
156.426 +(*
156.427 + val rules = (#rules o rep_rls) isolate_root;
156.428 + val rs = map (rule2stac calclist) rules;
156.429 + val tt = @@ rs;
156.430 + atomt tt; writeln (term2str tt);
156.431 + *)
156.432 +
156.433 +val contains_bdv = (not o null o (filter is_bdv) o ids2str o #prop o rep_thm);
156.434 +
156.435 +(*.does a rule contain a 'bdv'; descend recursively into Rls_.*)
156.436 +fun contain_bdv [] = false
156.437 + | contain_bdv (Thm (_, thm)::rs) =
156.438 + if (not o contains_bdv) thm
156.439 + then contain_bdv rs
156.440 + else true
156.441 + | contain_bdv (Calc _ ::rs) = contain_bdv rs
156.442 + | contain_bdv (Cal1 _ ::rs) = contain_bdv rs
156.443 + | contain_bdv (Rls_ rls ::rs) =
156.444 + contain_bdv (get_rules rls) orelse contain_bdv rs
156.445 + | contain_bdv (r::_) =
156.446 + raise error ("contain_bdv called with ["^(id_rule r)^",...]");
156.447 +
156.448 +fun rules2scr_Rls calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*)
156.449 + if contain_bdv rules
156.450 + then ScrStep_inst $ Term $ Bdv $
156.451 + (Repeat $ (((@@ o (map (rule2stac_inst calc))) rules) $ e_term))
156.452 + else ScrStep $ Term $
156.453 + (Repeat $ (((@@ o (map (rule2stac calc))) rules) $ e_term));
156.454 +(* val (calc, rules) = (!calclist', rules);
156.455 + *)
156.456 +fun rules2scr_Seq calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*)
156.457 + if contain_bdv rules
156.458 + then ScrStep_inst $ Term $ Bdv $
156.459 + (((@@ o (map (rule2stac_inst calc))) rules) $ e_term)
156.460 + else ScrStep $ Term $
156.461 + (((@@ o (map (rule2stac calc))) rules) $ e_term);
156.462 +
156.463 +(*.prepare the input for an rls for use:
156.464 + # generate a script for stepwise execution of the rls
156.465 + # filter the operators for Calc out of the script
156.466 + !!!use this function in ruleset' := !!! .*)
156.467 +fun prep_rls Erls = raise error "prep_rls not impl. for Erls"
156.468 + | prep_rls (Rls {id,preconds,rew_ord,erls,srls,calc,rules,...}) =
156.469 + let val sc = (rules2scr_Rls (!calclist') rules)
156.470 + in Rls {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls,
156.471 + srls=srls,
156.472 + calc = (*FIXXXME.040207 use also for met*)
156.473 + ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
156.474 + (filter is_calc) o stacpbls) sc,
156.475 + rules=rules,
156.476 + scr = Script sc} end
156.477 +(* val (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) = add_new_c;
156.478 + *)
156.479 + | prep_rls (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) =
156.480 + let val sc = (rules2scr_Seq (!calclist') rules)
156.481 + in Seq {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls,
156.482 + srls=srls,
156.483 + calc = ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
156.484 + (filter is_calc) o stacpbls) sc,
156.485 + rules=rules,
156.486 + scr = Script sc} end
156.487 + | prep_rls (Rrls {id,...}) =
156.488 + raise error ("prep_rls not required for Rrls \""^id^"\"");
156.489 +(*
156.490 + val Script sc = (#scr o rep_rls o prep_rls) isolate_root;
156.491 + (writeln o term2str) sc;
156.492 + val Script sc = (#scr o rep_rls o prep_rls) isolate_bdv;
156.493 + (writeln o term2str) sc;
156.494 + *)
157.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
157.2 +++ b/src/Tools/isac/ProgLang/term.sml Wed Aug 25 16:20:07 2010 +0200
157.3 @@ -0,0 +1,1343 @@
157.4 +(* extends Isabelle/src/Pure/term.ML
157.5 + (c) Walther Neuper 1999
157.6 +
157.7 +use"ProgLang/term.sml";
157.8 +use"term.sml";
157.9 +*)
157.10 +
157.11 +(*
157.12 +> (cterm_of thy) a_term;
157.13 +val it = "empty" : cterm *)
157.14 +
157.15 +(*2003 fun match thy t pat =
157.16 + (snd (Pattern.match (Sign.tsig_of (sign_of thy)) (pat, t)))
157.17 + handle _ => [];
157.18 +fn : theory ->
157.19 + Term.term -> Term.term -> (Term.indexname * Term.term) list*)
157.20 +(*see src/Tools/eqsubst.ML fun clean_match*)
157.21 +(*2003 fun matches thy tm pa = if match thy tm pa = [] then false else true;*)
157.22 +fun matches thy tm pa =
157.23 + (Pattern.match thy (pa, tm) (Vartab.empty, Vartab.empty); true)
157.24 + handle _ => false
157.25 +
157.26 +fun atomtyp t = (*see raw_pp_typ*)
157.27 + let
157.28 + fun ato n (Type (s,[])) =
157.29 + ("\n*** "^indent n^"Type ("^s^",[])")
157.30 + | ato n (Type (s,Ts)) =
157.31 + ("\n*** "^indent n^"Type ("^s^",["^ atol (n+1) Ts)
157.32 +
157.33 + | ato n (TFree (s,sort)) =
157.34 + ("\n*** "^indent n^"TFree ("^s^",["^ strs2str' sort)
157.35 +
157.36 + | ato n (TVar ((s,i),sort)) =
157.37 + ("\n*** "^indent n^"TVar (("^s^","^
157.38 + string_of_int i ^ strs2str' sort)
157.39 + and atol n [] =
157.40 + ("\n*** "^indent n^"]")
157.41 + | atol n (T::Ts) = (ato n T ^ atol n Ts)
157.42 +(*in print (ato 0 t ^ "\n") end; TODO TUM10*)
157.43 +in writeln(ato 0 t) end;
157.44 +
157.45 +(*Prog.Tutorial.p.34*)
157.46 +local
157.47 + fun pp_pair (x, y) = Pretty.list "(" ")" [x, y]
157.48 + fun pp_list xs = Pretty.list "[" "]" xs
157.49 + fun pp_str s = Pretty.str s
157.50 + fun pp_qstr s = Pretty.quote (pp_str s)
157.51 + fun pp_int i = pp_str (string_of_int i)
157.52 + fun pp_sort S = pp_list (map pp_qstr S)
157.53 + fun pp_constr a args = Pretty.block [pp_str a, Pretty.brk 1, args]
157.54 +in
157.55 +fun raw_pp_typ (TVar ((a, i), S)) =
157.56 + pp_constr "TVar" (pp_pair (pp_pair (pp_qstr a, pp_int i), pp_sort S))
157.57 + | raw_pp_typ (TFree (a, S)) =
157.58 + pp_constr "TFree" (pp_pair (pp_qstr a, pp_sort S))
157.59 + | raw_pp_typ (Type (a, tys)) =
157.60 + pp_constr "Type" (pp_pair (pp_qstr a, pp_list (map raw_pp_typ tys)))
157.61 +end
157.62 +(* install
157.63 +PolyML.addPrettyPrinter
157.64 + (fn _ => fn _ => ml_pretty o Pretty.to_ML o raw_pp_typ);
157.65 +de-install
157.66 +PolyML.addPrettyPrinter
157.67 + (fn _ => fn _ => ml_pretty o Pretty.to_ML o Proof_Display.pp_typ Pure.thy);
157.68 +*)
157.69 +
157.70 +(*
157.71 +> val T = (type_of o term_of o the o (parse thy)) "a::[real,int] => nat";
157.72 +> atomtyp T;
157.73 +*** Type (fun,[
157.74 +*** Type (RealDef.real,[])
157.75 +*** Type (fun,[
157.76 +*** Type (IntDef.int,[])
157.77 +*** Type (nat,[])
157.78 +*** ]
157.79 +*** ]
157.80 +*)
157.81 +
157.82 +fun atomt t =
157.83 + let fun ato (Const(a,T)) n =
157.84 + ("\n*** "^indent n^"Const ("^a^")")
157.85 + | ato (Free (a,T)) n =
157.86 + ("\n*** "^indent n^"Free ("^a^", "^")")
157.87 + | ato (Var ((a,ix),T)) n =
157.88 + ("\n*** "^indent n^"Var (("^a^", "^(string_of_int ix)^"), "^")")
157.89 + | ato (Bound ix) n =
157.90 + ("\n*** "^indent n^"Bound "^(string_of_int ix))
157.91 + | ato (Abs(a,T,body)) n =
157.92 + ("\n*** "^indent n^"Abs("^a^",..")^ato body (n+1)
157.93 + | ato (f$t') n = (ato f n; ato t' (n+1))
157.94 + in writeln("\n*** -------------"^ ato t 0 ^"\n***") end;
157.95 +
157.96 +fun term_detail2str t =
157.97 + let fun ato (Const (a, T)) n =
157.98 + "\n*** "^indent n^"Const ("^a^", "^string_of_typ T^")"
157.99 + | ato (Free (a, T)) n =
157.100 + "\n*** "^indent n^"Free ("^a^", "^string_of_typ T^")"
157.101 + | ato (Var ((a, ix), T)) n =
157.102 + "\n*** "^indent n^"Var (("^a^", "^string_of_int ix^"), "^
157.103 + string_of_typ T^")"
157.104 + | ato (Bound ix) n =
157.105 + "\n*** "^indent n^"Bound "^string_of_int ix
157.106 + | ato (Abs(a, T, body)) n =
157.107 + "\n*** "^indent n^"Abs ("^a^", "^
157.108 + (string_of_typ T)^",.."
157.109 + ^ato body (n + 1)
157.110 + | ato (f $ t') n = ato f n^ato t' (n+1)
157.111 + in "\n*** "^ato t 0^"\n***" end;
157.112 +fun atomty t = (writeln o term_detail2str) t;
157.113 +
157.114 +fun term_str thy (Const(s,_)) = s
157.115 + | term_str thy (Free(s,_)) = s
157.116 + | term_str thy (Var((s,i),_)) = s^(string_of_int i)
157.117 + | term_str thy (Bound i) = "B."^(string_of_int i)
157.118 + | term_str thy (Abs(s,_,_)) = s
157.119 + | term_str thy t = raise error("term_str not for "^term2str t);
157.120 +
157.121 +(*.contains the fst argument the second argument (a leave! of term).*)
157.122 +fun contains_term (Abs(_,_,body)) t = contains_term body t
157.123 + | contains_term (f $ f') t =
157.124 + contains_term f t orelse contains_term f' t
157.125 + | contains_term s t = t = s;
157.126 +(*.contains the term a VAR(("*",_),_) ?.*)
157.127 +fun contains_Var (Abs(_,_,body)) = contains_Var body
157.128 + | contains_Var (f $ f') = contains_Var f orelse contains_Var f'
157.129 + | contains_Var (Var _) = true
157.130 + | contains_Var _ = false;
157.131 +(* contains_Var (str2term "?z = 3") (*true*);
157.132 + contains_Var (str2term "z = 3") (*false*);
157.133 + *)
157.134 +
157.135 +(*fun int_of_str str =
157.136 + let val ss = explode str
157.137 + val str' = case ss of
157.138 + "("::s => drop_last s | _ => ss
157.139 + in case BasisLibrary.Int.fromString (implode str') of
157.140 + SOME i => SOME i
157.141 + | NONE => NONE end;*)
157.142 +fun int_of_str str =
157.143 + let val ss = explode str
157.144 + val str' = case ss of
157.145 + "("::s => drop_last s | _ => ss
157.146 + in (SOME (Thy_Output.integer (implode str'))) handle _ => NONE end;
157.147 +(*
157.148 +> int_of_str "123";
157.149 +val it = SOME 123 : int option
157.150 +> int_of_str "(-123)";
157.151 +val it = SOME 123 : int option
157.152 +> int_of_str "#123";
157.153 +val it = NONE : int option
157.154 +> int_of_str "-123";
157.155 +val it = SOME ~123 : int option
157.156 +*)
157.157 +fun int_of_str' str =
157.158 + case int_of_str str of
157.159 + SOME i => i
157.160 + | NONE => raise TERM ("int_of_string: no int-string",[]);
157.161 +val str2int = int_of_str';
157.162 +
157.163 +fun is_numeral str = case int_of_str str of
157.164 + SOME _ => true
157.165 + | NONE => false;
157.166 +val is_no = is_numeral;
157.167 +fun is_num (Free (s,_)) = if is_numeral s then true else false
157.168 + | is_num _ = false;
157.169 +(*>
157.170 +> is_num ((term_of o the o (parse thy)) "#1");
157.171 +val it = true : bool
157.172 +> is_num ((term_of o the o (parse thy)) "#-1");
157.173 +val it = true : bool
157.174 +> is_num ((term_of o the o (parse thy)) "a123");
157.175 +val it = false : bool
157.176 +*)
157.177 +
157.178 +(*fun int_of_Free (Free (intstr, _)) =
157.179 + (case BasisLibrary.Int.fromString intstr of
157.180 + SOME i => i
157.181 + | NONE => raise error ("int_of_Free ( "^ intstr ^", _)"))
157.182 + | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )");*)
157.183 +fun int_of_Free (Free (intstr, _)) = (Thy_Output.integer intstr
157.184 + handle _ => raise error ("int_of_Free ( "^ intstr ^", _)"))
157.185 + | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )");
157.186 +
157.187 +fun vars t =
157.188 + let
157.189 + fun scan vs (Const(s,T)) = vs
157.190 + | scan vs (t as Free(s,T)) = if is_no s then vs else t::vs
157.191 + | scan vs (t as Var((s,i),T)) = t::vs
157.192 + | scan vs (Bound i) = vs
157.193 + | scan vs (Abs(s,T,t)) = scan vs t
157.194 + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
157.195 + in (distinct o (scan [])) t end;
157.196 +
157.197 +fun is_Free (Free _) = true
157.198 + | is_Free _ = false;
157.199 +fun is_fun_id (Const _) = true
157.200 + | is_fun_id (Free _) = true
157.201 + | is_fun_id _ = false;
157.202 +fun is_f_x (f $ x) = is_fun_id f andalso is_Free x
157.203 + | is_f_x _ = false;
157.204 +(* is_f_x (str2term "q_0/2 * L * x") (*false*);
157.205 + is_f_x (str2term "M_b x") (*true*);
157.206 + *)
157.207 +fun vars_str t =
157.208 + let
157.209 + fun scan vs (Const(s,T)) = vs
157.210 + | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs
157.211 + | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs
157.212 + | scan vs (Bound i) = vs
157.213 + | scan vs (Abs(s,T,t)) = scan vs t
157.214 + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
157.215 + in (distinct o (scan [])) t end;
157.216 +
157.217 +fun ids2str t =
157.218 + let
157.219 + fun scan vs (Const(s,T)) = if is_no s then vs else s::vs
157.220 + | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs
157.221 + | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs
157.222 + | scan vs (Bound i) = vs
157.223 + | scan vs (Abs(s,T,t)) = scan (s::vs) t
157.224 + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
157.225 + in (distinct o (scan [])) t end;
157.226 +fun is_bdv str =
157.227 + case explode str of
157.228 + "b"::"d"::"v"::_ => true
157.229 + | _ => false;
157.230 +fun is_bdv_ (Free (s,_)) = is_bdv s
157.231 + | is_bdv_ _ = false;
157.232 +
157.233 +fun free2str (Free (s,_)) = s
157.234 + | free2str t = raise error ("free2str not for "^ term2str t);
157.235 +fun free2int (t as Free (s, _)) = ((str2int s)
157.236 + handle _ => raise error ("free2int: "^term_detail2str t))
157.237 + | free2int t = raise error ("free2int: "^term_detail2str t);
157.238 +
157.239 +(*27.8.01: unused*)
157.240 +fun var2free (t as Const(s,T)) = t
157.241 + | var2free (t as Free(s,T)) = t
157.242 + | var2free (Var((s,i),T)) = Free(s,T)
157.243 + | var2free (t as Bound i) = t
157.244 + | var2free (Abs(s,T,t)) = Abs(s,T,var2free t)
157.245 + | var2free (t1 $ t2) = (var2free t1) $ (var2free t2);
157.246 +
157.247 +(*27.8.01: doesn't find some subterm ???!???*)
157.248 +(*2010 Logic.varify !!!*)
157.249 +fun free2var (t as Const(s,T)) = t
157.250 + | free2var (t as Free(s,T)) = if is_no s then t else Var((s,0),T)
157.251 + | free2var (t as Var((s,i),T)) = t
157.252 + | free2var (t as Bound i) = t
157.253 + | free2var (Abs(s,T,t)) = Abs(s,T,free2var t)
157.254 + | free2var (t1 $ t2) = (free2var t1) $ (free2var t2);
157.255 +
157.256 +
157.257 +fun mk_listT T = Type ("List.list", [T]);
157.258 +fun list_const T =
157.259 + Const("List.list.Cons", [T, mk_listT T] ---> mk_listT T);
157.260 +(*28.8.01: TODO: get type from head of list: 1 arg less!!!*)
157.261 +fun list2isalist T [] = Const("List.list.Nil",mk_listT T)
157.262 + | list2isalist T (t::ts) = (list_const T) $ t $ (list2isalist T ts);
157.263 +(*
157.264 +> val tt = (term_of o the o (parse thy)) "R=(R::real)";
157.265 +> val TT = type_of tt;
157.266 +> val ss = list2isalist TT [tt,tt,tt];
157.267 +> (cterm_of thy) ss;
157.268 +val it = "[R = R, R = R, R = R]" : cterm *)
157.269 +
157.270 +fun isapair2pair (Const ("Pair",_) $ a $ b) = (a,b)
157.271 + | isapair2pair t =
157.272 + raise error ("isapair2pair called with "^term2str t);
157.273 +
157.274 +val listType = Type ("List.list",[Type ("bool",[])]);
157.275 +fun isalist2list ls =
157.276 + let
157.277 + fun get es (Const("List.list.Cons",_) $ t $ ls) = get (t::es) ls
157.278 + | get es (Const("List.list.Nil",_)) = es
157.279 + | get _ t =
157.280 + raise error ("isalist2list applied to NON-list '"^term2str t^"'")
157.281 + in (rev o (get [])) ls end;
157.282 +(*
157.283 +> val il = str2term "[a=b,c=d,e=f]";
157.284 +> val l = isalist2list il;
157.285 +> (writeln o terms2str) l;
157.286 +["a = b","c = d","e = f"]
157.287 +
157.288 +> val il = str2term "ss___::bool list";
157.289 +> val l = isalist2list il;
157.290 +[Free ("ss___", "bool List.list")]
157.291 +*)
157.292 +
157.293 +
157.294 +(*review Isabelle2009/src/HOL/Tools/hologic.ML*)
157.295 +val prop = Type ("prop",[]); (* ~/Diss.99/Integers-Isa/tools.sml*)
157.296 +val bool = Type ("bool",[]); (* 2002 Integ.int *)
157.297 +val Trueprop = Const("Trueprop",bool-->prop);
157.298 +fun mk_prop t = Trueprop $ t;
157.299 +val true_as_term = Const("True",bool);
157.300 +val false_as_term = Const("False",bool);
157.301 +val true_as_cterm = cterm_of (theory "HOL") true_as_term;
157.302 +val false_as_cterm = cterm_of (theory "HOL") false_as_term;
157.303 +
157.304 +infixr 5 -->; (*2002 /Pure/term.ML *)
157.305 +infixr --->; (*2002 /Pure/term.ML *)
157.306 +fun S --> T = Type("fun",[S,T]); (*2002 /Pure/term.ML *)
157.307 +val op ---> = foldr (op -->); (*2002 /Pure/term.ML *)
157.308 +fun list_implies ([], B) = B : term (*2002 /term.ML *)
157.309 + | list_implies (A::AS, B) = Logic.implies $ A $ list_implies(AS,B);
157.310 +
157.311 +
157.312 +
157.313 +(** substitution **)
157.314 +
157.315 +fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) = (* = thm.ML *)
157.316 + match_bvs(s, t, if x="" orelse y="" then al
157.317 + else (x,y)::al)
157.318 + | match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al))
157.319 + | match_bvs(_,_,al) = al;
157.320 +fun ren_inst(insts,prop,pat,obj) = (* = thm.ML *)
157.321 + let val ren = match_bvs(pat,obj,[])
157.322 + fun renAbs(Abs(x,T,b)) =
157.323 + Abs(case assoc_string(ren,x) of NONE => x
157.324 + | SOME(y) => y, T, renAbs(b))
157.325 + | renAbs(f$t) = renAbs(f) $ renAbs(t)
157.326 + | renAbs(t) = t
157.327 + in subst_vars insts (if null(ren) then prop else renAbs(prop)) end;
157.328 +
157.329 +
157.330 +
157.331 +
157.332 +
157.333 +
157.334 +fun dest_equals' (Const("op =",_) $ t $ u) = (t,u)(* logic.ML: Const("=="*)
157.335 + | dest_equals' t = raise TERM("dest_equals'", [t]);
157.336 +val lhs_ = (fst o dest_equals');
157.337 +val rhs_ = (snd o dest_equals');
157.338 +
157.339 +fun is_equality (Const("op =",_) $ t $ u) = true (* logic.ML: Const("=="*)
157.340 + | is_equality _ = false;
157.341 +fun mk_equality (t,u) = (Const("op =",[type_of t,type_of u]--->bool) $ t $ u);
157.342 +fun is_expliceq (Const("op =",_) $ (Free _) $ u) = true
157.343 + | is_expliceq _ = false;
157.344 +fun strip_trueprop (Const("Trueprop",_) $ t) = t
157.345 + | strip_trueprop t = t;
157.346 +(* | strip_trueprop t = raise TERM("strip_trueprop", [t]);
157.347 +*)
157.348 +
157.349 +(*.(A1==>...An==>B) goes to (A1==>...An==>).*)
157.350 +fun strip_imp_prems' (Const("==>", T) $ A $ t) =
157.351 + let fun coll_prems As (Const("==>", _) $ A $ t) =
157.352 + coll_prems (As $ (Logic.implies $ A)) t
157.353 + | coll_prems As _ = SOME As
157.354 + in coll_prems (Logic.implies $ A) t end
157.355 + | strip_imp_prems' _ = NONE; (* logic.ML: term -> term list*)
157.356 +(*
157.357 + val thm = real_mult_div_cancel1;
157.358 + val prop = (#prop o rep_thm) thm;
157.359 + atomt prop;
157.360 +*** -------------
157.361 +*** Const ( ==>)
157.362 +*** . Const ( Trueprop)
157.363 +*** . . Const ( Not)
157.364 +*** . . . Const ( op =)
157.365 +*** . . . . Var ((k, 0), )
157.366 +*** . . . . Const ( 0)
157.367 +*** . Const ( Trueprop)
157.368 +*** . . Const ( op =) *** .............
157.369 + val SOME t = strip_imp_prems' ((#prop o rep_thm) thm);
157.370 + atomt t;
157.371 +*** -------------
157.372 +*** Const ( ==>)
157.373 +*** . Const ( Trueprop)
157.374 +*** . . Const ( Not)
157.375 +*** . . . Const ( op =)
157.376 +*** . . . . Var ((k, 0), )
157.377 +*** . . . . Const ( 0)
157.378 +
157.379 + val thm = real_le_anti_sym;
157.380 + val prop = (#prop o rep_thm) thm;
157.381 + atomt prop;
157.382 +*** -------------
157.383 +*** Const ( ==>)
157.384 +*** . Const ( Trueprop)
157.385 +*** . . Const ( op <=)
157.386 +*** . . . Var ((z, 0), )
157.387 +*** . . . Var ((w, 0), )
157.388 +*** . Const ( ==>)
157.389 +*** . . Const ( Trueprop)
157.390 +*** . . . Const ( op <=)
157.391 +*** . . . . Var ((w, 0), )
157.392 +*** . . . . Var ((z, 0), )
157.393 +*** . . Const ( Trueprop)
157.394 +*** . . . Const ( op =)
157.395 +*** .............
157.396 + val SOME t = strip_imp_prems' ((#prop o rep_thm) thm);
157.397 + atomt t;
157.398 +*** -------------
157.399 +*** Const ( ==>)
157.400 +*** . Const ( Trueprop)
157.401 +*** . . Const ( op <=)
157.402 +*** . . . Var ((z, 0), )
157.403 +*** . . . Var ((w, 0), )
157.404 +*** . Const ( ==>)
157.405 +*** . . Const ( Trueprop)
157.406 +*** . . . Const ( op <=)
157.407 +*** . . . . Var ((w, 0), )
157.408 +*** . . . . Var ((z, 0), )
157.409 +*)
157.410 +
157.411 +(*. (A1==>...An==>) (B) goes to (A1==>...An==>B), where B is lowest branch.*)
157.412 +fun ins_concl (Const("==>", T) $ A $ t) B = Logic.implies $ A $ (ins_concl t B)
157.413 + | ins_concl (Const("==>", T) $ A ) B = Logic.implies $ A $ B
157.414 + | ins_concl t B = raise TERM("ins_concl", [t, B]);
157.415 +(*
157.416 + val thm = real_le_anti_sym;
157.417 + val prop = (#prop o rep_thm) thm;
157.418 + val concl = Logic.strip_imp_concl prop;
157.419 + val SOME prems = strip_imp_prems' prop;
157.420 + val prop' = ins_concl prems concl;
157.421 + prop = prop';
157.422 + atomt prop;
157.423 + atomt prop';
157.424 +*)
157.425 +
157.426 +
157.427 +fun vperm (Var _, Var _) = true (*2002 Pure/thm.ML *)
157.428 + | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t)
157.429 + | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2)
157.430 + | vperm (t, u) = (t = u);
157.431 +
157.432 +(*2002 cp from Pure/term.ML --- since 2009 in Pure/old_term.ML*)
157.433 +fun mem_term (_, []) = false
157.434 + | mem_term (t, t'::ts) = t aconv t' orelse mem_term(t,ts);
157.435 +fun subset_term ([], ys) = true
157.436 + | subset_term (x :: xs, ys) = mem_term (x, ys) andalso subset_term(xs, ys);
157.437 +fun eq_set_term (xs, ys) =
157.438 + xs = ys orelse (subset_term (xs, ys) andalso subset_term (ys, xs));
157.439 +(*a total, irreflexive ordering on index names*)
157.440 +fun xless ((a,i), (b,j): indexname) = i<j orelse (i=j andalso a<b);
157.441 +(*a partial ordering (not reflexive) for atomic terms*)
157.442 +fun atless (Const (a,_), Const (b,_)) = a<b
157.443 + | atless (Free (a,_), Free (b,_)) = a<b
157.444 + | atless (Var(v,_), Var(w,_)) = xless(v,w)
157.445 + | atless (Bound i, Bound j) = i<j
157.446 + | atless _ = false;
157.447 +(*insert atomic term into partially sorted list, suppressing duplicates (?)*)
157.448 +fun insert_aterm (t,us) =
157.449 + let fun inserta [] = [t]
157.450 + | inserta (us as u::us') =
157.451 + if atless(t,u) then t::us
157.452 + else if t=u then us (*duplicate*)
157.453 + else u :: inserta(us')
157.454 + in inserta us end;
157.455 +
157.456 +(*Accumulates the Vars in the term, suppressing duplicates*)
157.457 +fun add_term_vars (t, vars: term list) = case t of
157.458 + Var _ => insert_aterm(t,vars)
157.459 + | Abs (_,_,body) => add_term_vars(body,vars)
157.460 + | f$t => add_term_vars (f, add_term_vars(t, vars))
157.461 + | _ => vars;
157.462 +fun term_vars t = add_term_vars(t,[]);
157.463 +
157.464 +
157.465 +fun var_perm (t, u) = (*2002 Pure/thm.ML *)
157.466 + vperm (t, u) andalso eq_set_term (term_vars t, term_vars u);
157.467 +
157.468 +(*2002 fun decomp_simp, Pure/thm.ML *)
157.469 +fun perm lhs rhs = var_perm (lhs, rhs) andalso not (lhs aconv rhs)
157.470 + andalso not (is_Var lhs);
157.471 +
157.472 +
157.473 +fun str_of_int n =
157.474 + if n < 0 then "-"^((string_of_int o abs) n)
157.475 + else string_of_int n;
157.476 +(*
157.477 +> str_of_int 1;
157.478 +val it = "1" : string > str_of_int ~1;
157.479 +val it = "-1" : string
157.480 +*)
157.481 +
157.482 +
157.483 +fun power b 0 = 1
157.484 + | power b n =
157.485 + if n>0 then b*(power b (n-1))
157.486 + else raise error ("power "^(str_of_int b)^" "^(str_of_int n));
157.487 +(*
157.488 +> power 2 3;
157.489 +val it = 8 : int
157.490 +> power ~2 3;
157.491 +val it = ~8 : int
157.492 +> power ~3 2;
157.493 +val it = 9 : int
157.494 +> power 3 ~2;
157.495 +*)
157.496 +fun gcd 0 b = b
157.497 + | gcd a b = if a < b then gcd (b mod a) a
157.498 + else gcd (a mod b) b;
157.499 +fun sign n = if n < 0 then ~1
157.500 + else if n = 0 then 0 else 1;
157.501 +fun sign2 n1 n2 = (sign n1) * (sign n2);
157.502 +
157.503 +infix dvd;
157.504 +fun d dvd n = n mod d = 0;
157.505 +
157.506 +fun divisors n =
157.507 + let fun pdiv ds d n =
157.508 + if d=n then d::ds
157.509 + else if d dvd n then pdiv (d::ds) d (n div d)
157.510 + else pdiv ds (d+1) n
157.511 + in pdiv [] 2 n end;
157.512 +
157.513 +divisors 30;
157.514 +divisors 32;
157.515 +divisors 60;
157.516 +divisors 11;
157.517 +
157.518 +fun doubles ds = (* ds is ordered *)
157.519 + let fun dbls ds [] = ds
157.520 + | dbls ds [i] = ds
157.521 + | dbls ds (i::i'::is) = if i=i' then dbls (i::ds) is
157.522 + else dbls ds (i'::is)
157.523 + in dbls [] ds end;
157.524 +(*> doubles [2,3,4];
157.525 +val it = [] : int list
157.526 +> doubles [2,3,3,5,5,7];
157.527 +val it = [5,3] : int list*)
157.528 +
157.529 +fun squfact 0 = 0
157.530 + | squfact 1 = 1
157.531 + | squfact n = foldl op* (1, (doubles o divisors) n);
157.532 +(*> squfact 30;
157.533 +val it = 1 : int
157.534 +> squfact 32;
157.535 +val it = 4 : int
157.536 +> squfact 60;
157.537 +val it = 2 : int
157.538 +> squfact 11;
157.539 +val it = 1 : int*)
157.540 +
157.541 +
157.542 +fun dest_type (Type(T,[])) = T
157.543 + | dest_type T =
157.544 + (atomtyp T;
157.545 + raise error ("... dest_type: not impl. for this type"));
157.546 +
157.547 +fun term_of_num ntyp n = Free (str_of_int n, ntyp);
157.548 +
157.549 +fun pairT T1 T2 = Type ("*", [T1, T2]);
157.550 +(*> val t = str2term "(1,2)";
157.551 +> type_of t = pairT HOLogic.realT HOLogic.realT;
157.552 +val it = true : bool
157.553 +*)
157.554 +fun PairT T1 T2 = ([T1, T2] ---> Type ("*", [T1, T2]));
157.555 +(*> val t = str2term "(1,2)";
157.556 +> val Const ("Pair",pT) $ _ $ _ = t;
157.557 +> pT = PairT HOLogic.realT HOLogic.realT;
157.558 +val it = true : bool
157.559 +*)
157.560 +fun pairt t1 t2 =
157.561 + Const ("Pair", PairT (type_of t1) (type_of t2)) $ t1 $ t2;
157.562 +(*> val t = str2term "(1,2)";
157.563 +> val (t1, t2) = (str2term "1", str2term "2");
157.564 +> t = pairt t1 t2;
157.565 +val it = true : bool*)
157.566 +
157.567 +
157.568 +fun num_of_term (t as Free (s,_)) =
157.569 + (case int_of_str s of
157.570 + SOME s' => s'
157.571 + | NONE => raise error ("num_of_term not for "^ term2str t))
157.572 + | num_of_term t = raise error ("num_of_term not for "^term2str t);
157.573 +
157.574 +fun mk_factroot op_(*=thy.sqrt*) T fact root =
157.575 + Const ("op *", [T, T] ---> T) $ (term_of_num T fact) $
157.576 + (Const (op_, T --> T) $ term_of_num T root);
157.577 +(*
157.578 +val T = (type_of o term_of o the) (parse thy "#12::real");
157.579 +val t = mk_factroot "SqRoot.sqrt" T 2 3;
157.580 +(cterm_of thy) t;
157.581 +val it = "#2 * sqrt #3 " : cterm
157.582 +*)
157.583 +fun var_op_num v op_ optype ntyp n =
157.584 + Const (op_, optype) $ v $
157.585 + Free (str_of_int n, ntyp);
157.586 +
157.587 +fun num_op_var v op_ optype ntyp n =
157.588 + Const (op_,optype) $
157.589 + Free (str_of_int n, ntyp) $ v;
157.590 +
157.591 +fun num_op_num T1 T2 (op_,Top) n1 n2 =
157.592 + Const (op_,Top) $
157.593 + Free (str_of_int n1, T1) $ Free (str_of_int n2, T2);
157.594 +(*
157.595 +> val t = num_op_num "Int" 3 4;
157.596 +> atomty t;
157.597 +> string_of_cterm ((cterm_of thy) t);
157.598 +*)
157.599 +
157.600 +fun const_in str (Const _) = false
157.601 + | const_in str (Free (s,_)) = if strip_thy s = str then true else false
157.602 + | const_in str (Bound _) = false
157.603 + | const_in str (Var _) = false
157.604 + | const_in str (Abs (_,_,body)) = const_in str body
157.605 + | const_in str (f$u) = const_in str f orelse const_in str u;
157.606 +(*
157.607 +> val t = (term_of o the o (parse thy)) "6 + 5 * sqrt 4 + 3";
157.608 +> const_in "sqrt" t;
157.609 +val it = true : bool
157.610 +> val t = (term_of o the o (parse thy)) "6 + 5 * 4 + 3";
157.611 +> const_in "sqrt" t;
157.612 +val it = false : bool
157.613 +*)
157.614 +
157.615 +(*used for calculating built in binary operations in Isabelle2002->Float.ML*)
157.616 +(*fun calc "op +" (n1, n2) = n1+n2
157.617 + | calc "op -" (n1, n2) = n1-n2
157.618 + | calc "op *" (n1, n2) = n1*n2
157.619 + | calc "HOL.divide"(n1, n2) = n1 div n2
157.620 + | calc "Atools.pow"(n1, n2) = power n1 n2
157.621 + | calc op_ _ = raise error ("calc: operator = "^op_^" not defined");-----*)
157.622 +fun calc_equ "op <" (n1, n2) = n1 < n2
157.623 + | calc_equ "op <=" (n1, n2) = n1 <= n2
157.624 + | calc_equ op_ _ =
157.625 + raise error ("calc_equ: operator = "^op_^" not defined");
157.626 +fun sqrt (n:int) = if n < 0 then 0
157.627 + (*FIXME ~~~*) else (trunc o Math.sqrt o Real.fromInt) n;
157.628 +
157.629 +fun mk_thmid thmid op_ n1 n2 =
157.630 + thmid ^ (strip_thy n1) ^ "_" ^ (strip_thy n2);
157.631 +
157.632 +fun dest_binop_typ (Type("fun",[range,Type("fun",[arg2,arg1])])) =
157.633 + (arg1,arg2,range)
157.634 + | dest_binop_typ _ = raise error "dest_binop_typ: not binary";
157.635 +(* -----
157.636 +> val t = (term_of o the o (parse thy)) "#3^#4";
157.637 +> val hT = type_of (head_of t);
157.638 +> dest_binop_typ hT;
157.639 +val it = ("'a","nat","'a") : typ * typ * typ
157.640 + ----- *)
157.641 +
157.642 +
157.643 +(** transform binary numeralsstrings **)
157.644 +(*Makarius 100308, hacked by WN*)
157.645 +val numbers_to_string =
157.646 + let
157.647 + fun dest_num t =
157.648 + (case try HOLogic.dest_number t of
157.649 + SOME (T, i) =>
157.650 + (*if T = @{typ int} orelse T = @{typ real} then WN*)
157.651 + SOME (Free (signed_string_of_int i, T))
157.652 + (*else NONE WN*)
157.653 + | NONE => NONE);
157.654 +
157.655 + fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
157.656 + | to_str (t as (u1 $ u2)) =
157.657 + (case dest_num t of
157.658 + SOME t' => t'
157.659 + | NONE => to_str u1 $ to_str u2)
157.660 + | to_str t = perhaps dest_num t;
157.661 + in to_str end
157.662 +
157.663 +(*.make uminus uniform:
157.664 + Const ("uminus", _) $ Free ("2", "RealDef.real") --> Free ("-2", _)
157.665 +to be used immediately before evaluation of numerals;
157.666 +see Scripts/calculate.sml .*)
157.667 +(*2002 fun(*app_num_tr'2 (Const("0",T)) = Free("0",T)
157.668 + | app_num_tr'2 (Const("1",T)) = Free("1",T)
157.669 + |*)app_num_tr'2 (t as Const("uminus",_) $ Free(s,T)) =
157.670 + (case int_of_str s of SOME i =>
157.671 + if i > 0 then Free("-"^s,T) else Free(s,T)
157.672 + | NONE => t)
157.673 +(*| app_num_tr'2 (t as Const(s,T)) = t
157.674 + | app_num_tr'2 (Const("Numeral.number_of",Type ("fun", [_, T])) $ t) =
157.675 + Free(NumeralSyntax.dest_bin_str t, T)
157.676 + | app_num_tr'2 (t as Free(s,T)) = t
157.677 + | app_num_tr'2 (t as Var(n,T)) = t
157.678 + | app_num_tr'2 (t as Bound i) = t
157.679 +*)| app_num_tr'2 (Abs(s,T,body)) = Abs(s,T, app_num_tr'2 body)
157.680 + | app_num_tr'2 (t1 $ t2) = (app_num_tr'2 t1) $ (app_num_tr'2 t2)
157.681 + | app_num_tr'2 t = t;
157.682 +*)
157.683 +val uminus_to_string =
157.684 + let
157.685 + fun dest_num t =
157.686 + (case t of
157.687 + (Const ("HOL.uminus_class.uminus", _) $ Free (s, T)) =>
157.688 + (case int_of_str s of
157.689 + SOME i =>
157.690 + SOME (Free (signed_string_of_int (~1 * i), T))
157.691 + | NONE => NONE)
157.692 + | _ => NONE);
157.693 +
157.694 + fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
157.695 + | to_str (t as (u1 $ u2)) =
157.696 + (case dest_num t of
157.697 + SOME t' => t'
157.698 + | NONE => to_str u1 $ to_str u2)
157.699 + | to_str t = perhaps dest_num t;
157.700 + in to_str end;
157.701 +
157.702 +
157.703 +(*2002 fun num_str thm =
157.704 + let
157.705 + val {sign_ref = sign_ref, der = der, maxidx = maxidx,
157.706 + shyps = shyps, hyps = hyps, (*tpairs = tpairs,*) prop = prop} =
157.707 + rep_thm_G thm;
157.708 + val prop' = app_num_tr'1 prop;
157.709 + in assbl_thm sign_ref der maxidx shyps hyps (*tpairs*) prop' end;*)
157.710 +fun num_str thm =
157.711 + let val (deriv,
157.712 + {thy_ref = thy_ref, tags = tags, maxidx = maxidx, shyps = shyps,
157.713 + hyps = hyps, tpairs = tpairs, prop = prop}) = rep_thm_G thm
157.714 + val prop' = numbers_to_string prop;
157.715 + in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end;
157.716 +
157.717 +fun get_thm' xstring = (*?covers 2009 Thm?!, replaces 2002 fun get_thm :
157.718 +val it = fn : theory -> xstring -> Thm.thm*)
157.719 + Thm (xstring,
157.720 + num_str (ProofContext.get_thm (thy2ctxt' "Isac") xstring));
157.721 +
157.722 +(** get types of Free and Abs for parse' **)
157.723 +(*11.1.00: not used, fix-typed +,*,-,^ instead *)
157.724 +
157.725 +val dummyT = Type ("dummy",[]);
157.726 +val dummyT = TVar (("DUMMY",0),[]);
157.727 +
157.728 +(* assumes only 1 type for numerals
157.729 + and different identifiers for Const, Free and Abs *)
157.730 +fun get_types t =
157.731 + let
157.732 + fun get ts (Const(s,T)) = (s,T)::ts
157.733 + | get ts (Free(s,T)) = if is_no s
157.734 + then ("#",T)::ts else (s,T)::ts
157.735 + | get ts (Var(n,T)) = ts
157.736 + | get ts (Bound i) = ts
157.737 + | get ts (Abs(s,T,body)) = get ((s,T)::ts) body
157.738 + | get ts (t1 $ t2) = (get ts t1) @ (get ts t2)
157.739 + in distinct (get [] t) end;
157.740 +(*
157.741 +val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
157.742 +get_types t;
157.743 +*)
157.744 +
157.745 +(*11.1.00: not used, fix-typed +,*,-,^ instead *)
157.746 +fun set_types al (Const(s,T)) =
157.747 + (case assoc (al,s) of
157.748 + SOME T' => Const(s,T')
157.749 + | NONE => (warning ("set_types: no type for "^s); Const(s,dummyT)))
157.750 + | set_types al (Free(s,T)) =
157.751 + if is_no s then
157.752 + (case assoc (al,"#") of
157.753 + SOME T' => Free(s,T')
157.754 + | NONE => (warning ("set_types: no type for numerals"); Free(s,T)))
157.755 + else (case assoc (al,s) of
157.756 + SOME T' => Free(s,T')
157.757 + | NONE => (warning ("set_types: no type for "^s); Free(s,T)))
157.758 + | set_types al (Var(n,T)) = Var(n,T)
157.759 + | set_types al (Bound i) = Bound i
157.760 + | set_types al (Abs(s,T,body)) =
157.761 + (case assoc (al,s) of
157.762 + SOME T' => Abs(s,T', set_types al body)
157.763 + | NONE => (warning ("set_types: no type for "^s);
157.764 + Abs(s,T, set_types al body)))
157.765 + | set_types al (t1 $ t2) = (set_types al t1) $ (set_types al t2);
157.766 +(*
157.767 +val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
157.768 +val al = get_types t;
157.769 +
157.770 +val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4";
157.771 +atomty t; (* 'a *)
157.772 +val t' = set_types al t;
157.773 +atomty t'; (*real*)
157.774 +(cterm_of thy) t';
157.775 +val it = "x = #0 + #-1 * #-4" : cterm
157.776 +
157.777 +val t = (term_of o the o (parse thy))
157.778 + "#5 * x + x ^^^ #2 = (#2 + x) ^^^ #2";
157.779 +atomty t;
157.780 +val t' = set_types al t;
157.781 +atomty t';
157.782 +(cterm_of thy) t';
157.783 +uncaught exception TYPE (*^^^ is new, NOT in al*)
157.784 +*)
157.785 +
157.786 +
157.787 +(** from Descript.ML **)
157.788 +
157.789 +(** decompose an isa-list to an ML-list
157.790 + i.e. [] belong to the meta-language, too **)
157.791 +
157.792 +fun is_list ((Const("List.list.Cons",_)) $ _ $ _) = true
157.793 + | is_list _ = false;
157.794 +(* val (SOME ct) = parse thy "lll::real list";
157.795 +> val ty = (#t o rep_cterm) ct;
157.796 +> is_list ty;
157.797 +val it = false : bool
157.798 +> val (SOME ct) = parse thy "[lll]";
157.799 +> val ty = (#t o rep_cterm) ct;
157.800 +> is_list ty;
157.801 +val it = true : bool *)
157.802 +
157.803 +
157.804 +
157.805 +fun mk_Free (s,T) = Free(s,T);
157.806 +fun mk_free T s = Free(s,T);
157.807 +
157.808 +(*instantiate let; necessary for ass_up*)
157.809 +fun inst_abs thy (Const sT) = Const sT
157.810 + | inst_abs thy (Free sT) = Free sT
157.811 + | inst_abs thy (Bound n) = Bound n
157.812 + | inst_abs thy (Var iT) = Var iT
157.813 + | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) =
157.814 + let val (v',b') = variant_abs (v,T2,b); (*fun variant_abs: term.ML*)
157.815 + in Const ("Let",T1) $ inst_abs thy e $ (Abs (v',T2,inst_abs thy b')) end
157.816 + | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2
157.817 + | inst_abs thy t =
157.818 + (writeln("inst_abs: unchanged t= "^ term2str t);
157.819 + t);
157.820 +(*val scr as (Script sc) = Script ((term_of o the o (parse thy))
157.821 + "Script Testeq (e_::bool) = \
157.822 + \While (contains_root e_) Do \
157.823 + \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False e_)); \
157.824 + \ e_ = Try (Repeat (Rewrite square_equation_left True e_)) \
157.825 + \ in Try (Repeat (Rewrite radd_0 False e_))) ");
157.826 +ML> atomt sc;
157.827 +*** Const ( Script.Testeq)
157.828 +*** . Free ( e_, )
157.829 +*** . Const ( Script.While)
157.830 +*** . . Const ( RatArith.contains'_root)
157.831 +*** . . . Free ( e_, )
157.832 +*** . . Const ( Let)
157.833 +*** . . . Const ( Script.Try)
157.834 +*** . . . . Const ( Script.Repeat)
157.835 +*** . . . . . Const ( Script.Rewrite)
157.836 +*** . . . . . . Free ( rroot_square_inv, )
157.837 +*** . . . . . . Const ( False)
157.838 +*** . . . . . . Free ( e_, )
157.839 +*** . . . Abs( e_,..
157.840 +*** . . . . Const ( Let)
157.841 +*** . . . . . Const ( Script.Try)
157.842 +*** . . . . . . Const ( Script.Repeat)
157.843 +*** . . . . . . . Const ( Script.Rewrite)
157.844 +*** . . . . . . . . Free ( square_equation_left, )
157.845 +*** . . . . . . . . Const ( True)
157.846 +*** . . . . . . . . Bound 0 <-- !!!
157.847 +*** . . . . . Abs( e_,..
157.848 +*** . . . . . . Const ( Script.Try)
157.849 +*** . . . . . . . Const ( Script.Repeat)
157.850 +*** . . . . . . . . Const ( Script.Rewrite)
157.851 +*** . . . . . . . . . Free ( radd_0, )
157.852 +*** . . . . . . . . . Const ( False)
157.853 +*** . . . . . . . . . Bound 0 <-- !!!
157.854 +val it = () : unit
157.855 +ML> atomt (inst_abs thy sc);
157.856 +*** Const ( Script.Testeq)
157.857 +*** . Free ( e_, )
157.858 +*** . Const ( Script.While)
157.859 +*** . . Const ( RatArith.contains'_root)
157.860 +*** . . . Free ( e_, )
157.861 +*** . . Const ( Let)
157.862 +*** . . . Const ( Script.Try)
157.863 +*** . . . . Const ( Script.Repeat)
157.864 +*** . . . . . Const ( Script.Rewrite)
157.865 +*** . . . . . . Free ( rroot_square_inv, )
157.866 +*** . . . . . . Const ( False)
157.867 +*** . . . . . . Free ( e_, )
157.868 +*** . . . Abs( e_,..
157.869 +*** . . . . Const ( Let)
157.870 +*** . . . . . Const ( Script.Try)
157.871 +*** . . . . . . Const ( Script.Repeat)
157.872 +*** . . . . . . . Const ( Script.Rewrite)
157.873 +*** . . . . . . . . Free ( square_equation_left, )
157.874 +*** . . . . . . . . Const ( True)
157.875 +*** . . . . . . . . Free ( e_, ) <-- !!!
157.876 +*** . . . . . Abs( e_,..
157.877 +*** . . . . . . Const ( Script.Try)
157.878 +*** . . . . . . . Const ( Script.Repeat)
157.879 +*** . . . . . . . . Const ( Script.Rewrite)
157.880 +*** . . . . . . . . . Free ( radd_0, )
157.881 +*** . . . . . . . . . Const ( False)
157.882 +*** . . . . . . . . . Free ( e_, ) <-- ZUFALL vor 5.03!!!
157.883 +val it = () : unit*)
157.884 +
157.885 +
157.886 +
157.887 +
157.888 +fun inst_abs thy (Const sT) = Const sT
157.889 + | inst_abs thy (Free sT) = Free sT
157.890 + | inst_abs thy (Bound n) = Bound n
157.891 + | inst_abs thy (Var iT) = Var iT
157.892 + | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) =
157.893 + let val b' = subst_bound (Free(v,T2),b);
157.894 + (*fun variant_abs: term.ML*)
157.895 + in Const ("Let",T1) $ inst_abs thy e $ (Abs (v,T2,inst_abs thy b')) end
157.896 + | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2
157.897 + | inst_abs thy t =
157.898 + (writeln("inst_abs: unchanged t= "^ term2str t);
157.899 + t);
157.900 +(*val scr =
157.901 + "Script Make_fun_by_explicit (f_::real) (v_::real) (eqs_::bool list) = \
157.902 + \ (let h_ = (hd o (filterVar f_)) eqs_; \
157.903 + \ e_1 = hd (dropWhile (ident h_) eqs_); \
157.904 + \ vs_ = dropWhile (ident f_) (Vars h_); \
157.905 + \ v_1 = hd (dropWhile (ident v_) vs_); \
157.906 + \ (s_1::bool list)=(SubProblem(DiffApp_,[univar,equation],[no_met])\
157.907 + \ [bool_ e_1, real_ v_1])\
157.908 + \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)";
157.909 +> val ttt = (term_of o the o (parse thy)) scr;
157.910 +> writeln(term2str ttt);
157.911 +> atomt ttt;
157.912 +*** -------------
157.913 +*** Const ( DiffApp.Make'_fun'_by'_explicit)
157.914 +*** . Free ( f_, )
157.915 +*** . Free ( v_, )
157.916 +*** . Free ( eqs_, )
157.917 +*** . Const ( Let)
157.918 +*** . . Const ( Fun.op o)
157.919 +*** . . . Const ( List.hd)
157.920 +*** . . . Const ( DiffApp.filterVar)
157.921 +*** . . . . Free ( f_, )
157.922 +*** . . . Free ( eqs_, )
157.923 +*** . . Abs( h_,..
157.924 +*** . . . Const ( Let)
157.925 +*** . . . . Const ( List.hd)
157.926 +*** . . . . . Const ( List.dropWhile)
157.927 +*** . . . . . . Const ( Atools.ident)
157.928 +*** . . . . . . . Bound 0 <---- Free ( h_, )
157.929 +*** . . . . . . Free ( eqs_, )
157.930 +*** . . . . Abs( e_1,..
157.931 +*** . . . . . Const ( Let)
157.932 +*** . . . . . . Const ( List.dropWhile)
157.933 +*** . . . . . . . Const ( Atools.ident)
157.934 +*** . . . . . . . . Free ( f_, )
157.935 +*** . . . . . . . Const ( Tools.Vars)
157.936 +*** . . . . . . . . Bound 1 <---- Free ( h_, )
157.937 +*** . . . . . . Abs( vs_,..
157.938 +*** . . . . . . . Const ( Let)
157.939 +*** . . . . . . . . Const ( List.hd)
157.940 +*** . . . . . . . . . Const ( List.dropWhile)
157.941 +*** . . . . . . . . . . Const ( Atools.ident)
157.942 +*** . . . . . . . . . . . Free ( v_, )
157.943 +*** . . . . . . . . . . Bound 0 <---- Free ( vs_, )
157.944 +*** . . . . . . . . Abs( v_1,..
157.945 +*** . . . . . . . . . Const ( Let)
157.946 +*** . . . . . . . . . . Const ( Script.SubProblem)
157.947 +*** . . . . . . . . . . . Const ( Pair)
157.948 +*** . . . . . . . . . . . . Free ( DiffApp_, )
157.949 +*** . . . . . . . . . . . . Const ( Pair)
157.950 +*** . . . . . . . . . . . . . Const ( List.list.Cons)
157.951 +*** . . . . . . . . . . . . . . Free ( univar, )
157.952 +*** . . . . . . . . . . . . . . Const ( List.list.Cons)
157.953 +*** . . . . . . . . . . . . . . . Free ( equation, )
157.954 +*** . . . . . . . . . . . . . . . Const ( List.list.Nil)
157.955 +*** . . . . . . . . . . . . . Const ( List.list.Cons)
157.956 +*** . . . . . . . . . . . . . . Free ( no_met, )
157.957 +*** . . . . . . . . . . . . . . Const ( List.list.Nil)
157.958 +*** . . . . . . . . . . . Const ( List.list.Cons)
157.959 +*** . . . . . . . . . . . . Const ( Script.bool_)
157.960 +*** . . . . . . . . . . . . . Bound 2 <----- Free ( e_1, )
157.961 +*** . . . . . . . . . . . . Const ( List.list.Cons)
157.962 +*** . . . . . . . . . . . . . Const ( Script.real_)
157.963 +*** . . . . . . . . . . . . . . Bound 0 <----- Free ( v_1, )
157.964 +*** . . . . . . . . . . . . . Const ( List.list.Nil)
157.965 +*** . . . . . . . . . . Abs( s_1,..
157.966 +*** . . . . . . . . . . . Const ( Script.Substitute)
157.967 +*** . . . . . . . . . . . . Const ( List.list.Cons)
157.968 +*** . . . . . . . . . . . . . Const ( Pair)
157.969 +*** . . . . . . . . . . . . . . Bound 1 <----- Free ( v_1, )
157.970 +*** . . . . . . . . . . . . . . Const ( Fun.op o)
157.971 +*** . . . . . . . . . . . . . . . Const ( Tools.rhs)
157.972 +*** . . . . . . . . . . . . . . . Const ( List.hd)
157.973 +*** . . . . . . . . . . . . . . . Bound 0 <----- Free ( s_1, )
157.974 +*** . . . . . . . . . . . . . Const ( List.list.Nil)
157.975 +*** . . . . . . . . . . . . Bound 4 <----- Free ( h_, )
157.976 +
157.977 +> val ttt' = inst_abs thy ttt;
157.978 +> writeln(term2str ttt');
157.979 +Script Make_fun_by_explicit f_ v_ eqs_ =
157.980 + ... as above ...
157.981 +> atomt ttt';
157.982 +*** -------------
157.983 +*** Const ( DiffApp.Make'_fun'_by'_explicit)
157.984 +*** . Free ( f_, )
157.985 +*** . Free ( v_, )
157.986 +*** . Free ( eqs_, )
157.987 +*** . Const ( Let)
157.988 +*** . . Const ( Fun.op o)
157.989 +*** . . . Const ( List.hd)
157.990 +*** . . . Const ( DiffApp.filterVar)
157.991 +*** . . . . Free ( f_, )
157.992 +*** . . . Free ( eqs_, )
157.993 +*** . . Abs( h_,..
157.994 +*** . . . Const ( Let)
157.995 +*** . . . . Const ( List.hd)
157.996 +*** . . . . . Const ( List.dropWhile)
157.997 +*** . . . . . . Const ( Atools.ident)
157.998 +*** . . . . . . . Free ( h_, ) <---- Bound 0
157.999 +*** . . . . . . Free ( eqs_, )
157.1000 +*** . . . . Abs( e_1,..
157.1001 +*** . . . . . Const ( Let)
157.1002 +*** . . . . . . Const ( List.dropWhile)
157.1003 +*** . . . . . . . Const ( Atools.ident)
157.1004 +*** . . . . . . . . Free ( f_, )
157.1005 +*** . . . . . . . Const ( Tools.Vars)
157.1006 +*** . . . . . . . . Free ( h_, ) <---- Bound 1
157.1007 +*** . . . . . . Abs( vs_,..
157.1008 +*** . . . . . . . Const ( Let)
157.1009 +*** . . . . . . . . Const ( List.hd)
157.1010 +*** . . . . . . . . . Const ( List.dropWhile)
157.1011 +*** . . . . . . . . . . Const ( Atools.ident)
157.1012 +*** . . . . . . . . . . . Free ( v_, )
157.1013 +*** . . . . . . . . . . Free ( vs_, ) <---- Bound 0
157.1014 +*** . . . . . . . . Abs( v_1,..
157.1015 +*** . . . . . . . . . Const ( Let)
157.1016 +*** . . . . . . . . . . Const ( Script.SubProblem)
157.1017 +*** . . . . . . . . . . . Const ( Pair)
157.1018 +*** . . . . . . . . . . . . Free ( DiffApp_, )
157.1019 +*** . . . . . . . . . . . . Const ( Pair)
157.1020 +*** . . . . . . . . . . . . . Const ( List.list.Cons)
157.1021 +*** . . . . . . . . . . . . . . Free ( univar, )
157.1022 +*** . . . . . . . . . . . . . . Const ( List.list.Cons)
157.1023 +*** . . . . . . . . . . . . . . . Free ( equation, )
157.1024 +*** . . . . . . . . . . . . . . . Const ( List.list.Nil)
157.1025 +*** . . . . . . . . . . . . . Const ( List.list.Cons)
157.1026 +*** . . . . . . . . . . . . . . Free ( no_met, )
157.1027 +*** . . . . . . . . . . . . . . Const ( List.list.Nil)
157.1028 +*** . . . . . . . . . . . Const ( List.list.Cons)
157.1029 +*** . . . . . . . . . . . . Const ( Script.bool_)
157.1030 +*** . . . . . . . . . . . . . Free ( e_1, ) <----- Bound 2
157.1031 +*** . . . . . . . . . . . . Const ( List.list.Cons)
157.1032 +*** . . . . . . . . . . . . . Const ( Script.real_)
157.1033 +*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 0
157.1034 +*** . . . . . . . . . . . . . Const ( List.list.Nil)
157.1035 +*** . . . . . . . . . . Abs( s_1,..
157.1036 +*** . . . . . . . . . . . Const ( Script.Substitute)
157.1037 +*** . . . . . . . . . . . . Const ( List.list.Cons)
157.1038 +*** . . . . . . . . . . . . . Const ( Pair)
157.1039 +*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 1
157.1040 +*** . . . . . . . . . . . . . . Const ( Fun.op o)
157.1041 +*** . . . . . . . . . . . . . . . Const ( Tools.rhs)
157.1042 +*** . . . . . . . . . . . . . . . Const ( List.hd)
157.1043 +*** . . . . . . . . . . . . . . . Free ( s_1, ) <----- Bound 0
157.1044 +*** . . . . . . . . . . . . . Const ( List.list.Nil)
157.1045 +*** . . . . . . . . . . . . Free ( h_, ) <----- Bound 4
157.1046 +
157.1047 +Note numbering of de Bruijn indexes !
157.1048 +
157.1049 +Script Make_fun_by_explicit f_ v_ eqs_ =
157.1050 + let h_ = (hd o filterVar f_) eqs_;
157.1051 + e_1 = hd (dropWhile (ident h_ BOUND_0) eqs_);
157.1052 + vs_ = dropWhile (ident f_) (Vars h_ BOUND_1);
157.1053 + v_1 = hd (dropWhile (ident v_) vs_ BOUND_0);
157.1054 + s_1 =
157.1055 + SubProblem (DiffApp_, [univar, equation], [no_met])
157.1056 + [bool_ e_1 BOUND_2, real_ v_1 BOUND_0]
157.1057 + in Substitute [(v_1 BOUND_1 = (rhs o hd) s_1 BOUND_0)] h_ BOUND_4
157.1058 +*)
157.1059 +
157.1060 +
157.1061 +fun T_a2real (Type (s, [])) =
157.1062 + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else Type (s, [])
157.1063 + | T_a2real (Type (s, Ts)) = Type (s, map T_a2real Ts)
157.1064 + | T_a2real (TFree (s, srt)) =
157.1065 + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TFree (s, srt)
157.1066 + | T_a2real (TVar (("DUMMY",_),srt)) = HOLogic.realT;
157.1067 +
157.1068 +(*FIXME .. fixes the type (+see Typefix.thy*)
157.1069 +fun typ_a2real (Const( s, T)) = (Const( s, T_a2real T))
157.1070 + | typ_a2real (Free( s, T)) = (Free( s, T_a2real T))
157.1071 + | typ_a2real (Var( n, T)) = (Var( n, T_a2real T))
157.1072 + | typ_a2real (Bound i) = (Bound i)
157.1073 + | typ_a2real (Abs(s,T,t)) = Abs(s, T, typ_a2real t)
157.1074 + | typ_a2real (t1 $ t2) = (typ_a2real t1) $ (typ_a2real t2);
157.1075 +(*
157.1076 +----------------6.8.02---------------------------------------------------
157.1077 + val str = "1";
157.1078 + val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[])));
157.1079 + atomty (term_of t);
157.1080 +*** -------------
157.1081 +*** Const ( 1, 'a)
157.1082 + val t = (app_num_tr' o term_of) t;
157.1083 + atomty t;
157.1084 +*** -------------
157.1085 +*** Const ( 1, 'a)
157.1086 + val t = typ_a2real t;
157.1087 + atomty t;
157.1088 +*** -------------
157.1089 +*** Const ( 1, real)
157.1090 +
157.1091 + val str = "2";
157.1092 + val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[])));
157.1093 + atomty (term_of t);
157.1094 +*** -------------
157.1095 +*** Const ( Numeral.number_of, bin => 'a)
157.1096 +*** . Const ( Numeral.bin.Bit, [bin, bool] => bin)
157.1097 +*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin)
157.1098 +*** . . . Const ( Numeral.bin.Pls, bin)
157.1099 +*** . . . Const ( True, bool)
157.1100 +*** . . Const ( False, bool)
157.1101 + val t = (app_num_tr' o term_of) t;
157.1102 + atomty t;
157.1103 +*** -------------
157.1104 +*** Free ( 2, 'a)
157.1105 + val t = typ_a2real t;
157.1106 + atomty t;
157.1107 +*** -------------
157.1108 +*** Free ( 2, real)
157.1109 +----------------6.8.02---------------------------------------------------
157.1110 +
157.1111 +
157.1112 +> val str = "R";
157.1113 +> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[]))));
157.1114 +val t = Free ("R","?DUMMY") : term
157.1115 +> val t' = typ_a2real t;
157.1116 +> (cterm_of thy) t';
157.1117 +val it = "R::RealDef.real" : cterm
157.1118 +
157.1119 +> val str = "R=R";
157.1120 +> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[]))));
157.1121 +> atomty (typ_a2real t);
157.1122 +*** -------------
157.1123 +*** Const ( op =, [RealDef.real, RealDef.real] => bool)
157.1124 +*** Free ( R, RealDef.real)
157.1125 +*** Free ( R, RealDef.real)
157.1126 +> val t' = typ_a2real t;
157.1127 +> (cterm_of thy) t';
157.1128 +val it = "(R::RealDef.real) = R" : cterm
157.1129 +
157.1130 +> val str = "fixed_values [R=R]";
157.1131 +> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[]))));
157.1132 +> val t' = typ_a2real t;
157.1133 +> (cterm_of thy) t';
157.1134 +val it = "fixed_values [(R::RealDef.real) = R]" : cterm
157.1135 +*)
157.1136 +
157.1137 +(*TODO.WN0609: parse should return a term or a string
157.1138 + (or even more comprehensive datastructure for error-messages)
157.1139 + i.e. in wrapping with SOME term or NONE the latter is not sufficient*)
157.1140 +(*2002 fun parseold thy str =
157.1141 + (let
157.1142 + val sgn = sign_of thy;
157.1143 + val t = ((*typ_a2real o*) app_num_tr'1 o term_of)
157.1144 + (read_cterm sgn (str,(TVar(("DUMMY",0),[]))));
157.1145 + in SOME (cterm_of sgn t) end)
157.1146 + handle _ => NONE;*)
157.1147 +
157.1148 +
157.1149 +
157.1150 +fun parseold thy str =
157.1151 + (let val t = ((*typ_a2real o*) numbers_to_string)
157.1152 + (Syntax.read_term_global thy str)
157.1153 + in SOME (cterm_of thy t) end)
157.1154 + handle _ => NONE;
157.1155 +(*2002 fun parseN thy str =
157.1156 + (let
157.1157 + val sgn = sign_of thy;
157.1158 + val t = ((*typ_a2real o app_num_tr'1 o*) term_of)
157.1159 + (read_cterm sgn (str,(TVar(("DUMMY",0),[]))));
157.1160 + in SOME (cterm_of sgn t) end)
157.1161 + handle _ => NONE;*)
157.1162 +fun parseN thy str =
157.1163 + (let val t = (*(typ_a2real o numbers_to_string)*)
157.1164 + (Syntax.read_term_global thy str)
157.1165 + in SOME (cterm_of thy t) end)
157.1166 + handle _ => NONE;
157.1167 +(*2002 fun parse thy str =
157.1168 + (let
157.1169 + val sgn = sign_of thy;
157.1170 + val t = (typ_a2real o app_num_tr'1 o term_of)
157.1171 + (read_cterm sgn (str,(TVar(("DUMMY",0),[]))));
157.1172 + in SOME (cterm_of sgn t) end) (*FIXXXXME 10.8.02: return term !!!*)
157.1173 + handle _ => NONE;*)
157.1174 +(*2010 fun parse thy str =
157.1175 + (let val t = (typ_a2real o app_num_tr'1) (Syntax.read_term_global thy str)
157.1176 + in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*)
157.1177 + handle _ => NONE;*)
157.1178 +fun parse thy str =
157.1179 + (let val t = (typ_a2real o numbers_to_string)
157.1180 + (Syntax.read_term_global thy str)
157.1181 + in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*)
157.1182 + handle _ => NONE;
157.1183 +
157.1184 +(* 10.8.02: for this reason we still have ^^^--------------------
157.1185 + val thy = SqRoot.thy;
157.1186 + val str = "(1::real) ^ (2::nat)";
157.1187 + val sgn = sign_of thy;
157.1188 + val ct = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e =>print_exn e;
157.1189 +(*1*)"(1::real) ^ 2";
157.1190 + atomty (term_of ct);
157.1191 +*** -------------
157.1192 +*** Const ( Nat.power, [real, nat] => real)
157.1193 +*** . Const ( 1, real)
157.1194 +*** . Const ( Numeral.number_of, bin => nat)
157.1195 +*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin)
157.1196 +*** . . . Const ( Numeral.bin.Bit, [bin, bool] => bin)
157.1197 +*** . . . . Const ( Numeral.bin.Pls, bin)
157.1198 +*** . . . . Const ( True, bool)
157.1199 +*** . . . Const ( False, bool)
157.1200 + val t = ((app_num_tr' o term_of)
157.1201 + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e;
157.1202 + val ct = (cterm_of sgn t) handle e => print_exn e;
157.1203 +(*2*)"(1::real) ^ (2::nat)";
157.1204 + atomty (term_of ct);
157.1205 +*** -------------
157.1206 +*** Const ( Nat.power, [real, nat] => real)
157.1207 +*** . Free ( 1, real)
157.1208 +*** . Free ( 2, nat) (*1*) Const("2",_) (*2*) Free("2",_)
157.1209 +
157.1210 +
157.1211 + val str = "(2::real) ^ (2::nat)";
157.1212 + val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e;
157.1213 +val t = "(2::real) ^ 2" : cterm
157.1214 + val t = ((app_num_tr' o term_of)
157.1215 + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e;
157.1216 + val ct = (cterm_of sgn t) handle e => print_exn e;
157.1217 +Variable "2" has two distinct types
157.1218 +real
157.1219 +nat
157.1220 +uncaught exception TYPE
157.1221 + raised at: sign.ML:672.26-673.56
157.1222 + goals.ML:1100.61
157.1223 +
157.1224 +
157.1225 + val str = "(3::real) ^ (2::nat)";
157.1226 + val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e;
157.1227 +val t = "(3::real) ^ 2" : cterm
157.1228 + val t = ((app_num_tr' o term_of)
157.1229 + (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e;
157.1230 + val ct = (cterm_of sgn t) handle e => print_exn e;
157.1231 +val ct = "(3::real) ^ (2::nat)" : cterm
157.1232 +
157.1233 +
157.1234 +Conclusion: The type inference allows different types
157.1235 + for one and the same Numeral.number_of
157.1236 + BUT the type inference doesn't allow
157.1237 + Free ( 2, real) and Free ( 2, nat) within one term
157.1238 +--------------- ~~~~ ~~~ *)
157.1239 +(*
157.1240 +> val (SOME ct) = parse thy "(-#5)^^^#3";
157.1241 +> atomty (term_of ct);
157.1242 +*** -------------
157.1243 +*** Const ( Nat.op ^, ['a, nat] => 'a)
157.1244 +*** Const ( uminus, 'a => 'a)
157.1245 +*** Free ( #5, 'a)
157.1246 +*** Free ( #3, nat)
157.1247 +> val (SOME ct) = parse thy "R=R";
157.1248 +> atomty (term_of ct);
157.1249 +*** -------------
157.1250 +*** Const ( op =, [real, real] => bool)
157.1251 +*** Free ( R, real)
157.1252 +*** Free ( R, real)
157.1253 +
157.1254 +THIS IS THE OUTPUT FOR VERSION (3) above at typ_a2real !!!!!
157.1255 +*** -------------
157.1256 +*** Const ( op =, [RealDef.real, RealDef.real] => bool)
157.1257 +*** Free ( R, RealDef.real)
157.1258 +*** Free ( R, RealDef.real) *)
157.1259 +
157.1260 +(*version for testing local to theories*)
157.1261 +fun str2term_ thy str = (term_of o the o (parse thy)) str;
157.1262 +fun str2term str = (term_of o the o (parse (theory "Isac"))) str;
157.1263 +fun strs2terms ss = map str2term ss;
157.1264 +fun str2termN str = (term_of o the o (parseN (theory "Isac"))) str;
157.1265 +
157.1266 +(*+ makes a substitution from the output of Pattern.match +*)
157.1267 +(*fun mk_subs ((id, _):indexname, t:term) = (Free (id,type_of t), t);*)
157.1268 +fun mk_subs (subs: ((string * int) * (Term.typ * Term.term)) list) =
157.1269 +let fun mk_sub ((id, _), (ty, tm)) = (Free (id, ty), tm) in
157.1270 +map mk_sub subs end;
157.1271 +
157.1272 +val atomthm = atomt o #prop o rep_thm;
157.1273 +
157.1274 +(*.instantiate #prop thm with bound variables (as Free).*)
157.1275 +fun inst_bdv [] t = t : term
157.1276 + | inst_bdv (instl: (term*term) list) t =
157.1277 + let fun subst (v as Var((s,_),T)) =
157.1278 + (case explode s of
157.1279 + "b"::"d"::"v"::_ =>
157.1280 + if_none (assoc(instl,Free(s,T))) (Free(s,T))
157.1281 + | _ => v)
157.1282 + | subst (Abs(a,T,body)) = Abs(a, T, subst body)
157.1283 + | subst (f$t') = subst f $ subst t'
157.1284 + | subst t = if_none (assoc(instl,t)) t
157.1285 + in subst t end;
157.1286 +
157.1287 +
157.1288 +(*WN050829 caution: is_atom (str2term"q_0/2 * L * x") = true !!!
157.1289 + use length (vars term) = 1 instead*)
157.1290 +fun is_atom (Const ("Float.Float",_) $ _) = true
157.1291 + | is_atom (Const ("ComplexI.I'_'_",_)) = true
157.1292 + | is_atom (Const ("op *",_) $ t $ Const ("ComplexI.I'_'_",_)) = is_atom t
157.1293 + | is_atom (Const ("op +",_) $ t1 $ Const ("ComplexI.I'_'_",_)) = is_atom t1
157.1294 + | is_atom (Const ("op +",_) $ t1 $
157.1295 + (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_))) =
157.1296 + is_atom t1 andalso is_atom t2
157.1297 + | is_atom (Const _) = true
157.1298 + | is_atom (Free _) = true
157.1299 + | is_atom (Var _) = true
157.1300 + | is_atom _ = false;
157.1301 +(* val t = str2term "q_0/2 * L * x";
157.1302 +
157.1303 +
157.1304 +*)
157.1305 +(*val t = str2term "Float ((1,2),(0,0))";
157.1306 +> is_atom t;
157.1307 +val it = true : bool
157.1308 +> val t = str2term "Float ((1,2),(0,0)) * I__";
157.1309 +> is_atom t;
157.1310 +val it = true : bool
157.1311 +> val t = str2term "Float ((1,2),(0,0)) + Float ((3,4),(0,0)) * I__";
157.1312 +> is_atom t;
157.1313 +val it = true : bool
157.1314 +> val t = str2term "1 + 2*I__";
157.1315 +> val Const ("op +",_) $ t1 $ (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_)) = t;
157.1316 +*)
157.1317 +
157.1318 +(*.adaption from Isabelle/src/Pure/term.ML; reports if ALL Free's
157.1319 + have found a substitution (required for evaluating the preconditions
157.1320 + of _incomplete_ models).*)
157.1321 +fun subst_atomic_all [] t = (false, (*TODO may be 'true' for some terms ?*)
157.1322 + t : term)
157.1323 + | subst_atomic_all (instl: (term*term) list) t =
157.1324 + let fun subst (Abs(a,T,body)) =
157.1325 + let val (all, body') = subst body
157.1326 + in (all, Abs(a, T, body')) end
157.1327 + | subst (f$tt) =
157.1328 + let val (all1, f') = subst f
157.1329 + val (all2, tt') = subst tt
157.1330 + in (all1 andalso all2, f' $ tt') end
157.1331 + | subst (t as Free _) =
157.1332 + if is_num t then (true, t) (*numerals cannot be subst*)
157.1333 + else (case assoc(instl,t) of
157.1334 + SOME t' => (true, t')
157.1335 + | NONE => (false, t))
157.1336 + | subst t = (true, if_none (assoc(instl,t)) t)
157.1337 + in subst t end;
157.1338 +
157.1339 +(*.add two terms with a type given.*)
157.1340 +fun mk_add t1 t2 =
157.1341 + let val T1 = type_of t1
157.1342 + val T2 = type_of t2
157.1343 + in if T1 <> T2 then raise TYPE ("mk_add gets ",[T1, T2],[t1,t2])
157.1344 + else (Const ("op +", [T1, T2] ---> T1) $ t1 $ t2)
157.1345 + end;
157.1346 +
158.1 --- a/src/Tools/isac/RCODE-root.sml Wed Aug 25 15:15:01 2010 +0200
158.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
158.3 @@ -1,81 +0,0 @@
158.4 -(*.evaluate isac (all the code of the kernel) and isactest
158.5 - (c) Walther Neuper 1997
158.6 -
158.7 - /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac
158.8 -
158.9 - /usr/local/Isabelle2002/bin/isabelle HOL-Real
158.10 - cd"~/proto2/isac/src/sml"; use"RCODE-root.sml";
158.11 -
158.12 - use"ROOT.ML";
158.13 - use"RTEST-root.sml";
158.14 -.*)
158.15 -
158.16 -(*.please change HERE and in ROOT.ML accordingly,
158.17 - if you store a new heap ...*)
158.18 -val version_isac = "WN0710-calcResponse";
158.19 -
158.20 -print_depth 1;(*reduces verbosity of stdout*)
158.21 -
158.22 -(*.this function from Isabelle2002/src/Pure/library.ML is overwritten
158.23 - by some Isabelle2002 theory file; thus reestablished for isac.*)
158.24 -fun find_first _ [] = NONE
158.25 - | find_first pred (x :: xs) =
158.26 - if pred x then SOME x else find_first pred xs;
158.27 -fun swap (x, y) = (y, x);
158.28 -(*HACK.WN080107*) val sstr = str;
158.29 -
158.30 -"**** build the isac kernel = math-engine + IsacKnowledge ";
158.31 -"**** build the math-engine ******************************";
158.32 -use"library.sml";
158.33 -use"calcelems.sml";
158.34 -cd "Scripts";
158.35 - use"term_G.sml";
158.36 - use"calculate.sml";
158.37 - use"rewrite.sml";
158.38 - use_thy"Script";
158.39 -(* remove_thy"ListG";
158.40 - use_thy"~/proto2/isac/src/sml/Scripts/Script";
158.41 - *)
158.42 - use"scrtools.sml";
158.43 - cd "..";
158.44 -cd "ME";
158.45 - use"mstools.sml";
158.46 - use"ctree.sml";
158.47 - use"ptyps.sml";
158.48 - use"generate.sml";
158.49 - use"calchead.sml";
158.50 - use"appl.sml";
158.51 - use"rewtools.sml";
158.52 - use"script.sml";
158.53 - use"solve.sml";
158.54 - use"inform.sml";
158.55 - use"mathengine.sml";
158.56 - cd "..";
158.57 -cd "xmlsrc";
158.58 - use"mathml.sml";
158.59 - use"datatypes.sml";
158.60 - use"pbl-met-hierarchy.sml";
158.61 - use"thy-hierarchy.sml";
158.62 - use"interface-xml.sml";
158.63 - cd "..";
158.64 -cd"FE-interface";
158.65 - use"messages.sml";
158.66 - use"states.sml";
158.67 - use"interface.sml";
158.68 - cd "..";
158.69 -use"print_exn_G.sml";
158.70 -"**** build math-engine complete *************************";
158.71 -
158.72 -"**** build the IsacKnowledge ****************************";
158.73 - cd "IsacKnowledge";
158.74 - use_thy"Isac"; (*evaluates ALL thys depending on the root 'Isac'*)
158.75 -
158.76 - (* remove_thy"Typefix";
158.77 - use_thy"~/proto2/isac/src/sml/IsacKnowledge/Isac";
158.78 - *)
158.79 - cd "..";
158.80 -"**** build IsacKnowledge complete ***********************";
158.81 -"**** build isac kernel complete *************************";
158.82 -
158.83 -states:=[];
158.84 -print_depth 3;
159.1 --- a/src/Tools/isac/ROOT.ML Wed Aug 25 15:15:01 2010 +0200
159.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
159.3 @@ -1,282 +0,0 @@
159.4 -(*.evaluate isac (all the code of the kernel) and isactest
159.5 - (c) Walther Neuper 1997
159.6 -
159.7 ---------------------------------------------------------old heap on new nb
159.8 - polyisac /home/neuper/devel/isac-10/heap/HOL-Real-Isac
159.9 ---------------------------------------------------------old heap on new nb
159.10 -
159.11 - poly /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/HOL-Real
159.12 - cd"/home/neuper/proto2/isac/src/sml"; use"ROOT.ML";
159.13 -
159.14 -############################# nb-setup 080917 broke the isabelle configuration; thus HOL-Real CANNOT BE RECOMPUTED todo !
159.15 -
159.16 - /usr/local/Isabelle2002/bin/isabelle HOL-Real
159.17 - cd"/home/neuper/proto2/isac/src/sml"; use"ROOT.ML";
159.18 -
159.19 -############################# Rational-SK070730.ML #############
159.20 -
159.21 - cd"/home/neuper/proto2/isac/src/sml"; use"RCODE-root.sml";
159.22 - cd"/home/neuper/proto2/isac/src/sml"; use"RTEST-root.sml";
159.23 -.*)
159.24 -
159.25 -(*.please change HERE and in RCODE-root accordingly,
159.26 - if you store a new heap ...*)
159.27 -val version_isac = "WN071206-applyTacticTW";
159.28 -
159.29 -print_depth 1;(*reduces verbosity of stdout*)
159.30 -
159.31 -(*.these functions from Isabelle2002/src/Pure/library.ML are overwritten
159.32 - by some Isabelle2002 theory file; thus reestablished for isac.*)
159.33 -fun find_first _ [] = NONE
159.34 - | find_first pred (x :: xs) =
159.35 - if pred x then SOME x else find_first pred xs;
159.36 -fun swap (x, y) = (y, x);
159.37 -(*HACK.WN080107*) val sstr = str;
159.38 -
159.39 -"**** build the isac kernel = math-engine + IsacKnowledge ";
159.40 -"**** build the math-engine ******************************";
159.41 -use"library.sml";
159.42 -use"calcelems.sml";
159.43 -check_guhs_unique := true;
159.44 -cd "Scripts";
159.45 - use"term_G.sml";
159.46 - use"calculate.sml";
159.47 - use"rewrite.sml";
159.48 - use_thy"Script";
159.49 -(* remove_thy"ListG";
159.50 - use_thy"~/proto2/isac/src/sml/Scripts/Script";
159.51 - *)
159.52 - use"scrtools.sml";
159.53 - cd "..";
159.54 -cd "ME";
159.55 - use"mstools.sml";
159.56 - use"ctree.sml";
159.57 - use"ptyps.sml";
159.58 - use"generate.sml";
159.59 - use"calchead.sml";
159.60 - use"appl.sml";
159.61 - use"rewtools.sml";
159.62 - use"script.sml";
159.63 - use"solve.sml";
159.64 - use"inform.sml";
159.65 - use"mathengine.sml";
159.66 - cd "..";
159.67 -cd "xmlsrc";
159.68 - use"mathml.sml";
159.69 - use"datatypes.sml";
159.70 - use"pbl-met-hierarchy.sml";
159.71 - use"thy-hierarchy.sml";
159.72 - use"interface-xml.sml";
159.73 - cd "..";
159.74 -cd"FE-interface";
159.75 - use"messages.sml";
159.76 - use"states.sml";
159.77 - use"interface.sml";
159.78 - cd "..";
159.79 -use"print_exn_G.sml";
159.80 -"**** build math-engine complete *************************";
159.81 -
159.82 -"**** build the IsacKnowledge ****************************";
159.83 - cd "IsacKnowledge";
159.84 - use_thy"Isac"; (*evaluates ALL thys depending on the root 'Isac'*)
159.85 -
159.86 - (* remove_thy"Typefix";
159.87 - use_thy"~/proto2/isac/src/sml/IsacKnowledge/Isac";
159.88 - *)
159.89 - cd "..";
159.90 -"**** build IsacKnowledge complete ***********************";
159.91 -"**** build isac kernel complete *************************";
159.92 -check_guhs_unique := false;
159.93 -
159.94 -"**** run the tests **************************************";
159.95 -cd "systest";
159.96 -(*+ check kbtest/diffapp.sml for additional items in met-model*)
159.97 - use"root-equ.sml";
159.98 - use"script.sml";
159.99 - (* use"script_if.sml"; WN03 missing: is_rootequation_in*)
159.100 - use"scriptnew.sml";
159.101 - use"subp-rooteq.sml";
159.102 - use"tacis.sml";
159.103 - use"interface-xml.sml";
159.104 - (* use"testdaten.sml"; no update after dropping 'errorBound'*)
159.105 - cd "../..";
159.106 -"**** run systests complete ******************************";
159.107 -(*TODO copy the whole filestructure from sml to smltest*)
159.108 -
159.109 -cd"smltest/Scripts";
159.110 - use"calculate-float.sml";
159.111 - use"calculate.sml";
159.112 - use"listg.sml";
159.113 - use"rewrite.sml";
159.114 - use"scrtools.sml";
159.115 - use"term_G.sml";
159.116 - use"tools.sml";
159.117 - cd "../..";
159.118 -cd"smltest/ME";
159.119 - use"ctree.sml";
159.120 - use"calchead.sml";
159.121 - use"rewtools.sml";
159.122 - use"solve.sml"; (*detailrls can notyet ackn. 'Rewrite_Set "cancel"' *);
159.123 - use"inform.sml";
159.124 - use"me.sml";
159.125 - use"ptyps.sml";
159.126 - cd "../..";
159.127 -cd"smltest/xmlsrc";
159.128 - use"datatypes.sml";
159.129 - use"pbl-met-hierarchy.sml";
159.130 - use"thy-hierarchy.sml";
159.131 - cd "../..";
159.132 -cd"smltest/FE-interface";
159.133 - use"interface.sml";
159.134 - cd "../..";
159.135 -"**** run tests on math-engine complete ******************";
159.136 -cd"smltest/IsacKnowledge";
159.137 - use"atools.sml";
159.138 - use"complex.sml";
159.139 - use"diff.sml";
159.140 - use"diffapp.sml";
159.141 - use"integrate.sml";
159.142 - use"equation.sml";
159.143 - (*use"inssort.sml"; problems with recdef in Isabelle2002*)
159.144 - use"logexp.sml";
159.145 - use"poly.sml";
159.146 - use"polyminus.sml";
159.147 - use"polyeq.sml"; (*TODO 31.b, n1., 44.a, 1.a~, 1.b (all'expanded')WN
159.148 - ? also check others without check 'diff.behav.'*);
159.149 - use"rateq.sml";
159.150 - use"rational.sml" (*TODO add_fractions_p throws overflow-exn WN*);
159.151 - use"rlang.sml"; (*WN.12.6.03: for TODOs search 'writeln',
159.152 - for simplification search MG
159.153 - erls: 98a(1) 104a(1) 104a(2) 68a *);
159.154 - use"root.sml";
159.155 - use"rooteq.sml";
159.156 - use"rootrateq.sml";
159.157 - use"termorder.sml";
159.158 - use"trig.sml";
159.159 - use"vect.sml";
159.160 - use"wn.sml";
159.161 - use"eqsystem.sml";
159.162 - use"biegelinie.sml";
159.163 - use"algein.sml";
159.164 - cd "../..";
159.165 -"**** run tests on IsacKnowledge complete ****************";
159.166 -
159.167 -val path = "/home/neuper/proto2/testsml2xml/";
159.168 -pbl_hierarchy2file (path ^ "pbl/");
159.169 -pbls2file (path ^ "pbl/");
159.170 -met_hierarchy2file (path ^ "met/");
159.171 -mets2file (path ^ "met/");
159.172 -thy_hierarchy2file (path ^ "thy/");
159.173 -thes2file (path ^ "thy/");
159.174 -"**** tested creation of xmldata *************************";
159.175 -
159.176 -cd"sml";
159.177 -states:=[];
159.178 -print_depth 3;
159.179 -"=========================================================";
159.180 -
159.181 -"**** build math-engine complete *************************";
159.182 -"**** build IsacKnowledge complete ***********************";
159.183 -"**** run systests complete ***************** re-organize!";
159.184 -"**** run tests on math-engine complete ******************";
159.185 -"**** run tests on IsacKnowledge complete ****************";
159.186 -"**** tested creation of xmldata *************************";
159.187 -"**** build isac kernel + run tests complete *************";
159.188 -
159.189 -
159.190 -
159.191 -(****************************************************************************
159.192 -WN.notebook: SMLNJ
159.193 ------------------------------------------------------------------------------
159.194 - cd ~/isabelle-smlnj/heaps/smlnj-110_x86-linux/
159.195 - sml @SMLload=02-HOL-Real-isac
159.196 - cd"~/develop/sml/";
159.197 - use"ROOT.ML";
159.198 -
159.199 -*****************************************************************************
159.200 -WN.notebook: create HTML representation for theory files für Isac
159.201 ------------------------------------------------------------------------------
159.202 -su
159.203 -cd /home/neuper/proto2/isac/src/
159.204 -mv sml Isac
159.205 -mv Isac/ROOT.ML Isac/ROOT.ML-save
159.206 -cp Isac/RCODE-root.sml Isac/ROOT.ML
159.207 -(*!!!cd"sml";!!! in ROOT.ML-save causes SysErr ("chdir failed", SOME ENOENT)*)
159.208 -
159.209 -/usr/local/Isabelle2002/bin/isatool usedir -i true HOL-Real /home/neuper/proto2/isac/src/Isac/
159.210 -(*^^^ does not create a new heap and writes only NEW files ...
159.211 - ... to isab-installation vvv*)
159.212 -cd /usr/local/Isabelle2002/browser_info/HOL/HOL-Real/
159.213 -cp -r Isac/ /home/neuper/proto2/www/kbase/thy/browser_info/HOL/HOL-Real/
159.214 -
159.215 -cd /home/neuper/proto2/isac/src/
159.216 -mv Isac sml
159.217 -mv sml/ROOT.ML-save sml/ROOT.ML
159.218 -exit
159.219 -
159.220 -*****************************************************************************
159.221 -save and restore contents in *.xml-files; @ stands for thy | pbl | met
159.222 ------------------------------------------------------------------------------
159.223 -@> grep EXPLANATIONS *.xml > saveecex/EXPLANATIONS.tex
159.224 -@> emacs saveexec/EXPLANATIONS.tex &
159.225 -## there search with "<EXPLANATIONS> </EXPLANATIONS>" for missing lines ...
159.226 -@> cd saveexec
159.227 -## ... and check with ls -l file.xml
159.228 -@> cd ..
159.229 -@> rm *.xml
159.230 ------------------------------------------------------------------------------
159.231 -export of problems and methods from sml to xml ... see below ***
159.232 -restore contents in *.xml-files:
159.233 ------------------------------------------------------------------------------
159.234 -
159.235 -
159.236 -
159.237 -*****************************************************************************
159.238 -export of problems and methods from sml to xml
159.239 ------------------------------------------------------------------------------
159.240 -> val path = "/home/neuper/proto2/isac/xmldata/";
159.241 -
159.242 -> pbl_hierarchy2file (path ^ "pbl/");
159.243 -> pbls2file (path ^ "pbl/");
159.244 -
159.245 -> met_hierarchy2file (path ^ "met/");
159.246 -> mets2file (path ^ "met/");
159.247 -
159.248 -> thy_hierarchy2file (path ^ "thy/");
159.249 -> thes2file (path ^ "thy/");
159.250 -
159.251 -*****************************************************************************
159.252 -WN.notebook: create a new heap (which is used by java in eclipse)
159.253 -(PolyML overwrites HOL-Real-Isac !)
159.254 ------------------------------------------------------------------------------
159.255 - su
159.256 - cd /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux
159.257 - rm HOL-Real-Isac
159.258 - cp HOL-Real HOL-Real-Isac
159.259 - poly /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/HOL-Real-Isac
159.260 - cd"/home/neuper/proto2/isac/src/sml"; use"RCODE-root.sml";
159.261 - <ctrl><d>
159.262 - exit
159.263 -
159.264 -*****************************************************************************;
159.265 -IST has another linux + polyml: create another new heap
159.266 ------------------------------------------------------------------------------
159.267 -notebook:sml> scp -r ../sml wneuper@pear.ist.intra:del_graz/
159.268 -
159.269 - ssh ist
159.270 - cd /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/
159.271 - rm HOL-Real-Isac
159.272 - TYPE 'yes' !!!
159.273 - cp HOL-Real HOL-Real-Isac
159.274 - chmod u+w HOL-Real-Isac
159.275 - cd ~/del_graz/sml
159.276 - /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac
159.277 - use"RCODE-root.sml";
159.278 - <ctrl><d>
159.279 - cd /usr/local/Isabelle2002/heaps/polyml-4.1.3_x86-linux/
159.280 - chmod u-w HOL-Real-Isac
159.281 -
159.282 - logout
159.283 ------------------------------------------------------------------------------
159.284 -test ist> /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac
159.285 -*****************************************************************************);
160.1 --- a/src/Tools/isac/RTEST-root.sml Wed Aug 25 15:15:01 2010 +0200
160.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
160.3 @@ -1,103 +0,0 @@
160.4 -(*.evaluate isac (all the code of the kernel) and isactest
160.5 - (c) Walther Neuper 1997
160.6 -
160.7 - /usr/local/Isabelle2002/bin/isabelle HOL-Real-Isac
160.8 -
160.9 - /usr/local/Isabelle2002/bin/isabelle HOL-Real
160.10 - cd"~/proto2/isac/src/sml";
160.11 - use"RTEST-root.sml";
160.12 -
160.13 - use"ROOT.ML";
160.14 - use"RCODE-root.sml";
160.15 -.*)
160.16 -
160.17 -"**** run the tests **************************************";
160.18 -cd "systest";
160.19 -(*+ check kbtest/diffapp.sml for additional items in met-model*)
160.20 - use"root-equ.sml";
160.21 - use"script.sml";
160.22 - (* use"script_if.sml"; WN03 missing: is_rootequation_in*)
160.23 - use"scriptnew.sml";
160.24 - use"subp-rooteq.sml";
160.25 - use"tacis.sml";
160.26 - use"interface-xml.sml";
160.27 - (* use"testdaten.sml"; no update after dropping 'errorBound'*)
160.28 - cd "../..";
160.29 -"**** run systests complete ******************************";
160.30 -
160.31 -cd"smltest/Scripts";
160.32 - use"calculate-float.sml";
160.33 - use"calculate.sml";
160.34 - use"listg.sml";
160.35 - use"rewrite.sml";
160.36 - use"scrtools.sml";
160.37 - use"term_G.sml";
160.38 - use"tools.sml";
160.39 - cd "../..";
160.40 -cd"smltest/ME";
160.41 - use"ctree.sml";
160.42 - use"calchead.sml";
160.43 - use"rewtools.sml";
160.44 - use"solve.sml"; (*detailrls can notyet ackn. 'Rewrite_Set "cancel"' *);
160.45 - use"inform.sml";
160.46 - use"me.sml";
160.47 - use"ptyps.sml";
160.48 - cd "../..";
160.49 -cd"smltest/xmlsrc";
160.50 - use"datatypes.sml";
160.51 - use"pbl-met-hierarchy.sml";
160.52 - use"thy-hierarchy.sml";
160.53 - cd "../..";
160.54 -cd"smltest/FE-interface";
160.55 - use"interface.sml";
160.56 - cd "../..";
160.57 -"**** run tests on math-engine complete ******************";
160.58 -cd"smltest/IsacKnowledge";
160.59 - use"atools.sml";
160.60 - use"complex.sml";
160.61 - use"diff.sml";
160.62 - use"diffapp.sml";
160.63 - use"integrate.sml";
160.64 - use"equation.sml";
160.65 - (*use"inssort.sml"; problems with recdef in Isabelle2002*)
160.66 - use"logexp.sml";
160.67 - use"poly.sml";
160.68 - use"polyminus.sml";
160.69 - use"polyeq.sml"; (*TODO 31.b, n1., 44.a, 1.a~, 1.b (all'expanded')WN
160.70 - ? also check others without check 'diff.behav.'*);
160.71 - use"rateq.sml";
160.72 - use"rational.sml" (*TODO add_fractions_p throws overflow-exn WN*);
160.73 - use"rlang.sml"; (*WN.12.6.03: for TODOs search 'writeln',
160.74 - for simplification search MG
160.75 - erls: 98a(1) 104a(1) 104a(2) 68a *);
160.76 - use"root.sml";
160.77 - use"rooteq.sml";
160.78 - use"rootrateq.sml";
160.79 - use"termorder.sml";
160.80 - use"trig.sml";
160.81 - use"vect.sml";
160.82 - use"wn.sml";
160.83 - use"eqsystem.sml";
160.84 - use"biegelinie.sml";
160.85 - use"algein.sml";
160.86 - cd "../..";
160.87 -"**** run tests on IsacKnowledge complete ****************";
160.88 -
160.89 -val path = "/home/neuper/proto2/testsml2xml/";
160.90 -pbl_hierarchy2file (path ^ "pbl/");
160.91 -pbls2file (path ^ "pbl/");
160.92 -met_hierarchy2file (path ^ "met/");
160.93 -mets2file (path ^ "met/");
160.94 -thy_hierarchy2file (path ^ "thy/");
160.95 -thes2file (path ^ "thy/");
160.96 -"**** tested creation of xmldata *************************";
160.97 -
160.98 -cd"sml";
160.99 -states:=[];
160.100 -"=========================================================";
160.101 -
160.102 -"**** run systests complete ***************** re-organize!";
160.103 -"**** run tests on math-engine complete ******************";
160.104 -"**** run tests on IsacKnowledge complete ****************";
160.105 -"**** build isac kernel + run tests complete *************";
160.106 -"**** tested creation of xmldata *************************";
161.1 --- a/src/Tools/isac/Scripts/Isabelle-isac-conflicts Wed Aug 25 15:15:01 2010 +0200
161.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
161.3 @@ -1,22 +0,0 @@
161.4 -6.8.02:
161.5 -(1) special constants are already defined by Isabelle2002,
161.6 - and thus cannot be parsed from terms; eg.
161.7 -
161.8 - Reals thus formula 'subproblem (Reals,...)' not possible
161.9 - power thus 'Calculate power' not possible in Scripts
161.10 -
161.11 -(2) numerals in (terms and) thms are stored differently:
161.12 - string Isabelle term isac term
161.13 - 123 Bin.... Free("123",_)
161.14 - 0 Const("0",_) Free("0",_)
161.15 - 0 Const("1",_) Free("1",_)
161.16 -
161.17 -(3) overwritteln functions
161.18 - find_first see isac/ROOT.ML
161.19 -
161.20 -
161.21 -Questions for Isabelle team:
161.22 -
161.23 -28.02.03
161.24 -(4) what is going on in Isa02/Typefix.thy (Markus Wenzen) ?
161.25 -(5) how avoid "- x" ---parse---> Free ("-x", _) ?
161.26 \ No newline at end of file
162.1 --- a/src/Tools/isac/Scripts/ListG.thy Wed Aug 25 15:15:01 2010 +0200
162.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
162.3 @@ -1,204 +0,0 @@
162.4 -(* use_thy_only"../Scripts/ListG";
162.5 - use_thy_only"Scripts/ListG";
162.6 - use_thy"Scripts/ListG";
162.7 -
162.8 - use_thy_only"ListG";
162.9 - W.N. 8.01
162.10 - attaches identifiers to definition of listfuns,
162.11 - for storing them in list_rls
162.12 -
162.13 -WN.29.4.03:
162.14 -*)
162.15 -
162.16 -theory ListG imports Complex_Main
162.17 -uses ("library.sml")("calcelems.sml")
162.18 -("Scripts/term_G.sml")("Scripts/calculate.sml")
162.19 -("Scripts/rewrite.sml")
162.20 -begin
162.21 -use "library.sml" (*indent,...*)
162.22 -use "calcelems.sml" (*str_of_type, Thm,...*)
162.23 -use "Scripts/term_G.sml" (*num_str,...*)
162.24 -use "Scripts/calculate.sml" (*???*)
162.25 -use "Scripts/rewrite.sml" (*?*** At command "end" (line 205../ListG.thy*)
162.26 -
162.27 -text {* 'nat' in List.thy replaced by 'real' *}
162.28 -
162.29 -primrec length_' :: "'a list => real"
162.30 -where
162.31 - LENGTH_NIL: "length_' [] = 0" (*length: 'a list => nat*)
162.32 -| LENGTH_CONS: "length_' (x#xs) = 1 + length_' xs"
162.33 -
162.34 -primrec del :: "['a list, 'a] => 'a list"
162.35 -where
162.36 - del_base: "del [] x = []"
162.37 -| del_rec: "del (y#ys) x = (if x = y then ys else y#(del ys x))"
162.38 -
162.39 -definition
162.40 - list_diff :: "['a list, 'a list] => 'a list" (* as -- bs *)
162.41 - ("(_ --/ _)" [66, 66] 65)
162.42 - where "a -- b == foldl del a b"
162.43 -
162.44 -consts nth_' :: "[real, 'a list] => 'a"
162.45 -axioms
162.46 - (*** more than one non-variable in pattern in "nth_ 1 [x] = x"--*)
162.47 - NTH_NIL: "nth_' 1 (x#xs) = x"
162.48 -(* NTH_CONS: "nth_' n (x#xs) = nth_' (n+ -1) xs" *)
162.49 -
162.50 -(*rewriter does not reach base case ...... ;
162.51 - the condition involves another rule set (erls, eval_binop in Atools):*)
162.52 - NTH_CONS: "1 < n ==> nth_' n (x#xs) = nth_' (n+ - 1) xs"
162.53 -
162.54 -(*primrec from Isabelle/src/HOL/List.thy -- def.twice not allowed*)
162.55 -(*primrec*)
162.56 - hd_thm: "hd(x#xs) = x"
162.57 -(*primrec*)
162.58 - tl_Nil: "tl([]) = []"
162.59 - tl_Cons: "tl(x#xs) = xs"
162.60 -(*primrec*)
162.61 - null_Nil: "null([]) = True"
162.62 - null_Cons: "null(x#xs) = False"
162.63 -(*primrec*)
162.64 - LAST: "last(x#xs) = (if xs=[] then x else last xs)"
162.65 -(*primrec*)
162.66 - butlast_Nil: "butlast [] = []"
162.67 - butlast_Cons: "butlast(x#xs) = (if xs=[] then [] else x#butlast xs)"
162.68 -(*primrec*)
162.69 - mem_Nil: "x mem [] = False"
162.70 - mem_Cons: "x mem (y#ys) = (if y=x then True else x mem ys)"
162.71 -(*primrec-------already named---
162.72 - "set [] = {}"
162.73 - "set (x#xs) = insert x (set xs)"
162.74 - primrec
162.75 - list_all_Nil "list_all P [] = True"
162.76 - list_all_Cons "list_all P (x#xs) = (P(x) & list_all P xs)"
162.77 -----------------*)
162.78 -(*primrec*)
162.79 - map_Nil: "map f [] = []"
162.80 - map_Cons: "map f (x#xs) = f(x)#map f xs"
162.81 -(*primrec*)
162.82 - append_Nil: "[] @ys = ys"
162.83 - append_Cons: "(x#xs)@ys = x#(xs@ys)"
162.84 -(*primrec*)
162.85 - rev_Nil: "rev([]) = []"
162.86 - rev_Cons: "rev(x#xs) = rev(xs) @ [x]"
162.87 -(*primrec*)
162.88 - filter_Nil: "filter P [] = []"
162.89 - filter_Cons: "filter P (x#xs) =(if P x then x#filter P xs else filter P xs)"
162.90 -(*primrec-------already named---
162.91 - foldl_Nil "foldl f a [] = a"
162.92 - foldl_Cons "foldl f a (x#xs) = foldl f (f a x) xs"
162.93 -----------------*)
162.94 -(*primrec*)
162.95 - foldr_Nil: "foldr f [] a = a"
162.96 - foldr_Cons: "foldr f (x#xs) a = f x (foldr f xs a)"
162.97 -(*primrec*)
162.98 - concat_Nil: "concat([]) = []"
162.99 - concat_Cons: "concat(x#xs) = x @ concat(xs)"
162.100 -(*primrec-------already named---
162.101 - drop_Nil "drop n [] = []"
162.102 - drop_Cons "drop n (x#xs) = (case n of 0 => x#xs | Suc(m) => drop m xs)"
162.103 - (* Warning: simpset does not contain this definition but separate theorems
162.104 - for n=0 / n=Suc k*)
162.105 -(*primrec*)
162.106 - take_Nil "take n [] = []"
162.107 - take_Cons "take n (x#xs) = (case n of 0 => [] | Suc(m) => x # take m xs)"
162.108 - (* Warning: simpset does not contain this definition but separate theorems
162.109 - for n=0 / n=Suc k*)
162.110 -(*primrec*)
162.111 - nth_Cons "(x#xs)!n = (case n of 0 => x | (Suc k) => xs!k)"
162.112 - (* Warning: simpset does not contain this definition but separate theorems
162.113 - for n=0 / n=Suc k*)
162.114 -(*primrec*)
162.115 - " [][i:=v] = []"
162.116 - "(x#xs)[i:=v] = (case i of 0 => v # xs
162.117 - | Suc j => x # xs[j:=v])"
162.118 -----------------*)
162.119 -(*primrec*)
162.120 - takeWhile_Nil: "takeWhile P [] = []"
162.121 - takeWhile_Cons:
162.122 - "takeWhile P (x#xs) = (if P x then x#takeWhile P xs else [])"
162.123 -(*primrec*)
162.124 - dropWhile_Nil: "dropWhile P [] = []"
162.125 - dropWhile_Cons:
162.126 - "dropWhile P (x#xs) = (if P x then dropWhile P xs else x#xs)"
162.127 -(*primrec*)
162.128 - zip_Nil: "zip xs [] = []"
162.129 - zip_Cons: "zip xs (y#ys) =(case xs of [] => [] | z#zs =>(z,y)#zip zs ys)"
162.130 - (* Warning: simpset does not contain this definition but separate theorems
162.131 - for xs=[] / xs=z#zs *)
162.132 -(*primrec
162.133 - upt_0 "[i..0(] = []"
162.134 - upt_Suc "[i..(Suc j)(] = (if i <= j then [i..j(] @ [j] else [])"
162.135 -*)
162.136 -(*primrec*)
162.137 - distinct_Nil: "distinct [] = True"
162.138 - distinct_Cons: "distinct (x#xs) = (x ~: set xs & distinct xs)"
162.139 -(*primrec*)
162.140 - remdups_Nil: "remdups [] = []"
162.141 - remdups_Cons: "remdups (x#xs) =
162.142 - (if x : set xs then remdups xs else x # remdups xs)"
162.143 -(*primrec-------already named---
162.144 - replicate_0 "replicate 0 x = []"
162.145 - replicate_Suc "replicate (Suc n) x = x # replicate n x"
162.146 -----------------*)
162.147 -
162.148 -(** Lexicographic orderings on lists ...!!!**)
162.149 -
162.150 -ML{* (*the former ListG.ML*)
162.151 -(** rule set for evaluating listexpr in scripts **)
162.152 -val list_rls =
162.153 - Rls{id="list_rls",preconds = [], rew_ord = ("dummy_ord",dummy_ord),
162.154 - erls = e_rls, srls = Erls, calc = [], (*asm_thm=[],*)
162.155 - rules = (*8.01: copied from*)
162.156 - [Thm ("refl", num_str refl), (*'a<>b -> FALSE' by fun eval_equal*)
162.157 - Thm ("o_apply", num_str @{thm o_apply}),
162.158 -
162.159 - Thm ("NTH_CONS",num_str @{thm NTH_CONS}),(*erls for cond. in Atools.ML*)
162.160 - Thm ("NTH_NIL",num_str @{thm NTH_NIL}),
162.161 - Thm ("append_Cons",num_str @{thm append_Cons}),
162.162 - Thm ("append_Nil",num_str @{thm append_Nil}),
162.163 - Thm ("butlast_Cons",num_str @{thm butlast_Cons}),
162.164 - Thm ("butlast_Nil",num_str @{thm butlast_Nil}),
162.165 - Thm ("concat_Cons",num_str @{thm concat_Cons}),
162.166 - Thm ("concat_Nil",num_str @{thm concat_Nil}),
162.167 - Thm ("del_base",num_str @{thm del_base}),
162.168 - Thm ("del_rec",num_str @{thm del_rec}),
162.169 -
162.170 - Thm ("distinct_Cons",num_str @{thm distinct_Cons}),
162.171 - Thm ("distinct_Nil",num_str @{thm distinct_Nil}),
162.172 - Thm ("dropWhile_Cons",num_str @{thm dropWhile_Cons}),
162.173 - Thm ("dropWhile_Nil",num_str @{thm dropWhile_Nil}),
162.174 - Thm ("filter_Cons",num_str @{thm filter_Cons}),
162.175 - Thm ("filter_Nil",num_str @{thm filter_Nil}),
162.176 - Thm ("foldr_Cons",num_str @{thm foldr_Cons}),
162.177 - Thm ("foldr_Nil",num_str @{thm foldr_Nil}),
162.178 - Thm ("hd_thm",num_str @{thm hd_thm}),
162.179 - Thm ("LAST",num_str @{thm LAST}),
162.180 - Thm ("LENGTH_CONS",num_str @{thm LENGTH_CONS}),
162.181 - Thm ("LENGTH_NIL",num_str @{thm LENGTH_NIL}),
162.182 - Thm ("list_diff_def",num_str @{thm list_diff_def}),
162.183 - Thm ("map_Cons",num_str @{thm map_Cons}),
162.184 - Thm ("map_Nil",num_str @{thm map_Cons}),
162.185 - Thm ("mem_Cons",num_str @{thm mem_Cons}),
162.186 - Thm ("mem_Nil",num_str @{thm mem_Nil}),
162.187 - Thm ("null_Cons",num_str @{thm null_Cons}),
162.188 - Thm ("null_Nil",num_str @{thm null_Nil}),
162.189 - Thm ("remdups_Cons",num_str @{thm remdups_Cons}),
162.190 - Thm ("remdups_Nil",num_str @{thm remdups_Nil}),
162.191 - Thm ("rev_Cons",num_str @{thm rev_Cons}),
162.192 - Thm ("rev_Nil",num_str @{thm rev_Nil}),
162.193 - Thm ("take_Nil",num_str @{thm take_Nil}),
162.194 - Thm ("take_Cons",num_str @{thm take_Cons}),
162.195 - Thm ("tl_Cons",num_str @{thm tl_Cons}),
162.196 - Thm ("tl_Nil",num_str @{thm tl_Nil}),
162.197 - Thm ("zip_Cons",num_str @{thm zip_Cons}),
162.198 - Thm ("zip_Nil",num_str @{thm zip_Nil})
162.199 - ], scr = EmptyScr}:rls;
162.200 -*}
162.201 -
162.202 -ML{*
162.203 -ruleset' := overwritelthy @{theory} (!ruleset',
162.204 - [("list_rls",list_rls)
162.205 - ]);
162.206 -*}
162.207 -end
163.1 --- a/src/Tools/isac/Scripts/Real2002-theorems.sml Wed Aug 25 15:15:01 2010 +0200
163.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
163.3 @@ -1,1005 +0,0 @@
163.4 -(*WN060306 from isabelle-users:
163.5 -put expressions involving plus and minus into a canonical form. Here is a possible set of
163.6 -rules:
163.7 -
163.8 - add_assoc add_commute
163.9 - diff_def minus_add_distrib
163.10 - minus_minus minus_zero
163.11 -===========================================================================*)
163.12 -
163.13 -(*
163.14 - cd ~/Isabelle2002/src/HOL/Real
163.15 - grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml
163.16 - WN 9.8.02
163.17 -
163.18 -ML> thy;
163.19 -val it =
163.20 - {ProtoPure, CPure, HOL, Set, Typedef, Fun, Product_Type, Lfp, Gfp, Sum_Type,
163.21 - Relation, Record, Inductive, Transitive_Closure, Wellfounded_Recursion,
163.22 - NatDef, Nat, NatArith, Divides, Power, SetInterval, Finite_Set, Equiv,
163.23 - IntDef, Int, Datatype_Universe, Datatype, Numeral, Bin, IntArith,
163.24 - Wellfounded_Relations, Recdef, IntDiv, IntPower, NatBin, NatSimprocs,
163.25 - Relation_Power, PreList, List, Map, Hilbert_Choice, Main, Lubs, PNat, PRat,
163.26 - PReal, RealDef, RealOrd, RealInt, RealBin, RealArith0, RealArith,
163.27 - RComplete, RealAbs, RealPow, Ring_and_Field, Complex_Numbers, Real}
163.28 - : theory
163.29 -
163.30 -theories with their respective theorems found by
163.31 -grep qed *.ML > ~/develop/isac/Isa02/Real2002-theorems.sml;
163.32 -theories listed in the the order as found in Real.thy above
163.33 -
163.34 -comments
163.35 - (**)"...theorem..." : first choice for one of the rule-sets
163.36 - "...theorem..."(*??*): to be investigated
163.37 - "...theorem... : just for documenting the contents
163.38 -*)
163.39 -
163.40 -Lubs.ML:qed -----------------------------------------------------------------
163.41 - "setleI"; "ALL y::?'a:?S::?'a set. y <= (?x::?'a) ==> ?S *<= ?x"
163.42 - "setleD"; "[| (?S::?'a set) *<= (?x::?'a); (?y::?'a) : ?S |] ==> ?y <= ?x"
163.43 - "setgeI"; "Ball (?S::?'a set) (op <= (?x::?'a)) ==> ?x <=* ?S"
163.44 - "setgeD"; "[| (?x::?'a) <=* (?S::?'a set); (?y::?'a) : ?S |] ==> ?x <= ?y"
163.45 - "leastPD1";
163.46 - "leastPD2";
163.47 - "leastPD3";
163.48 - "isLubD1";
163.49 - "isLubD1a";
163.50 - "isLub_isUb";
163.51 - "isLubD2";
163.52 - "isLubD3";
163.53 - "isLubI1";
163.54 - "isLubI2";
163.55 - "isUbD";
163.56 - "[| isUb (?R::?'a set) (?S::?'a set) (?x::?'a); (?y::?'a) : ?S |]
163.57 - ==> ?y <= ?x" "isUbD2";
163.58 - "isUbD2a";
163.59 - "isUbI";
163.60 - "isLub_le_isUb";
163.61 - "isLub_ubs";
163.62 -PNat.ML:qed ------------------------------------------------------------------
163.63 - "pnat_fun_mono"; "mono (%X::nat set. {Suc (0::nat)} Un Suc ` X)"
163.64 - "one_RepI"; "Suc (0::nat) : pnat"
163.65 - "pnat_Suc_RepI";
163.66 - "two_RepI";
163.67 - "PNat_induct";
163.68 - "[| (?i::nat) : pnat; (?P::nat => bool) (Suc (0::nat));
163.69 - !!j::nat. [| j : pnat; ?P j |] ==> ?P (Suc j) |] ==> ?P ?i"
163.70 - "pnat_induct";
163.71 - "[| (?P::pnat => bool) (1::pnat); !!n::pnat. ?P n ==> ?P (pSuc n) |]
163.72 - ==> ?P (?n::pnat)"
163.73 - "pnat_diff_induct";
163.74 - "pnatE";
163.75 - "inj_on_Abs_pnat";
163.76 - "inj_Rep_pnat";
163.77 - "zero_not_mem_pnat";
163.78 - "mem_pnat_gt_zero";
163.79 - "gt_0_mem_pnat";
163.80 - "mem_pnat_gt_0_iff";
163.81 - "Rep_pnat_gt_zero";
163.82 - "pnat_add_commute"; "(?x::pnat) + (?y::pnat) = ?y + ?x"
163.83 - "Collect_pnat_gt_0";
163.84 - "pSuc_not_one";
163.85 - "inj_pSuc";
163.86 - "pSuc_pSuc_eq";
163.87 - "n_not_pSuc_n";
163.88 - "not1_implies_pSuc";
163.89 - "pSuc_is_plus_one";
163.90 - "sum_Rep_pnat";
163.91 - "sum_Rep_pnat_sum";
163.92 - "pnat_add_assoc";
163.93 - "pnat_add_left_commute";
163.94 - "pnat_add_left_cancel";
163.95 - "pnat_add_right_cancel";
163.96 - "pnat_no_add_ident";
163.97 - "pnat_less_not_refl";
163.98 - "pnat_less_not_refl2";
163.99 - "Rep_pnat_not_less0";
163.100 - "Rep_pnat_not_less_one";
163.101 - "Rep_pnat_gt_implies_not0";
163.102 - "pnat_less_linear";
163.103 - "Rep_pnat_le_one";
163.104 - "lemma_less_ex_sum_Rep_pnat";
163.105 - "pnat_le_iff_Rep_pnat_le";
163.106 - "pnat_add_left_cancel_le";
163.107 - "pnat_add_left_cancel_less";
163.108 - "pnat_add_lessD1";
163.109 - "pnat_not_add_less1";
163.110 - "pnat_not_add_less2";
163.111 -PNat.ML:qed_spec_mp
163.112 - "pnat_add_leD1";
163.113 - "pnat_add_leD2";
163.114 -PNat.ML:qed
163.115 - "pnat_less_add_eq_less";
163.116 - "pnat_less_iff";
163.117 - "pnat_linear_Ex_eq";
163.118 - "pnat_eq_lessI";
163.119 - "Rep_pnat_mult_1";
163.120 - "Rep_pnat_mult_1_right";
163.121 - "mult_Rep_pnat";
163.122 - "mult_Rep_pnat_mult";
163.123 - "pnat_mult_commute"; "(?m::pnat) * (?n::pnat) = ?n * ?m"
163.124 - "pnat_add_mult_distrib";
163.125 - "pnat_add_mult_distrib2";
163.126 - "pnat_mult_assoc";
163.127 - "pnat_mult_left_commute";
163.128 - "pnat_mult_1";
163.129 - "pnat_mult_1_left";
163.130 - "pnat_mult_less_mono2";
163.131 - "pnat_mult_less_mono1";
163.132 - "pnat_mult_less_cancel2";
163.133 - "pnat_mult_less_cancel1";
163.134 - "pnat_mult_cancel2";
163.135 - "pnat_mult_cancel1";
163.136 - "pnat_same_multI2";
163.137 - "eq_Abs_pnat";
163.138 - "pnat_one_iff";
163.139 - "pnat_two_eq";
163.140 - "inj_pnat_of_nat";
163.141 - "nat_add_one_less";
163.142 - "nat_add_one_less1";
163.143 - "pnat_of_nat_add";
163.144 - "pnat_of_nat_less_iff";
163.145 - "pnat_of_nat_mult";
163.146 -PRat.ML:qed ------------------------------------------------------------------
163.147 - "prat_trans_lemma";
163.148 - "[| (?x1.0::pnat) * (?y2.0::pnat) = (?x2.0::pnat) * (?y1.0::pnat);
163.149 - ?x2.0 * (?y3.0::pnat) = (?x3.0::pnat) * ?y2.0 |]
163.150 - ==> ?x1.0 * ?y3.0 = ?x3.0 * ?y1.0"
163.151 - "ratrel_iff";
163.152 - "ratrelI";
163.153 - "ratrelE_lemma";
163.154 - "ratrelE";
163.155 - "ratrel_refl";
163.156 - "equiv_ratrel";
163.157 - "ratrel_in_prat";
163.158 - "inj_on_Abs_prat";
163.159 - "inj_Rep_prat";
163.160 - "inj_prat_of_pnat";
163.161 - "eq_Abs_prat";
163.162 - "qinv_congruent";
163.163 - "qinv";
163.164 - "qinv_qinv";
163.165 - "inj_qinv";
163.166 - "qinv_1";
163.167 - "prat_add_congruent2_lemma";
163.168 - "prat_add_congruent2";
163.169 - "prat_add";
163.170 - "prat_add_commute";
163.171 - "prat_add_assoc";
163.172 - "prat_add_left_commute";
163.173 - "pnat_mult_congruent2";
163.174 - "prat_mult";
163.175 - "prat_mult_commute";
163.176 - "prat_mult_assoc";
163.177 - "prat_mult_left_commute";
163.178 - "prat_mult_1";
163.179 - "prat_mult_1_right";
163.180 - "prat_of_pnat_add";
163.181 - "prat_of_pnat_mult";
163.182 - "prat_mult_qinv";
163.183 - "prat_mult_qinv_right";
163.184 - "prat_qinv_ex";
163.185 - "prat_qinv_ex1";
163.186 - "prat_qinv_left_ex1";
163.187 - "prat_mult_inv_qinv";
163.188 - "prat_as_inverse_ex";
163.189 - "qinv_mult_eq";
163.190 - "prat_add_mult_distrib";
163.191 - "prat_add_mult_distrib2";
163.192 - "prat_less_iff";
163.193 - "prat_lessI";
163.194 - "prat_lessE_lemma";
163.195 - "prat_lessE";
163.196 - "prat_less_trans";
163.197 - "prat_less_not_refl";
163.198 - "prat_less_not_sym";
163.199 - "lemma_prat_dense";
163.200 - "prat_lemma_dense";
163.201 - "prat_dense";
163.202 - "prat_add_less2_mono1";
163.203 - "prat_add_less2_mono2";
163.204 - "prat_mult_less2_mono1";
163.205 - "prat_mult_left_less2_mono1";
163.206 - "lemma_prat_add_mult_mono";
163.207 - "qless_Ex";
163.208 - "lemma_prat_less_linear";
163.209 - "prat_linear";
163.210 - "prat_linear_less2";
163.211 - "lemma1_qinv_prat_less";
163.212 - "lemma2_qinv_prat_less";
163.213 - "qinv_prat_less";
163.214 - "prat_qinv_gt_1";
163.215 - "prat_qinv_is_gt_1";
163.216 - "prat_less_1_2";
163.217 - "prat_less_qinv_2_1";
163.218 - "prat_mult_qinv_less_1";
163.219 - "prat_self_less_add_self";
163.220 - "prat_self_less_add_right";
163.221 - "prat_self_less_add_left";
163.222 - "prat_self_less_mult_right";
163.223 - "prat_leI";
163.224 - "prat_leD";
163.225 - "prat_less_le_iff";
163.226 - "not_prat_leE";
163.227 - "prat_less_imp_le";
163.228 - "prat_le_imp_less_or_eq";
163.229 - "prat_less_or_eq_imp_le";
163.230 - "prat_le_eq_less_or_eq";
163.231 - "prat_le_refl";
163.232 - "prat_le_less_trans";
163.233 - "prat_le_trans";
163.234 - "not_less_not_eq_prat_less";
163.235 - "prat_add_less_mono";
163.236 - "prat_mult_less_mono";
163.237 - "prat_mult_left_le2_mono1";
163.238 - "prat_mult_le2_mono1";
163.239 - "qinv_prat_le";
163.240 - "prat_add_left_le2_mono1";
163.241 - "prat_add_le2_mono1";
163.242 - "prat_add_le_mono";
163.243 - "prat_add_right_less_cancel";
163.244 - "prat_add_left_less_cancel";
163.245 - "Abs_prat_mult_qinv";
163.246 - "lemma_Abs_prat_le1";
163.247 - "lemma_Abs_prat_le2";
163.248 - "lemma_Abs_prat_le3";
163.249 - "pre_lemma_gleason9_34";
163.250 - "pre_lemma_gleason9_34b";
163.251 - "prat_of_pnat_less_iff";
163.252 - "lemma_prat_less_1_memEx";
163.253 - "lemma_prat_less_1_set_non_empty";
163.254 - "empty_set_psubset_lemma_prat_less_1_set";
163.255 - "lemma_prat_less_1_not_memEx";
163.256 - "lemma_prat_less_1_set_not_rat_set";
163.257 - "lemma_prat_less_1_set_psubset_rat_set";
163.258 - "preal_1";
163.259 - "{x::prat. x < prat_of_pnat (Abs_pnat (Suc (0::nat)))}
163.260 - : {A::prat set.
163.261 - {} < A &
163.262 - A < UNIV &
163.263 - (ALL y::prat:A. (ALL z::prat. z < y --> z : A) & Bex A (op < y))}"
163.264 -PReal.ML:qed -----------------------------------------------------------------
163.265 - "inj_on_Abs_preal"; "inj_on Abs_preal preal"
163.266 - "inj_Rep_preal";
163.267 - "empty_not_mem_preal";
163.268 - "one_set_mem_preal";
163.269 - "preal_psubset_empty";
163.270 - "Rep_preal_psubset_empty";
163.271 - "mem_Rep_preal_Ex";
163.272 - "prealI1";
163.273 - "[| {} < (?A::prat set); ?A < UNIV;
163.274 - ALL y::prat:?A. (ALL z::prat. z < y --> z : ?A) & Bex ?A (op < y) |]
163.275 - ==> ?A : preal"
163.276 - "prealI2";
163.277 - "prealE_lemma";
163.278 - "prealE_lemma1";
163.279 - "prealE_lemma2";
163.280 - "prealE_lemma3";
163.281 - "prealE_lemma3a";
163.282 - "prealE_lemma3b";
163.283 - "prealE_lemma4";
163.284 - "prealE_lemma4a";
163.285 - "not_mem_Rep_preal_Ex";
163.286 - "lemma_prat_less_set_mem_preal";
163.287 - "lemma_prat_set_eq";
163.288 - "inj_preal_of_prat";
163.289 - "not_in_preal_ub";
163.290 - "preal_less_not_refl";
163.291 - "preal_not_refl2";
163.292 - "preal_less_trans";
163.293 - "preal_less_not_sym";
163.294 - "preal_linear";
163.295 - "(?r1.0::preal) < (?r2.0::preal) | ?r1.0 = ?r2.0 | ?r2.0 < ?r1.0"
163.296 - "preal_linear_less2";
163.297 - "preal_add_commute"; "(?x::preal) + (?y::preal) = ?y + ?x"
163.298 - "preal_add_set_not_empty";
163.299 - "preal_not_mem_add_set_Ex";
163.300 - "preal_add_set_not_prat_set";
163.301 - "preal_add_set_lemma3";
163.302 - "preal_add_set_lemma4";
163.303 - "preal_mem_add_set";
163.304 - "preal_add_assoc";
163.305 - "preal_add_left_commute";
163.306 - "preal_mult_commute"; "(?x::preal) * (?y::preal) = ?y * ?x"
163.307 - "preal_mult_set_not_empty";
163.308 - "preal_not_mem_mult_set_Ex";
163.309 - "preal_mult_set_not_prat_set";
163.310 - "preal_mult_set_lemma3";
163.311 - "preal_mult_set_lemma4";
163.312 - "preal_mem_mult_set";
163.313 - "preal_mult_assoc";
163.314 - "preal_mult_left_commute";
163.315 - "preal_mult_1";
163.316 - "preal_mult_1_right";
163.317 - "preal_add_assoc_cong";
163.318 - "preal_add_assoc_swap";
163.319 - "mem_Rep_preal_addD";
163.320 - "mem_Rep_preal_addI";
163.321 - "mem_Rep_preal_add_iff";
163.322 - "mem_Rep_preal_multD";
163.323 - "mem_Rep_preal_multI";
163.324 - "mem_Rep_preal_mult_iff";
163.325 - "lemma_add_mult_mem_Rep_preal";
163.326 - "lemma_add_mult_mem_Rep_preal1";
163.327 - "lemma_preal_add_mult_distrib";
163.328 - "lemma_preal_add_mult_distrib2";
163.329 - "preal_add_mult_distrib2";
163.330 - "preal_add_mult_distrib";
163.331 - "qinv_not_mem_Rep_preal_Ex";
163.332 - "lemma_preal_mem_inv_set_ex";
163.333 - "preal_inv_set_not_empty";
163.334 - "qinv_mem_Rep_preal_Ex";
163.335 - "preal_not_mem_inv_set_Ex";
163.336 - "preal_inv_set_not_prat_set";
163.337 - "preal_inv_set_lemma3";
163.338 - "preal_inv_set_lemma4";
163.339 - "preal_mem_inv_set";
163.340 - "preal_mem_mult_invD";
163.341 - "lemma1_gleason9_34";
163.342 - "lemma1b_gleason9_34";
163.343 - "lemma_gleason9_34a";
163.344 - "lemma_gleason9_34";
163.345 - "lemma1_gleason9_36";
163.346 - "lemma2_gleason9_36";
163.347 - "lemma_gleason9_36";
163.348 - "lemma_gleason9_36a";
163.349 - "preal_mem_mult_invI";
163.350 - "preal_mult_inv";
163.351 - "preal_mult_inv_right";
163.352 - "eq_Abs_preal";
163.353 - "Rep_preal_self_subset";
163.354 - "Rep_preal_sum_not_subset";
163.355 - "Rep_preal_sum_not_eq";
163.356 - "preal_self_less_add_left";
163.357 - "preal_self_less_add_right";
163.358 - "preal_leD";
163.359 - "not_preal_leE";
163.360 - "preal_leI";
163.361 - "preal_less_le_iff";
163.362 - "preal_less_imp_le";
163.363 - "preal_le_imp_less_or_eq";
163.364 - "preal_less_or_eq_imp_le";
163.365 - "preal_le_refl";
163.366 - "preal_le_trans";
163.367 - "preal_le_anti_sym";
163.368 - "preal_neq_iff";
163.369 - "preal_less_le";
163.370 - "lemma_psubset_mem";
163.371 - "lemma_psubset_not_refl";
163.372 - "psubset_trans";
163.373 - "subset_psubset_trans";
163.374 - "subset_psubset_trans2";
163.375 - "psubsetD";
163.376 - "lemma_ex_mem_less_left_add1";
163.377 - "preal_less_set_not_empty";
163.378 - "lemma_ex_not_mem_less_left_add1";
163.379 - "preal_less_set_not_prat_set";
163.380 - "preal_less_set_lemma3";
163.381 - "preal_less_set_lemma4";
163.382 - "preal_mem_less_set";
163.383 - "preal_less_add_left_subsetI";
163.384 - "lemma_sum_mem_Rep_preal_ex";
163.385 - "preal_less_add_left_subsetI2";
163.386 - "preal_less_add_left";
163.387 - "preal_less_add_left_Ex";
163.388 - "preal_add_less2_mono1";
163.389 - "preal_add_less2_mono2";
163.390 - "preal_mult_less_mono1";
163.391 - "preal_mult_left_less_mono1";
163.392 - "preal_mult_left_le_mono1";
163.393 - "preal_mult_le_mono1";
163.394 - "preal_add_left_le_mono1";
163.395 - "preal_add_le_mono1";
163.396 - "preal_add_right_less_cancel";
163.397 - "preal_add_left_less_cancel";
163.398 - "preal_add_less_iff1";
163.399 - "preal_add_less_iff2";
163.400 - "preal_add_less_mono";
163.401 - "preal_mult_less_mono";
163.402 - "preal_add_right_cancel";
163.403 - "preal_add_left_cancel";
163.404 - "preal_add_left_cancel_iff";
163.405 - "preal_add_right_cancel_iff";
163.406 - "preal_sup_mem_Ex";
163.407 - "preal_sup_set_not_empty";
163.408 - "preal_sup_not_mem_Ex";
163.409 - "preal_sup_not_mem_Ex1";
163.410 - "preal_sup_set_not_prat_set";
163.411 - "preal_sup_set_not_prat_set1";
163.412 - "preal_sup_set_lemma3";
163.413 - "preal_sup_set_lemma3_1";
163.414 - "preal_sup_set_lemma4";
163.415 - "preal_sup_set_lemma4_1";
163.416 - "preal_sup";
163.417 - "preal_sup1";
163.418 - "preal_psup_leI";
163.419 - "preal_psup_leI2";
163.420 - "preal_psup_leI2b";
163.421 - "preal_psup_leI2a";
163.422 - "psup_le_ub";
163.423 - "psup_le_ub1";
163.424 - "preal_complete";
163.425 - "lemma_preal_rat_less";
163.426 - "lemma_preal_rat_less2";
163.427 - "preal_of_prat_add";
163.428 - "lemma_preal_rat_less3";
163.429 - "lemma_preal_rat_less4";
163.430 - "preal_of_prat_mult";
163.431 - "preal_of_prat_less_iff"; "(preal_of_prat ?p < preal_of_prat ?q) = (?p < ?q)"
163.432 -RealDef.ML:qed ---------------------------------------------------------------
163.433 - "preal_trans_lemma";
163.434 - "realrel_iff";
163.435 - "realrelI";
163.436 - "?x1.0 + ?y2.0 = ?x2.0 + ?y1.0 ==> ((?x1.0, ?y1.0), ?x2.0, ?y2.0) : realrel"
163.437 - "realrelE_lemma";
163.438 - "realrelE";
163.439 - "realrel_refl";
163.440 - "equiv_realrel";
163.441 - "realrel_in_real";
163.442 - "inj_on_Abs_REAL";
163.443 - "inj_Rep_REAL";
163.444 - "inj_real_of_preal";
163.445 - "eq_Abs_REAL";
163.446 - "real_minus_congruent";
163.447 - "real_minus";
163.448 - "- Abs_REAL (realrel `` {(?x, ?y)}) = Abs_REAL (realrel `` {(?y, ?x)})"
163.449 - "real_minus_minus"; (**)"- (- (?z::real)) = ?z"
163.450 - "inj_real_minus"; "inj uminus"
163.451 - "real_minus_zero"; (**)"- 0 = 0"
163.452 - "real_minus_zero_iff"; (**)"(- ?x = 0) = (?x = 0)"
163.453 - "real_add_congruent2";
163.454 - "congruent2 realrel
163.455 - (%p1 p2. (%(x1, y1). (%(x2, y2). realrel `` {(x1 + x2, y1 + y2)}) p2) p1)"
163.456 - "real_add";
163.457 - "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) +
163.458 - Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) =
163.459 - Abs_REAL (realrel `` {(?x1.0 + ?x2.0, ?y1.0 + ?y2.0)})"
163.460 - "real_add_commute"; (**)"(?z::real) + (?w::real) = ?w + ?z"
163.461 - "real_add_assoc"; (**)
163.462 - "real_add_left_commute"; (**)
163.463 - "real_add_zero_left"; (**)"0 + ?z = ?z"
163.464 - "real_add_zero_right"; (**)
163.465 - "real_add_minus"; (**)"?z + - ?z = 0"
163.466 - "real_add_minus_left"; (**)
163.467 - "real_add_minus_cancel"; (**)"?z + (- ?z + ?w) = ?w"
163.468 - "real_minus_add_cancel"; (**)"- ?z + (?z + ?w) = ?w"
163.469 - "real_minus_ex"; "EX y. ?x + y = 0"
163.470 - "real_minus_ex1";
163.471 - "real_minus_left_ex1"; "EX! y. y + ?x = 0"
163.472 - "real_add_minus_eq_minus";"?x + ?y = 0 ==> ?x = - ?y"
163.473 - "real_as_add_inverse_ex"; "EX y. ?x = - y"
163.474 - "real_minus_add_distrib"; (**)"- (?x + ?y) = - ?x + - ?y"
163.475 - "real_add_left_cancel"; "(?x + ?y = ?x + ?z) = (?y = ?z)"
163.476 - "real_add_right_cancel"; "(?y + ?x = ?z + ?x) = (?y = ?z)"
163.477 - "real_diff_0"; (**)"0 - ?x = - ?x"
163.478 - "real_diff_0_right"; (**)"?x - 0 = ?x"
163.479 - "real_diff_self"; (**)"?x - ?x = 0"
163.480 - "real_mult_congruent2_lemma";
163.481 - "real_mult_congruent2";
163.482 - "congruent2 realrel
163.483 - (%p1 p2.
163.484 - (%(x1, y1).
163.485 - (%(x2, y2). realrel `` {(x1 * x2 + y1 * y2, x1 * y2 + x2 * y1)})
163.486 - p2) p1)"
163.487 - "real_mult";
163.488 - "Abs_REAL (realrel `` {(?x1.0, ?y1.0)}) *
163.489 - Abs_REAL (realrel `` {(?x2.0, ?y2.0)}) =
163.490 - Abs_REAL
163.491 - (realrel ``
163.492 - {(?x1.0 * ?x2.0 + ?y1.0 * ?y2.0, ?x1.0 * ?y2.0 + ?x2.0 * ?y1.0)})"
163.493 - "real_mult_commute"; (**)"?z * ?w = ?w * ?z"
163.494 - "real_mult_assoc"; (**)
163.495 - "real_mult_left_commute";
163.496 - (**)"?z1.0 * (?z2.0 * ?z3.0) = ?z2.0 * (?z1.0 * ?z3.0)"
163.497 - "real_mult_1"; (**)"1 * ?z = ?z"
163.498 - "real_mult_1_right"; (**)"?z * 1 = ?z"
163.499 - "real_mult_0"; (**)
163.500 - "real_mult_0_right"; (**)"?z * 0 = 0"
163.501 - "real_mult_minus_eq1"; (**)"- ?x * ?y = - (?x * ?y)"
163.502 - "real_mult_minus_eq2"; (**)"?x * - ?y = - (?x * ?y)"
163.503 - "real_mult_minus_1"; (**)"- 1 * ?z = - ?z"
163.504 - "real_mult_minus_1_right";(**)"?z * - 1 = - ?z"
163.505 - "real_minus_mult_cancel"; (**)"- ?x * - ?y = ?x * ?y"
163.506 - "real_minus_mult_commute";(**)"- ?x * ?y = ?x * - ?y"
163.507 - "real_add_assoc_cong";
163.508 - "?z + ?v = ?z' + ?v' ==> ?z + (?v + ?w) = ?z' + (?v' + ?w)"
163.509 - "real_add_assoc_swap"; (**)"?z + (?v + ?w) = ?v + (?z + ?w)"
163.510 - "real_add_mult_distrib"; (**)"(?z1.0 + ?z2.0) * ?w = ?z1.0 * ?w + ?z2.0 * ?w"
163.511 - "real_add_mult_distrib2"; (**)"?w * (?z1.0 + ?z2.0) = ?w * ?z1.0 + ?w * ?z2.0"
163.512 - "real_diff_mult_distrib"; (**)"(?z1.0 - ?z2.0) * ?w = ?z1.0 * ?w - ?z2.0 * ?w"
163.513 - "real_diff_mult_distrib2";(**)"?w * (?z1.0 - ?z2.0) = ?w * ?z1.0 - ?w * ?z2.0"
163.514 - "real_zero_not_eq_one";
163.515 - "real_zero_iff"; "0 = Abs_REAL (realrel `` {(?x, ?x)})"
163.516 - "real_mult_inv_right_ex"; "?x ~= 0 ==> EX y. ?x * y = 1"
163.517 - "real_mult_inv_left_ex"; "?x ~= 0 ==> inverse ?x * ?x = 1"
163.518 - "real_mult_inv_left";
163.519 - "real_mult_inv_right"; "?x ~= 0 ==> ?x * inverse ?x = 1"
163.520 - "INVERSE_ZERO"; "inverse 0 = 0"
163.521 - "DIVISION_BY_ZERO"; (*NOT for adding to default simpset*)"?a / 0 = 0"
163.522 - "real_mult_left_cancel"; (**)"?c ~= 0 ==> (?c * ?a = ?c * ?b) = (?a = ?b)"
163.523 - "real_mult_right_cancel"; (**)"?c ~= 0 ==> (?a * ?c = ?b * ?c) = (?a = ?b)"
163.524 - "real_mult_left_cancel_ccontr"; "?c * ?a ~= ?c * ?b ==> ?a ~= ?b"
163.525 - "real_mult_right_cancel_ccontr"; "?a * ?c ~= ?b * ?c ==> ?a ~= ?b"
163.526 - "real_inverse_not_zero"; "?x ~= 0 ==> inverse ?x ~= 0"
163.527 - "real_mult_not_zero"; "[| ?x ~= 0; ?y ~= 0 |] ==> ?x * ?y ~= 0"
163.528 - "real_inverse_inverse"; "inverse (inverse ?x) = ?x"
163.529 - "real_inverse_1"; "inverse 1 = 1"
163.530 - "real_minus_inverse"; "inverse (- ?x) = - inverse ?x"
163.531 - "real_inverse_distrib"; "inverse (?x * ?y) = inverse ?x * inverse ?y"
163.532 - "real_times_divide1_eq"; (**)"?x * (?y / ?z) = ?x * ?y / ?z"
163.533 - "real_times_divide2_eq"; (**)"?y / ?z * ?x = ?y * ?x / ?z"
163.534 - "real_divide_divide1_eq"; (**)"?x / (?y / ?z) = ?x * ?z / ?y"
163.535 - "real_divide_divide2_eq"; (**)"?x / ?y / ?z = ?x / (?y * ?z)"
163.536 - "real_minus_divide_eq"; (**)"- ?x / ?y = - (?x / ?y)"
163.537 - "real_divide_minus_eq"; (**)"?x / - ?y = - (?x / ?y)"
163.538 - "real_add_divide_distrib"; (**)"(?x + ?y) / ?z = ?x / ?z + ?y / ?z"
163.539 - "preal_lemma_eq_rev_sum";
163.540 - "[| ?x = ?y; ?x1.0 = ?y1.0 |] ==> ?x + ?y1.0 = ?x1.0 + ?y"
163.541 - "preal_add_left_commute_cancel";
163.542 - "?x + (?b + ?y) = ?x1.0 + (?b + ?y1.0) ==> ?x + ?y = ?x1.0 + ?y1.0"
163.543 - "preal_lemma_for_not_refl";
163.544 - "real_less_not_refl"; "~ ?R < ?R"
163.545 - "real_not_refl2";
163.546 - "preal_lemma_trans";
163.547 - "real_less_trans";
163.548 - "real_less_not_sym";
163.549 - "real_of_preal_add";
163.550 - "real_of_preal (?z1.0 + ?z2.0) = real_of_preal ?z1.0 + real_of_preal ?z2.0"
163.551 - "real_of_preal_mult";
163.552 - "real_of_preal_ExI";
163.553 - "real_of_preal_ExD";
163.554 - "real_of_preal_iff";
163.555 - "real_of_preal_trichotomy";
163.556 - "real_of_preal_trichotomyE";
163.557 - "real_of_preal_lessD";
163.558 - "real_of_preal_lessI";
163.559 - "?m1.0 < ?m2.0 ==> real_of_preal ?m1.0 < real_of_preal ?m2.0"
163.560 - "real_of_preal_less_iff1";
163.561 - "real_of_preal_minus_less_self";
163.562 - "real_of_preal_minus_less_zero";
163.563 - "real_of_preal_not_minus_gt_zero";
163.564 - "real_of_preal_zero_less";
163.565 - "real_of_preal_not_less_zero";
163.566 - "real_minus_minus_zero_less";
163.567 - "real_of_preal_sum_zero_less";
163.568 - "real_of_preal_minus_less_all";
163.569 - "real_of_preal_not_minus_gt_all";
163.570 - "real_of_preal_minus_less_rev1";
163.571 - "real_of_preal_minus_less_rev2";
163.572 - "real_of_preal_minus_less_rev_iff";
163.573 - "real_linear"; "?R1.0 < ?R2.0 | ?R1.0 = ?R2.0 | ?R2.0 < ?R1.0"
163.574 - "real_neq_iff";
163.575 - "real_linear_less2";
163.576 - "[| ?R1.0 < ?R2.0 ==> ?P; ?R1.0 = ?R2.0 ==> ?P; ?R2.0 < ?R1.0 ==> ?P |]
163.577 - ==> ?P"
163.578 - "real_leI";
163.579 - "real_leD"; "~ ?w < ?z ==> ?z <= ?w"
163.580 - "real_less_le_iff";
163.581 - "not_real_leE";
163.582 - "real_le_imp_less_or_eq";
163.583 - "real_less_or_eq_imp_le";
163.584 - "real_le_less";
163.585 - "real_le_refl"; "?w <= ?w"
163.586 - "real_le_linear";
163.587 - "real_le_trans"; "[| ?i <= ?j; ?j <= ?k |] ==> ?i <= ?k"
163.588 - "real_le_anti_sym"; "[| ?z <= ?w; ?w <= ?z |] ==> ?z = ?w"
163.589 - "not_less_not_eq_real_less";
163.590 - "real_less_le"; "(?w < ?z) = (?w <= ?z & ?w ~= ?z)"
163.591 - "real_minus_zero_less_iff";
163.592 - "real_minus_zero_less_iff2";
163.593 - "real_less_add_positive_left_Ex";
163.594 - "real_less_sum_gt_zero"; "?W < ?S ==> 0 < ?S + - ?W"
163.595 - "real_lemma_change_eq_subj";
163.596 - "real_sum_gt_zero_less"; "0 < ?S + - ?W ==> ?W < ?S"
163.597 - "real_less_sum_gt_0_iff"; "(0 < ?S + - ?W) = (?W < ?S)"
163.598 - "real_less_eq_diff"; "(?x < ?y) = (?x - ?y < 0)"
163.599 - "real_add_diff_eq"; (**)"?x + (?y - ?z) = ?x + ?y - ?z"
163.600 - "real_diff_add_eq"; (**)"?x - ?y + ?z = ?x + ?z - ?y"
163.601 - "real_diff_diff_eq"; (**)"?x - ?y - ?z = ?x - (?y + ?z)"
163.602 - "real_diff_diff_eq2"; (**)"?x - (?y - ?z) = ?x + ?z - ?y"
163.603 - "real_diff_less_eq"; "(?x - ?y < ?z) = (?x < ?z + ?y)"
163.604 - "real_less_diff_eq";
163.605 - "real_diff_le_eq"; "(?x - ?y <= ?z) = (?x <= ?z + ?y)"
163.606 - "real_le_diff_eq";
163.607 - "real_diff_eq_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)"
163.608 - "real_eq_diff_eq"; (**)"(?x - ?y = ?z) = (?x = ?z + ?y)"
163.609 - "real_less_eqI";
163.610 - "real_le_eqI";
163.611 - "real_eq_eqI"; "?x - ?y = ?x' - ?y' ==> (?x = ?y) = (?x' = ?y')"
163.612 -RealOrd.ML:qed ---------------------------------------------------------------
163.613 - "real_add_cancel_21"; "(?x + (?y + ?z) = ?y + ?u) = (?x + ?z = ?u)"
163.614 - "real_add_cancel_end"; "(?x + (?y + ?z) = ?y) = (?x = - ?z)"
163.615 - "real_minus_diff_eq"; (*??*)"- (?x - ?y) = ?y - ?x"
163.616 - "real_gt_zero_preal_Ex";
163.617 - "real_gt_preal_preal_Ex";
163.618 - "real_ge_preal_preal_Ex";
163.619 - "real_less_all_preal"; "?y <= 0 ==> ALL x. ?y < real_of_preal x"
163.620 - "real_less_all_real2";
163.621 - "real_lemma_add_positive_imp_less";
163.622 - "real_ex_add_positive_left_less";"EX T. 0 < T & ?R + T = ?S ==> ?R < ?S"
163.623 - "real_less_iff_add";
163.624 - "real_of_preal_le_iff";
163.625 - "real_mult_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x * ?y"
163.626 - "neg_real_mult_order";
163.627 - "real_mult_less_0"; "[| 0 < ?x; ?y < 0 |] ==> ?x * ?y < 0"
163.628 - "real_zero_less_one"; "0 < 1"
163.629 - "real_add_right_cancel_less"; "(?v + ?z < ?w + ?z) = (?v < ?w)"
163.630 - "real_add_left_cancel_less";
163.631 - "real_add_right_cancel_le";
163.632 - "real_add_left_cancel_le";
163.633 - "real_add_less_le_mono"; "[| ?w' < ?w; ?z' <= ?z |] ==> ?w' + ?z' < ?w + ?z"
163.634 - "real_add_le_less_mono"; "[| ?w' <= ?w; ?z' < ?z |] ==> ?w' + ?z' < ?w + ?z"
163.635 - "real_add_less_mono2";
163.636 - "real_less_add_right_cancel";
163.637 - "real_less_add_left_cancel"; "?C + ?A < ?C + ?B ==> ?A < ?B"
163.638 - "real_le_add_right_cancel";
163.639 - "real_le_add_left_cancel"; "?C + ?A <= ?C + ?B ==> ?A <= ?B"
163.640 - "real_add_order"; "[| 0 < ?x; 0 < ?y |] ==> 0 < ?x + ?y"
163.641 - "real_le_add_order";
163.642 - "real_add_less_mono";
163.643 - "real_add_left_le_mono1";
163.644 - "real_add_le_mono";
163.645 - "real_less_Ex";
163.646 - "real_add_minus_positive_less_self"; "0 < ?r ==> ?u + - ?r < ?u"
163.647 - "real_le_minus_iff"; "(- ?s <= - ?r) = (?r <= ?s)"
163.648 - "real_le_square";
163.649 - "real_of_posnat_one";
163.650 - "real_of_posnat_two";
163.651 - "real_of_posnat_add"; "real_of_posnat ?n1.0 + real_of_posnat ?n2.0 =
163.652 - real_of_posnat (?n1.0 + ?n2.0) + 1"
163.653 - "real_of_posnat_add_one";
163.654 - "real_of_posnat_Suc";
163.655 - "inj_real_of_posnat";
163.656 - "real_of_nat_zero";
163.657 - "real_of_nat_one"; "real (Suc 0) = 1"
163.658 - "real_of_nat_add";
163.659 - "real_of_nat_Suc";
163.660 - "real_of_nat_less_iff";
163.661 - "real_of_nat_le_iff";
163.662 - "inj_real_of_nat";
163.663 - "real_of_nat_ge_zero";
163.664 - "real_of_nat_mult";
163.665 - "real_of_nat_inject";
163.666 -RealOrd.ML:qed_spec_mp
163.667 - "real_of_nat_diff";
163.668 -RealOrd.ML:qed
163.669 - "real_of_nat_zero_iff";
163.670 - "real_of_nat_neg_int";
163.671 - "real_inverse_gt_0";
163.672 - "real_inverse_less_0";
163.673 - "real_mult_less_mono1";
163.674 - "real_mult_less_mono2";
163.675 - "real_mult_less_cancel1";
163.676 - "(?k * ?m < ?k * ?n) = (0 < ?k & ?m < ?n | ?k < 0 & ?n < ?m)"
163.677 - "real_mult_less_cancel2";
163.678 - "real_mult_less_iff1";
163.679 - "real_mult_less_iff2";
163.680 - "real_mult_le_cancel_iff1";
163.681 - "real_mult_le_cancel_iff2";
163.682 - "real_mult_le_less_mono1";
163.683 - "real_mult_less_mono";
163.684 - "real_mult_less_mono'";
163.685 - "real_gt_zero"; "1 <= ?x ==> 0 < ?x"
163.686 - "real_mult_self_le"; "[| 1 < ?r; 1 <= ?x |] ==> ?x <= ?r * ?x"
163.687 - "real_mult_self_le2";
163.688 - "real_inverse_less_swap";
163.689 - "real_mult_is_0";
163.690 - "real_inverse_add";
163.691 - "real_minus_zero_le_iff";
163.692 - "real_minus_zero_le_iff2";
163.693 - "real_sum_squares_cancel"; "?x * ?x + ?y * ?y = 0 ==> ?x = 0"
163.694 - "real_sum_squares_cancel2"; "?x * ?x + ?y * ?y = 0 ==> ?y = 0"
163.695 - "real_0_less_mult_iff";
163.696 - "real_0_le_mult_iff";
163.697 - "real_mult_less_0_iff"; "(?x * ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)"
163.698 - "real_mult_le_0_iff";
163.699 -RealInt.ML:qed ---------------------------------------------------------------
163.700 - "real_of_int_congruent";
163.701 - "real_of_int"; "real (Abs_Integ (intrel `` {(?i, ?j)})) =
163.702 - Abs_REAL
163.703 - (realrel ``
163.704 - {(preal_of_prat (prat_of_pnat (pnat_of_nat ?i)),
163.705 - preal_of_prat (prat_of_pnat (pnat_of_nat ?j)))})"
163.706 - "inj_real_of_int";
163.707 - "real_of_int_zero";
163.708 - "real_of_one";
163.709 - "real_of_int_add"; "real ?x + real ?y = real (?x + ?y)"
163.710 - "real_of_int_minus";
163.711 - "real_of_int_diff";
163.712 - "real_of_int_mult"; "real ?x * real ?y = real (?x * ?y)"
163.713 - "real_of_int_Suc";
163.714 - "real_of_int_real_of_nat";
163.715 - "real_of_nat_real_of_int";
163.716 - "real_of_int_zero_cancel";
163.717 - "real_of_int_less_cancel";
163.718 - "real_of_int_inject";
163.719 - "real_of_int_less_mono";
163.720 - "real_of_int_less_iff";
163.721 - "real_of_int_le_iff";
163.722 -RealBin.ML:qed ---------------------------------------------------------------
163.723 - "real_number_of"; "real (number_of ?w) = number_of ?w"
163.724 - "real_numeral_0_eq_0";
163.725 - "real_numeral_1_eq_1";
163.726 - "add_real_number_of";
163.727 - "minus_real_number_of";
163.728 - "diff_real_number_of";
163.729 - "mult_real_number_of";
163.730 - "real_mult_2"; (**)"2 * ?z = ?z + ?z"
163.731 - "real_mult_2_right"; (**)"?z * 2 = ?z + ?z"
163.732 - "eq_real_number_of";
163.733 - "less_real_number_of";
163.734 - "le_real_number_of_eq_not_less";
163.735 - "real_minus_1_eq_m1"; "- 1 = -1"(*uminus.. = "-.."*)
163.736 - "real_mult_minus1"; (**)"-1 * ?z = - ?z"
163.737 - "real_mult_minus1_right"; (**)"?z * -1 = - ?z"
163.738 - "zero_less_real_of_nat_iff";"(0 < real ?n) = (0 < ?n)"
163.739 - "zero_le_real_of_nat_iff";
163.740 - "real_add_number_of_left";
163.741 - "real_mult_number_of_left";
163.742 - "number_of ?v * (number_of ?w * ?z) = number_of (bin_mult ?v ?w) * ?z"
163.743 - "real_add_number_of_diff1";
163.744 - "real_add_number_of_diff2";"number_of ?v + (?c - number_of ?w) =
163.745 - number_of (bin_add ?v (bin_minus ?w)) + ?c"
163.746 - "real_of_nat_number_of";
163.747 - "real (number_of ?v) = (if neg (number_of ?v) then 0 else number_of ?v)"
163.748 - "real_less_iff_diff_less_0"; "(?x < ?y) = (?x - ?y < 0)"
163.749 - "real_eq_iff_diff_eq_0";
163.750 - "real_le_iff_diff_le_0";
163.751 - "left_real_add_mult_distrib";
163.752 - (**)"?i * ?u + (?j * ?u + ?k) = (?i + ?j) * ?u + ?k"
163.753 - "real_eq_add_iff1";
163.754 - "(?i * ?u + ?m = ?j * ?u + ?n) = ((?i - ?j) * ?u + ?m = ?n)"
163.755 - "real_eq_add_iff2";
163.756 - "real_less_add_iff1";
163.757 - "real_less_add_iff2";
163.758 - "real_le_add_iff1";
163.759 - "real_le_add_iff2";
163.760 - "real_mult_le_mono1";
163.761 - "real_mult_le_mono2";
163.762 - "real_mult_le_mono";
163.763 - "[| ?i <= ?j; ?k <= ?l; 0 <= ?j; 0 <= ?k |] ==> ?i * ?k <= ?j * ?l"
163.764 -RealArith0.ML:qed ------------------------------------------------------------
163.765 - "real_diff_minus_eq"; (**)"?x - - ?y = ?x + ?y"
163.766 - "real_0_divide"; (**)"0 / ?x = 0"
163.767 - "real_0_less_inverse_iff"; "(0 < inverse ?x) = (0 < ?x)"
163.768 - "real_inverse_less_0_iff";
163.769 - "real_0_le_inverse_iff";
163.770 - "real_inverse_le_0_iff";
163.771 - "REAL_DIVIDE_ZERO"; "?x / 0 = 0"(*!!!*)
163.772 - "real_inverse_eq_divide";
163.773 - "real_0_less_divide_iff";"(0 < ?x / ?y) = (0 < ?x & 0 < ?y | ?x < 0 & ?y < 0)"
163.774 - "real_divide_less_0_iff";"(?x / ?y < 0) = (0 < ?x & ?y < 0 | ?x < 0 & 0 < ?y)"
163.775 - "real_0_le_divide_iff";
163.776 - "real_divide_le_0_iff";
163.777 - "(?x / ?y <= 0) = ((?x <= 0 | ?y <= 0) & (0 <= ?x | 0 <= ?y))"
163.778 - "real_inverse_zero_iff";
163.779 - "real_divide_eq_0_iff"; "(?x / ?y = 0) = (?x = 0 | ?y = 0)"(*!!!*)
163.780 - "real_divide_self_eq"; "?h ~= 0 ==> ?h / ?h = 1"(**)
163.781 - "real_minus_less_minus"; "(- ?y < - ?x) = (?x < ?y)"
163.782 - "real_mult_less_mono1_neg"; "[| ?i < ?j; ?k < 0 |] ==> ?j * ?k < ?i * ?k"
163.783 - "real_mult_less_mono2_neg";
163.784 - "real_mult_le_mono1_neg";
163.785 - "real_mult_le_mono2_neg";
163.786 - "real_mult_less_cancel2";
163.787 - "real_mult_le_cancel2";
163.788 - "real_mult_less_cancel1";
163.789 - "real_mult_le_cancel1";
163.790 - "real_mult_eq_cancel1"; "(?k * ?m = ?k * ?n) = (?k = 0 | ?m = ?n)"
163.791 - "real_mult_eq_cancel2"; "(?m * ?k = ?n * ?k) = (?k = 0 | ?m = ?n)"
163.792 - "real_mult_div_cancel1"; (**)"?k ~= 0 ==> ?k * ?m / (?k * ?n) = ?m / ?n"
163.793 - "real_mult_div_cancel_disj";
163.794 - "?k * ?m / (?k * ?n) = (if ?k = 0 then 0 else ?m / ?n)"
163.795 - "pos_real_le_divide_eq";
163.796 - "neg_real_le_divide_eq";
163.797 - "pos_real_divide_le_eq";
163.798 - "neg_real_divide_le_eq";
163.799 - "pos_real_less_divide_eq";
163.800 - "neg_real_less_divide_eq";
163.801 - "pos_real_divide_less_eq";
163.802 - "neg_real_divide_less_eq";
163.803 - "real_eq_divide_eq"; (**)"?z ~= 0 ==> (?x = ?y / ?z) = (?x * ?z = ?y)"
163.804 - "real_divide_eq_eq"; (**)"?z ~= 0 ==> (?y / ?z = ?x) = (?y = ?x * ?z)"
163.805 - "real_divide_eq_cancel2"; "(?m / ?k = ?n / ?k) = (?k = 0 | ?m = ?n)"
163.806 - "real_divide_eq_cancel1"; "(?k / ?m = ?k / ?n) = (?k = 0 | ?m = ?n)"
163.807 - "real_inverse_less_iff";
163.808 - "real_inverse_le_iff";
163.809 - "real_divide_1"; (**)"?x / 1 = ?x"
163.810 - "real_divide_minus1"; (**)"?x / -1 = - ?x"
163.811 - "real_minus1_divide"; (**)"-1 / ?x = - (1 / ?x)"
163.812 - "real_lbound_gt_zero";
163.813 - "[| 0 < ?d1.0; 0 < ?d2.0 |] ==> EX e. 0 < e & e < ?d1.0 & e < ?d2.0"
163.814 - "real_inverse_eq_iff"; "(inverse ?x = inverse ?y) = (?x = ?y)"
163.815 - "real_divide_eq_iff"; "(?z / ?x = ?z / ?y) = (?z = 0 | ?x = ?y)"
163.816 - "real_less_minus"; "(?x < - ?y) = (?y < - ?x)"
163.817 - "real_minus_less"; "(- ?x < ?y) = (- ?y < ?x)"
163.818 - "real_le_minus";
163.819 - "real_minus_le"; "(- ?x <= ?y) = (- ?y <= ?x)"
163.820 - "real_equation_minus"; (**)"(?x = - ?y) = (?y = - ?x)"
163.821 - "real_minus_equation"; (**)"(- ?x = ?y) = (- ?y = ?x)"
163.822 - "real_add_minus_iff"; (**)"(?x + - ?a = 0) = (?x = ?a)"
163.823 - "real_minus_eq_cancel"; (**)"(- ?b = - ?a) = (?b = ?a)"
163.824 - "real_add_eq_0_iff"; (**)"(?x + ?y = 0) = (?y = - ?x)"
163.825 - "real_add_less_0_iff"; "(?x + ?y < 0) = (?y < - ?x)"
163.826 - "real_0_less_add_iff";
163.827 - "real_add_le_0_iff";
163.828 - "real_0_le_add_iff";
163.829 - "real_0_less_diff_iff"; "(0 < ?x - ?y) = (?y < ?x)"
163.830 - "real_0_le_diff_iff";
163.831 - "real_minus_diff_eq"; (**)"- (?x - ?y) = ?y - ?x"
163.832 - "real_less_half_sum"; "?x < ?y ==> ?x < (?x + ?y) / 2"
163.833 - "real_gt_half_sum";
163.834 - "real_dense"; "?x < ?y ==> EX r. ?x < r & r < ?y"
163.835 -RealArith ///!!!///-----------------------------------------------------------
163.836 -RComplete.ML:qed -------------------------------------------------------------
163.837 - "real_sum_of_halves"; (**)"?x / 2 + ?x / 2 = ?x"
163.838 - "real_sup_lemma1";
163.839 - "real_sup_lemma2";
163.840 - "posreal_complete";
163.841 - "real_isLub_unique";
163.842 - "real_order_restrict";
163.843 - "posreals_complete";
163.844 - "real_sup_lemma3";
163.845 - "lemma_le_swap2";
163.846 - "lemma_real_complete2b";
163.847 - "reals_complete";
163.848 - "real_of_nat_Suc_gt_zero";
163.849 - "reals_Archimedean"; "0 < ?x ==> EX n. inverse (real (Suc n)) < ?x"
163.850 - "reals_Archimedean2";
163.851 -RealAbs.ML:qed
163.852 - "abs_nat_number_of";
163.853 - "abs (number_of ?v) =
163.854 - (if neg (number_of ?v) then number_of (bin_minus ?v) else number_of ?v)"
163.855 - "abs_split";
163.856 - "abs_iff";
163.857 - "abs_zero"; "abs 0 = 0"
163.858 - "abs_one";
163.859 - "abs_eqI1";
163.860 - "abs_eqI2";
163.861 - "abs_minus_eqI2";
163.862 - "abs_minus_eqI1";
163.863 - "abs_ge_zero"; "0 <= abs ?x"
163.864 - "abs_idempotent"; "abs (abs ?x) = abs ?x"
163.865 - "abs_zero_iff"; "(abs ?x = 0) = (?x = 0)"
163.866 - "abs_ge_self"; "?x <= abs ?x"
163.867 - "abs_ge_minus_self";
163.868 - "abs_mult"; "abs (?x * ?y) = abs ?x * abs ?y"
163.869 - "abs_inverse"; "abs (inverse ?x) = inverse (abs ?x)"
163.870 - "abs_mult_inverse";
163.871 - "abs_triangle_ineq"; "abs (?x + ?y) <= abs ?x + abs ?y"
163.872 - "abs_triangle_ineq_four";
163.873 - "abs_minus_cancel";
163.874 - "abs_minus_add_cancel";
163.875 - "abs_triangle_minus_ineq";
163.876 -RealAbs.ML:qed_spec_mp
163.877 - "abs_add_less"; "[| abs ?x < ?r; abs ?y < ?s |] ==> abs (?x + ?y) < ?r + ?s"
163.878 -RealAbs.ML:qed
163.879 - "abs_add_minus_less";
163.880 - "real_mult_0_less"; "(0 * ?x < ?r) = (0 < ?r)"
163.881 - "real_mult_less_trans";
163.882 - "real_mult_le_less_trans";
163.883 - "abs_mult_less";
163.884 - "abs_mult_less2";
163.885 - "abs_less_gt_zero";
163.886 - "abs_minus_one"; "abs -1 = 1"
163.887 - "abs_disj"; "abs ?x = ?x | abs ?x = - ?x"
163.888 - "abs_interval_iff";
163.889 - "abs_le_interval_iff";
163.890 - "abs_add_pos_gt_zero";
163.891 - "abs_add_one_gt_zero";
163.892 - "abs_not_less_zero";
163.893 - "abs_circle"; "abs ?h < abs ?y - abs ?x ==> abs (?x + ?h) < abs ?y"
163.894 - "abs_le_zero_iff";
163.895 - "real_0_less_abs_iff";
163.896 - "abs_real_of_nat_cancel";
163.897 - "abs_add_one_not_less_self";
163.898 - "abs_triangle_ineq_three"; "abs (?w + ?x + ?y) <= abs ?w + abs ?x + abs ?y"
163.899 - "abs_diff_less_imp_gt_zero";
163.900 - "abs_diff_less_imp_gt_zero2";
163.901 - "abs_diff_less_imp_gt_zero3";
163.902 - "abs_diff_less_imp_gt_zero4";
163.903 - "abs_triangle_ineq_minus_cancel";
163.904 - "abs_sum_triangle_ineq";
163.905 - "abs (?x + ?y + (- ?l + - ?m)) <= abs (?x + - ?l) + abs (?y + - ?m)"
163.906 -RealPow.ML:qed
163.907 - "realpow_zero"; "0 ^ Suc ?n = 0"
163.908 -RealPow.ML:qed_spec_mp
163.909 - "realpow_not_zero"; "?r ~= 0 ==> ?r ^ ?n ~= 0"
163.910 - "realpow_zero_zero"; "?r ^ ?n = 0 ==> ?r = 0"
163.911 - "realpow_inverse"; "inverse (?r ^ ?n) = inverse ?r ^ ?n"
163.912 - "realpow_abs"; "abs (?r ^ ?n) = abs ?r ^ ?n"
163.913 - "realpow_add"; (**)"?r ^ (?n + ?m) = ?r ^ ?n * ?r ^ ?m"
163.914 - "realpow_one"; (**)"?r ^ 1 = ?r"
163.915 - "realpow_two"; (**)"?r ^ Suc (Suc 0) = ?r * ?r"
163.916 -RealPow.ML:qed_spec_mp
163.917 - "realpow_gt_zero"; "0 < ?r ==> 0 < ?r ^ ?n"
163.918 - "realpow_ge_zero"; "0 <= ?r ==> 0 <= ?r ^ ?n"
163.919 - "realpow_le"; "0 <= ?x & ?x <= ?y ==> ?x ^ ?n <= ?y ^ ?n"
163.920 - "realpow_less";
163.921 -RealPow.ML:qed
163.922 - "realpow_eq_one"; (**)"1 ^ ?n = 1"
163.923 - "abs_realpow_minus_one"; "abs (-1 ^ ?n) = 1"
163.924 - "realpow_mult"; (**)"(?r * ?s) ^ ?n = ?r ^ ?n * ?s ^ ?n"
163.925 - "realpow_two_le"; "0 <= ?r ^ Suc (Suc 0)"
163.926 - "abs_realpow_two";
163.927 - "realpow_two_abs"; "abs ?x ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)"
163.928 - "realpow_two_gt_one";
163.929 -RealPow.ML:qed_spec_mp
163.930 - "realpow_ge_one"; "1 < ?r ==> 1 <= ?r ^ ?n"
163.931 -RealPow.ML:qed
163.932 - "realpow_ge_one2";
163.933 - "two_realpow_ge_one";
163.934 - "two_realpow_gt";
163.935 - "realpow_minus_one"; (**)"-1 ^ (2 * ?n) = 1"
163.936 - "realpow_minus_one_odd"; "-1 ^ Suc (2 * ?n) = - 1"
163.937 - "realpow_minus_one_even";
163.938 -RealPow.ML:qed_spec_mp
163.939 - "realpow_Suc_less";
163.940 - "realpow_Suc_le"; "0 <= ?r & ?r < 1 ==> ?r ^ Suc ?n <= ?r ^ ?n"
163.941 -RealPow.ML:qed
163.942 - "realpow_zero_le"; "0 <= 0 ^ ?n"
163.943 -RealPow.ML:qed_spec_mp
163.944 - "realpow_Suc_le2";
163.945 -RealPow.ML:qed
163.946 - "realpow_Suc_le3";
163.947 -RealPow.ML:qed_spec_mp
163.948 - "realpow_less_le"; "0 <= ?r & ?r < 1 & ?n < ?N ==> ?r ^ ?N <= ?r ^ ?n"
163.949 -RealPow.ML:qed
163.950 - "realpow_le_le"; "[| 0 <= ?r; ?r < 1; ?n <= ?N |] ==> ?r ^ ?N <= ?r ^ ?n"
163.951 - "realpow_Suc_le_self";
163.952 - "realpow_Suc_less_one";
163.953 -RealPow.ML:qed_spec_mp
163.954 - "realpow_le_Suc";
163.955 - "realpow_less_Suc";
163.956 - "realpow_le_Suc2";
163.957 - "realpow_gt_ge";
163.958 - "realpow_gt_ge2";
163.959 -RealPow.ML:qed
163.960 - "realpow_ge_ge"; "[| 1 < ?r; ?n <= ?N |] ==> ?r ^ ?n <= ?r ^ ?N"
163.961 - "realpow_ge_ge2";
163.962 -RealPow.ML:qed_spec_mp
163.963 - "realpow_Suc_ge_self";
163.964 - "realpow_Suc_ge_self2";
163.965 -RealPow.ML:qed
163.966 - "realpow_ge_self";
163.967 - "realpow_ge_self2";
163.968 -RealPow.ML:qed_spec_mp
163.969 - "realpow_minus_mult"; "0 < ?n ==> ?x ^ (?n - 1) * ?x = ?x ^ ?n"
163.970 - "realpow_two_mult_inverse";
163.971 - "?r ~= 0 ==> ?r * inverse ?r ^ Suc (Suc 0) = inverse ?r"
163.972 - "realpow_two_minus"; "(- ?x) ^ Suc (Suc 0) = ?x ^ Suc (Suc 0)"
163.973 - "realpow_two_diff";
163.974 - "realpow_two_disj";
163.975 - "realpow_diff";
163.976 - "[| ?x ~= 0; ?m <= ?n |] ==> ?x ^ (?n - ?m) = ?x ^ ?n * inverse (?x ^ ?m)"
163.977 - "realpow_real_of_nat";
163.978 - "realpow_real_of_nat_two_pos"; "0 < real (Suc (Suc 0) ^ ?n)"
163.979 -RealPow.ML:qed_spec_mp
163.980 - "realpow_increasing";
163.981 - "realpow_Suc_cancel_eq";
163.982 - "[| 0 <= ?x; 0 <= ?y; ?x ^ Suc ?n = ?y ^ Suc ?n |] ==> ?x = ?y"
163.983 -RealPow.ML:qed
163.984 - "realpow_eq_0_iff"; "(?x ^ ?n = 0) = (?x = 0 & 0 < ?n)"
163.985 - "zero_less_realpow_abs_iff";
163.986 - "zero_le_realpow_abs";
163.987 - "real_of_int_power"; "real ?x ^ ?n = real (?x ^ ?n)"
163.988 - "power_real_number_of"; "number_of ?v ^ ?n = real (number_of ?v ^ ?n)"
163.989 -Ring_and_Field ---///!!!///---------------------------------------------------
163.990 -Complex_Numbers --///!!!///---------------------------------------------------
163.991 -Real -------------///!!!///---------------------------------------------------
163.992 -real_arith0.ML:qed "";
163.993 -real_arith0.ML:qed "";
163.994 -real_arith0.ML:qed "";
163.995 -real_arith0.ML:qed "";
163.996 -real_arith0.ML:qed "";
163.997 -real_arith0.ML:qed "";
163.998 -real_arith0.ML:qed "";
163.999 -real_arith0.ML:qed "";
163.1000 -real_arith0.ML:qed "";
163.1001 -
163.1002 -
163.1003 -
163.1004 -
163.1005 -
163.1006 -
163.1007 -
163.1008 -
164.1 --- a/src/Tools/isac/Scripts/Script.thy Wed Aug 25 15:15:01 2010 +0200
164.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
164.3 @@ -1,194 +0,0 @@
164.4 -(* Title: tactics, tacticals etc. for scripts
164.5 - Author: Walther Neuper 000224
164.6 - (c) due to copyright terms
164.7 -
164.8 -use_thy_only"Scripts/Script";
164.9 -use_thy"../Scripts/Script";
164.10 -use_thy"Script";
164.11 - *)
164.12 -
164.13 -theory Script imports Tools begin
164.14 -
164.15 -typedecl
164.16 - ID (* identifiers for thy, ruleset,... *)
164.17 -
164.18 -typedecl
164.19 - arg (* argument of subproblem *)
164.20 -
164.21 -consts
164.22 -
164.23 -(*types of subproblems' arguments*)
164.24 - real_' :: "real => arg"
164.25 - real_list_' :: "(real list) => arg"
164.26 - real_set_' :: "(real set) => arg"
164.27 - bool_' :: "bool => arg"
164.28 - bool_list_' :: "(bool list) => arg"
164.29 - real_real_' :: "(real => real) => arg"
164.30 -
164.31 -(*tactics*)
164.32 - Rewrite :: "[ID, bool, 'a] => 'a"
164.33 - Rewrite'_Inst:: "[(real * real) list, ID, bool, 'a] => 'a"
164.34 - ("(Rewrite'_Inst (_ _ _))" 11)
164.35 - (*without last argument ^^ for @@*)
164.36 - Rewrite'_Set :: "[ID, bool, 'a] => 'a" ("(Rewrite'_Set (_ _))" 11)
164.37 - Rewrite'_Set'_Inst
164.38 - :: "[(real * real) list, ID, bool, 'a] => 'a"
164.39 - ("(Rewrite'_Set'_Inst (_ _ _))" 11)
164.40 - (*without last argument ^^ for @@*)
164.41 - Calculate :: "[ID, 'a] => 'a" (*WN100816 PLUS, TIMES, POWER miss.in scr*)
164.42 - Calculate1 :: "[ID, 'a] => 'a" (*FIXXXME: unknown to script-interpreter*)
164.43 -
164.44 - (* WN0509 substitution now is rewriting by a list of terms (of type bool)
164.45 - Substitute :: "[(real * real) list, 'a] => 'a"*)
164.46 - Substitute :: "[bool list, 'a] => 'a"
164.47 -
164.48 - Map :: "['a => 'b, 'a list] => 'b list"
164.49 - Tac :: "ID => 'a" (*deprecated; only use in Test.ML*)
164.50 - Check'_elementwise ::
164.51 - "['a list, 'b set] => 'a list"
164.52 - ("Check'_elementwise (_ _)" 11)
164.53 - Take :: "'a => 'a" (*for non-var args as long as no 'o'*)
164.54 - SubProblem :: "[ID * ID list * ID list, arg list] => 'a"
164.55 -
164.56 - Or'_to'_List :: "bool => 'a list" ("Or'_to'_List (_)" 11)
164.57 - (*=========== record these ^^^ in 'tacs' in Script.ML =========*)
164.58 -
164.59 - Assumptions :: bool
164.60 - Problem :: "[ID * ID list] => 'a"
164.61 -
164.62 -(*special formulas for frontend 'CAS format'*)
164.63 - Subproblem :: "(ID * ID list) => 'a"
164.64 -
164.65 -(*script-expressions (tacticals)*)
164.66 - Seq :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "@@" 10) (*@ used*)
164.67 - Try :: "['a => 'a, 'a] => 'a"
164.68 - Repeat :: "['a => 'a, 'a] => 'a"
164.69 - Or :: "['a => 'a, 'a => 'a, 'a] => 'a" (infixr "Or" 10)
164.70 - While :: "[bool, 'a => 'a, 'a] => 'a" ("((While (_) Do)//(_))" 9)
164.71 -(*WN100723 because of "Error in syntax translation" below...
164.72 - (*'b => bool doesn't work with "contains_root _"*)
164.73 - Letpar :: "['a, 'a => 'b] => 'b"
164.74 - (*--- defined in Isabelle/scr/HOL/HOL.thy:
164.75 - Let :: "['a, 'a => 'b] => 'b"
164.76 - "_Let" :: "[letbinds, 'a] => 'a" ("(let (_)/ in (_))" 10)
164.77 - If :: "[bool, 'a, 'a] => 'a" ("(if (_)/ then (_)/ else (_))" 10)
164.78 - %x. P x .. lambda is defined in Isabelles meta logic
164.79 - --- *)
164.80 -*)
164.81 - failtac :: 'a
164.82 - idletac :: 'a
164.83 - (*... + RECORD IN 'screxpr' in Script.ML *)
164.84 -
164.85 -(*for scripts generated automatically from rls*)
164.86 - Stepwise :: "['z, 'z] => 'z" ("((Script Stepwise (_ =))// (_))" 9)
164.87 - Stepwise'_inst:: "['z,real,'z] => 'z"
164.88 - ("((Script Stepwise'_inst (_ _ =))// (_))" 9)
164.89 -
164.90 -
164.91 -(*SHIFT -> resp.thys ----vvv---------------------------------------------*)
164.92 -(*script-names: initial capital letter,
164.93 - type of last arg (=script-body) == result-type !
164.94 - Xxxx :: script ids, duplicate result-type 'r in last argument:
164.95 - "['a, ... , \
164.96 - \ 'r] => 'r
164.97 -*)
164.98 -
164.99 -(*make'_solution'_set :: "bool => bool list"
164.100 - ("(make'_solution'_set (_))" 11)
164.101 -
164.102 - max'_on'_interval
164.103 - :: "[ID * (ID list) * ID, bool,real,real set] => real"
164.104 - ("(max'_on'_interval (_)/ (_ _ _))" 9)
164.105 - find'_vals
164.106 - :: "[ID * (ID list) * ID,
164.107 - real,real,real,real,bool list] => bool list"
164.108 - ("(find'_vals (_)/ (_ _ _ _ _))" 9)
164.109 -
164.110 - make'_fun :: "[ID * (ID list) * ID, real,real,bool list] => bool"
164.111 - ("(make'_fun (_)/ (_ _ _))" 9)
164.112 -
164.113 - solve'_univar
164.114 - :: "[ID * (ID list) * ID, bool,real] => bool list"
164.115 - ("(solve'_univar (_)/ (_ _ ))" 9)
164.116 - solve'_univar'_err
164.117 - :: "[ID * (ID list) * ID, bool,real,bool] => bool list"
164.118 - ("(solve'_univar (_)/ (_ _ _))" 9)
164.119 -----------*)
164.120 -
164.121 - Testeq :: "[bool, bool] => bool"
164.122 - ("((Script Testeq (_ =))//
164.123 - (_))" 9)
164.124 -
164.125 - Testeq2 :: "[bool, bool list] => bool list"
164.126 - ("((Script Testeq2 (_ =))//
164.127 - (_))" 9)
164.128 -
164.129 - Testterm :: "[real, real] => real"
164.130 - ("((Script Testterm (_ =))//
164.131 - (_))" 9)
164.132 -
164.133 - Testchk :: "[bool, real, real list] => real list"
164.134 - ("((Script Testchk (_ _ =))//
164.135 - (_))" 9)
164.136 - (*... + RECORD IN 'subpbls' in Script.ML *)
164.137 -(*SHIFT -> resp.thys ----^^^----------------------------*)
164.138 -
164.139 -(*Makarius 10.03
164.140 -syntax
164.141 -
164.142 - "_Letpar" :: "[letbinds, 'a] => 'a" ("(letpar (_)/ in (_))" 10)
164.143 -
164.144 -translations
164.145 -
164.146 - "_Letpar (_binds b bs) e" == "_Letpar b (_Letpar bs e)"
164.147 - "letpar x = a in e" == "Letpar a (%x. e)"
164.148 -*** Error in syntax translation rule: rhs contains extra variables
164.149 -*** ("_Letpar" ("_bind" x a) e) -> (Letpar a ("_abs" x e))
164.150 -*** At command "translations" (line 140 of "/usr/local/isabisac/src/Pure/isac/Scripts/Script.thy").
164.151 -*)
164.152 -
164.153 -ML {* (*the former Script.ML*)
164.154 -
164.155 -(*.record all theories defined for Scripts; in order to distinguish them
164.156 - from general IsacKnowledge defined later on.*)
164.157 -script_thys := !theory';
164.158 -
164.159 -(*--vvv----- SHIFT? or delete ?*)
164.160 -val IDTyp = Type("Script.ID",[]);
164.161 -
164.162 -
164.163 -val tacs = ref (distinct (remove op = ""
164.164 - ["Calculate",
164.165 - "Rewrite","Rewrite'_Inst","Rewrite'_Set","Rewrite'_Set'_Inst",
164.166 - "Substitute","Tac","Check'_elementswise",
164.167 - "Take","Subproblem","Or'_to'_List"]));
164.168 -
164.169 -val screxpr = ref (distinct (remove op = ""
164.170 - ["Let","If","Repeat","While","Try","Or"]));
164.171 -
164.172 -val listfuns = ref [(*_all_ functions in Isa99.List.thy *)
164.173 - "@","filter","concat","foldl","hd","last","set","list_all",
164.174 - "map","mem","nth","list_update","take","drop",
164.175 - "takeWhile","dropWhile","tl","butlast",
164.176 - "rev","zip","upt","remdups","nodups","replicate",
164.177 -
164.178 - "Cons","Nil"];
164.179 -
164.180 -val scrfuns = ref (distinct (remove op = ""
164.181 - ["Testvar"]));
164.182 -
164.183 -val listexpr = ref (union op = (!listfuns) (!scrfuns));
164.184 -
164.185 -val notsimp = ref
164.186 - (distinct (remove op = ""
164.187 - (!tacs @ !screxpr @ (*!subpbls @*) !scrfuns @ !listfuns)));
164.188 -
164.189 -val negotiable = ref ((!tacs (*@ !subpbls*)));
164.190 -
164.191 -val tacpbl = ref
164.192 - (distinct (remove op = "" (!tacs (*@ !subpbls*))));
164.193 -(*--^^^----- SHIFT? or delete ?*)
164.194 -
164.195 -*}
164.196 -
164.197 -end
165.1 --- a/src/Tools/isac/Scripts/Tools.sml Wed Aug 25 15:15:01 2010 +0200
165.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
165.3 @@ -1,113 +0,0 @@
165.4 -(* = Tools.ML
165.5 - +++ outcommented tests *)
165.6 -
165.7 -
165.8 -fun eval_var (thmid:string) (op_:string)
165.9 - (t as (Const(op0,t0) $ arg)) thy =
165.10 - let
165.11 - val t' = ((list2isalist HOLogic.realT) o vars) t;
165.12 - val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg);
165.13 - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
165.14 - | eval_var _ _ _ _ = raise GO_ON;
165.15 -(*
165.16 -> val t = (term_of o the o (parse thy)) "Var (A=a*(b::real))";
165.17 -> val op_ = "Var";
165.18 -> val eval_fn = the (assoc (!eval_list, op_));
165.19 -> get_pair op_ eval_fn t;
165.20 -> val (t as (Const(op0,t0) $ arg)) = t;
165.21 -> eval_fn op0 t;
165.22 -
165.23 -> val thmid = "#Var_";
165.24 -> val (SOME(thmId,t')) = eval_var thmid op0 t;
165.25 -val it = SOME ("#Var_(A::real) = (a::real) * (b::real)",Const # $ (# $ #))
165.26 - : (string * term) option
165.27 -> Syntax.string_of_term (thy2ctxt thy) t';
165.28 -val it = "Var ((A::real) = (a::real) * (b::real)) = [A, a, b]" : string
165.29 -*)
165.30 -fun eval_Length (thmid:string) (op_:string)
165.31 - (t as (Const(op0,t0) $ arg)) thy =
165.32 - let
165.33 - val t' = ((term_of_num HOLogic.realT) o length o isalist2list) arg;
165.34 - val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) arg);
165.35 - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
165.36 - | eval_Length _ _ _ _ = raise GO_ON;
165.37 -(*
165.38 -> val thmid = "#Length_"; val op_ = "Length";
165.39 -> val s = "Length [A = a * b, a // #2 = #2]";
165.40 -> val (t as (Const(op0,t0) $ arg)) = (term_of o the o (parse thy)) s;
165.41 -> val (SOME (id,t')) = eval_Length thmid op_ t;
165.42 -val id = "#Length_[A = a * b, a // #2 = #2]" : string
165.43 -val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#))
165.44 -val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm
165.45 ----------------------------------------------
165.46 -> val thmid = "#Length_"; val op_ = "Length";
165.47 -> val s =
165.48 - "if #1 < Length [A = a * b, a // #2 = #2] \
165.49 - \then make_fun (R, [make, function], no_met) A a_ [A = a * b, a // #2 = #2]\
165.50 - \else hd [A = a * b, a // #2 = #2]";
165.51 -
165.52 -> (cterm_of thy) t';
165.53 -> val t = (term_of o the o (parse thy)) s;
165.54 -> val eval_fn = the (assoc (!eval_list, op_));
165.55 -> val (SOME(_,t')) = get_pair op_ eval_fn t;
165.56 -val t' = Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Free (#,#))
165.57 -val it = "Length [A = a * b, a // #2 = #2] = #2" : cterm
165.58 -
165.59 -> val ct = (the o (parse thy)) s;
165.60 -> val (SOME(_,thm)) = get_calculation thy (op_, eval_fn) ct;
165.61 -val thm = "Length [A = a * b, a // #2 = #2] = #2" [[ Free ( #2, real) !!!]]
165.62 -> rewrite_ thy tless_true e_rls false thm ct;
165.63 -("if #1 < #2
165.64 - then make_fun (R, [make, function], no_met)
165.65 - A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]",
165.66 - []) : (cterm * cterm list) option
165.67 -> val ct = (the o (parse thy)) s;
165.68 -> rewrite_set_ thy e_rls false eval_script ct;
165.69 -("if #1 < #2
165.70 - then make_fun (R, [make, function], no_met)
165.71 - A a_ [A = a * b, a // #2 = #2] else hd [A = a * b, a // #2 = #2]",
165.72 - []) : (cterm * cterm list) option
165.73 -*)
165.74 -
165.75 -fun eval_Nth (thmid:string) (op_:string) (t as
165.76 - (Const (op0,t0) $ t1 $ t2 )) thy =
165.77 -(writeln"@@@ eval_Nth";
165.78 - if is_num t1 andalso is_list t2
165.79 - then
165.80 - let
165.81 - val t' = (nth (num_of_term t1) (isalist2list t2))
165.82 - handle _ => raise GO_ON;
165.83 - val thmId = thmid^(Syntax.string_of_term (thy2ctxt thy) t1)^
165.84 - "_"^(Syntax.string_of_term (thy2ctxt thy) t2)^
165.85 - " = "^(Syntax.string_of_term (thy2ctxt thy) t');
165.86 - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
165.87 - else raise GO_ON
165.88 -)
165.89 - | eval_Nth _ _ _ _ = raise GO_ON;
165.90 -(*
165.91 -> val thmid = "#Nth_"; val op_ = "Nth";
165.92 -> val s = "Nth #2 [A = a * b, a // #2 = #2]";
165.93 -> val t = (term_of o the o (parse thy)) s;
165.94 -> eval_Nth thmid op_ t;
165.95 -
165.96 -> val eval_fn = the (assoc (!eval_list, op_));
165.97 -> val (SOME(id,t')) = get_pair op_ eval_fn t;
165.98 -> (cterm_of thy) t';
165.99 -val it = "Nth #2 [A = a * b, a // #2 = #2] = (a // #2 = #2)"
165.100 -*)
165.101 -
165.102 -
165.103 -(*17.6.00: calc_list instead eval_list*)
165.104 -eval_list:= overwritel (! eval_list,
165.105 - [("Var",eval_var "#Var_"),
165.106 - ("Length",eval_Length "#Length_"),
165.107 - ("Nth",eval_Nth "#Nth_")
165.108 - ]);
165.109 -(*17.6.00: association list for calculate_, calculate*)
165.110 -calc_list:= overwritel (! calc_list,
165.111 - [
165.112 - ("Var" ,("Var",eval_var "#Var_")),
165.113 - ("Length",("Length",eval_Length "#Length_")),
165.114 - ("Nth" ,("Nth",eval_Nth "#Nth_"))
165.115 - ]);
165.116 -
166.1 --- a/src/Tools/isac/Scripts/Tools.thy Wed Aug 25 15:15:01 2010 +0200
166.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
166.3 @@ -1,230 +0,0 @@
166.4 -(* auxiliary functions used in scripts
166.5 - author: Walther Neuper 000301
166.6 - WN0509 shift into Atools ?!? (because used also in where of models !)
166.7 -
166.8 - (c) copyright due to lincense terms.
166.9 -
166.10 -remove_thy"Tools";
166.11 -use_thy"Scripts/Tools";
166.12 -*)
166.13 -
166.14 -theory Tools imports ListG begin
166.15 -
166.16 -(*belongs to theory ListG*)
166.17 -ML {*
166.18 -val first_isac_thy = @{theory ListG}
166.19 -*}
166.20 -
166.21 -(*for Descript.thy*)
166.22 -
166.23 - (***********************************************************************)
166.24 - (* 'fun is_dsc' in Scripts/scrtools.smlMUST contain ALL these types !!!*)
166.25 - (***********************************************************************)
166.26 -typedecl nam (* named variables *)
166.27 -typedecl una (* unnamed variables *)
166.28 -typedecl unl (* unnamed variables of type list, elementwise input prohibited*)
166.29 -typedecl str (* structured variables *)
166.30 -typedecl toreal (* var with undef real value: forces typing *)
166.31 -typedecl toreall (* var with undef real list value: forces typing *)
166.32 -typedecl tobooll (* var with undef bool list value: forces typing *)
166.33 -typedecl unknow (* input without dsc in fmz=[] *)
166.34 -typedecl cpy (* UNUSED: copy-named variables
166.35 - identified by .._0, .._i .._' in pbt *)
166.36 - (***********************************************************************)
166.37 - (* 'fun is_dsc' in Scripts/scrtools.smlMUST contain ALL these types !!!*)
166.38 - (***********************************************************************)
166.39 -
166.40 -consts
166.41 -
166.42 - UniversalList :: "bool list"
166.43 -
166.44 - lhs :: "bool => real" (*of an equality*)
166.45 - rhs :: "bool => real" (*of an equality*)
166.46 - Vars :: "'a => real list" (*get the variables of a term *)
166.47 - matches :: "['a, 'a] => bool"
166.48 - matchsub :: "['a, 'a] => bool"
166.49 -
166.50 -constdefs
166.51 -
166.52 - Testvar :: "[real, 'a] => bool" (*is a variable in a term: unused 6.5.03*)
166.53 - "Testvar v t == v mem (Vars t)" (*by rewriting only,no Calcunused 6.5.03*)
166.54 -
166.55 -ML {* (*the former Tools.ML*)
166.56 -(* auxiliary functions for scripts WN.9.00*)
166.57 -(*11.02: for equation solving only*)
166.58 -val UniversalList = (term_of o the o (parse @{theory})) "UniversalList";
166.59 -val EmptyList = (term_of o the o (parse @{theory})) "[]::bool list";
166.60 -
166.61 -(*+ for Or_to_List +*)
166.62 -fun or2list (Const ("True",_)) = (writeln"### or2list True";UniversalList)
166.63 - | or2list (Const ("False",_)) = (writeln"### or2list False";EmptyList)
166.64 - | or2list (t as Const ("op =",_) $ _ $ _) =
166.65 - (writeln"### or2list _ = _";list2isalist bool [t])
166.66 - | or2list ors =
166.67 - (writeln"### or2list _ | _";
166.68 - let fun get ls (Const ("op |",_) $ o1 $ o2) =
166.69 - case o2 of
166.70 - Const ("op |",_) $ _ $ _ => get (ls @ [o1]) o2
166.71 - | _ => ls @ [o1, o2]
166.72 - in (((list2isalist bool) o (get [])) ors)
166.73 - handle _ => raise error ("or2list: no ORs= "^(term2str ors)) end
166.74 - );
166.75 -(*>val t = HOLogic.true_const;
166.76 -> val t' = or2list t;
166.77 -> term2str t';
166.78 -"Atools.UniversalList"
166.79 -> val t = HOLogic.false_const;
166.80 -> val t' = or2list t;
166.81 -> term2str t';
166.82 -"[]"
166.83 -> val t=(term_of o the o (parse thy)) "x=3";
166.84 -> val t' = or2list t;
166.85 -> term2str t';
166.86 -"[x = 3]"
166.87 -> val t=(term_of o the o (parse thy))"(x=3) | (x=-3) | (x=0)";
166.88 -> val t' = or2list t;
166.89 -> term2str t';
166.90 -"[x = #3, x = #-3, x = #0]" : string *)
166.91 -
166.92 -
166.93 -(** evaluation on the meta-level **)
166.94 -
166.95 -(*. evaluate the predicate matches (match on whole term only) .*)
166.96 -(*("matches",("Tools.matches",eval_matches "#matches_")):calc*)
166.97 -fun eval_matches (thmid:string) "Tools.matches"
166.98 - (t as Const ("Tools.matches",_) $ pat $ tst) thy =
166.99 - if matches thy tst pat
166.100 - then let val prop = Trueprop $ (mk_equality (t, true_as_term))
166.101 - in SOME (Syntax.string_of_term @{context} prop, prop) end
166.102 - else let val prop = Trueprop $ (mk_equality (t, false_as_term))
166.103 - in SOME (Syntax.string_of_term @{context} prop, prop) end
166.104 - | eval_matches _ _ _ _ = NONE;
166.105 -(*
166.106 -> val t = (term_of o the o (parse thy))
166.107 - "matches (?x = 0) (1 * x ^^^ 2 = 0)";
166.108 -> eval_matches "/thmid/" "/op_/" t thy;
166.109 -val it =
166.110 - SOME
166.111 - ("matches (x = 0) (1 * x ^^^ 2 = 0) = False",
166.112 - Const (#,#) $ (# $ # $ Const #)) : (string * term) option
166.113 -
166.114 -> val t = (term_of o the o (parse thy))
166.115 - "matches (?a = #0) (#1 * x ^^^ #2 = #0)";
166.116 -> eval_matches "/thmid/" "/op_/" t thy;
166.117 -val it =
166.118 - SOME
166.119 - ("matches (?a = #0) (#1 * x ^^^ #2 = #0) = True",
166.120 - Const (#,#) $ (# $ # $ Const #)) : (string * term) option
166.121 -
166.122 -> val t = (term_of o the o (parse thy))
166.123 - "matches (?a * x = #0) (#1 * x ^^^ #2 = #0)";
166.124 -> eval_matches "/thmid/" "/op_/" t thy;
166.125 -val it =
166.126 - SOME
166.127 - ("matches (?a * x = #0) (#1 * x ^^^ #2 = #0) = False",
166.128 - Const (#,#) $ (# $ # $ Const #)) : (string * term) option
166.129 -
166.130 -> val t = (term_of o the o (parse thy))
166.131 - "matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0)";
166.132 -> eval_matches "/thmid/" "/op_/" t thy;
166.133 -val it =
166.134 - SOME
166.135 - ("matches (?a * x ^^^ #2 = #0) (#1 * x ^^^ #2 = #0) = True",
166.136 - Const (#,#) $ (# $ # $ Const #)) : (string * term) option
166.137 ------ before ?patterns ---:
166.138 -> val t = (term_of o the o (parse thy))
166.139 - "matches (a * b^^^#2 = c) (#3 * x^^^#2 = #1)";
166.140 -> eval_matches "/thmid/" "/op_/" t thy;
166.141 -SOME
166.142 - ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2 = #1) = True",
166.143 - Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
166.144 - : (string * term) option
166.145 -
166.146 -> val t = (term_of o the o (parse thy))
166.147 - "matches (a * b^^^#2 = c) (#3 * x^^^#2222 = #1)";
166.148 -> eval_matches "/thmid/" "/op_/" t thy;
166.149 -SOME ("matches (a * b ^^^ #2 = c) (#3 * x ^^^ #2222 = #1) = False",
166.150 - Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
166.151 -
166.152 -> val t = (term_of o the o (parse thy))
166.153 - "matches (a = b) (x + #1 + #-1 * #2 = #0)";
166.154 -> eval_matches "/thmid/" "/op_/" t thy;
166.155 -SOME ("matches (a = b) (x + #1 + #-1 * #2 = #0) = True",Const # $ (# $ #))
166.156 -*)
166.157 -
166.158 -(*.does a pattern match some subterm ?.*)
166.159 -fun matchsub thy t pat =
166.160 - let fun matchs (t as Const _) = matches thy t pat
166.161 - | matchs (t as Free _) = matches thy t pat
166.162 - | matchs (t as Var _) = matches thy t pat
166.163 - | matchs (Bound _) = false
166.164 - | matchs (t as Abs (_, _, body)) =
166.165 - if matches thy t pat then true else matches thy body pat
166.166 - | matchs (t as f1 $ f2) =
166.167 - if matches thy t pat then true
166.168 - else if matchs f1 then true else matchs f2
166.169 - in matchs t end;
166.170 -
166.171 -(*("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")):calc*)
166.172 -fun eval_matchsub (thmid:string) "Tools.matchsub"
166.173 - (t as Const ("Tools.matchsub",_) $ pat $ tst) thy =
166.174 - if matchsub thy tst pat
166.175 - then let val prop = Trueprop $ (mk_equality (t, true_as_term))
166.176 - in SOME (Syntax.string_of_term @{context} prop, prop) end
166.177 - else let val prop = Trueprop $ (mk_equality (t, false_as_term))
166.178 - in SOME (Syntax.string_of_term @{context} prop, prop) end
166.179 - | eval_matchsub _ _ _ _ = NONE;
166.180 -
166.181 -(*get the variables in an isabelle-term*)
166.182 -(*("Vars" ,("Tools.Vars" ,eval_var "#Vars_")):calc*)
166.183 -fun eval_var (thmid:string) "Tools.Vars"
166.184 - (t as (Const(op0,t0) $ arg)) thy =
166.185 - let
166.186 - val t' = ((list2isalist HOLogic.realT) o vars) t;
166.187 - val thmId = thmid^(Syntax.string_of_term @{context} arg);
166.188 - in SOME (thmId, Trueprop $ (mk_equality (t,t'))) end
166.189 - | eval_var _ _ _ _ = NONE;
166.190 -
166.191 -fun lhs (Const ("op =",_) $ l $ _) = l
166.192 - | lhs t = error("lhs called with (" ^ term2str t ^ ")");
166.193 -(*("lhs" ,("Tools.lhs" ,eval_lhs "")):calc*)
166.194 -fun eval_lhs _ "Tools.lhs"
166.195 - (t as (Const ("Tools.lhs",_) $ (Const ("op =",_) $ l $ _))) _ =
166.196 - SOME ((term2str t) ^ " = " ^ (term2str l),
166.197 - Trueprop $ (mk_equality (t, l)))
166.198 - | eval_lhs _ _ _ _ = NONE;
166.199 -(*
166.200 -> val t = (term_of o the o (parse thy)) "lhs (1 * x ^^^ 2 = 0)";
166.201 -> val SOME (id,t') = eval_lhs 0 0 t 0;
166.202 -val id = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string
166.203 -> term2str t';
166.204 -val it = "Tools.lhs (1 * x ^^^ 2 = 0) = 1 * x ^^^ 2" : string
166.205 -*)
166.206 -
166.207 -fun rhs (Const ("op =",_) $ _ $ r) = r
166.208 - | rhs t = error("rhs called with (" ^ term2str t ^ ")");
166.209 -(*("rhs" ,("Tools.rhs" ,eval_rhs "")):calc*)
166.210 -fun eval_rhs _ "Tools.rhs"
166.211 - (t as (Const ("Tools.rhs",_) $ (Const ("op =",_) $ _ $ r))) _ =
166.212 - SOME ((term2str t) ^ " = " ^ (term2str r),
166.213 - Trueprop $ (mk_equality (t, r)))
166.214 - | eval_rhs _ _ _ _ = NONE;
166.215 -
166.216 -
166.217 -(*for evaluating scripts*)
166.218 -
166.219 -val list_rls = append_rls "list_rls" list_rls
166.220 - [Calc ("Tools.rhs",eval_rhs "")];
166.221 -ruleset' := overwritelthy @{theory} (!ruleset',
166.222 - [("list_rls",list_rls)
166.223 - ]);
166.224 -calclist':= overwritel (!calclist',
166.225 - [("matches",("Tools.matches",eval_matches "#matches_")),
166.226 - ("matchsub",("Tools.matchsub",eval_matchsub "#matchsub_")),
166.227 - ("Vars" ,("Tools.Vars" ,eval_var "#Vars_")),
166.228 - ("lhs" ,("Tools.lhs" ,eval_lhs "")),
166.229 - ("rhs" ,("Tools.rhs" ,eval_rhs ""))
166.230 - ]);
166.231 -
166.232 -*}
166.233 -end
167.1 --- a/src/Tools/isac/Scripts/calculate.sml Wed Aug 25 15:15:01 2010 +0200
167.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
167.3 @@ -1,408 +0,0 @@
167.4 -(* calculate values for function constants
167.5 - (c) Walther Neuper 000106
167.6 -
167.7 -use"Scripts/calculate.sml";
167.8 -*)
167.9 -
167.10 -
167.11 -(* dirty type-conversion 30.1.00 for "fixed_values [R=R]" *)
167.12 -
167.13 -val aT = Type ("'a", []);
167.14 -(* isas types for Free, parseold: (1) "R=R" or (2) "R=(R::real)":
167.15 -(1)
167.16 -> val (TFree(ss2,TT2)) = T2;
167.17 -val ss2 = "'a" : string
167.18 -val TT2 = ["term"] : sort
167.19 -(2)
167.20 -> val (Type(ss2',TT2')) = T2';
167.21 -val ss2' = "RealDef.real" : string
167.22 -val TT2' = [] : typ list
167.23 -(3)
167.24 -val realType = TFree ("RealDef.real", HOLogic.termS);
167.25 -is different internally, too;
167.26 -
167.27 -(1) .. (3) are displayed equally !!!
167.28 -*)
167.29 -
167.30 -
167.31 -
167.32 -(* 30.1.00: generating special terms for ME:
167.33 - (1) binary numerals reconverted to Free ("#num",...)
167.34 - by libarary_G.num_str: called from parse (below) and
167.35 - interface_ME_ISA for all thms used
167.36 - (compare HOLogic.dest_binum)
167.37 - (2) 'a types converted to RealDef.real by typ_a2real
167.38 - in parse below
167.39 - (3) binary operators fixed to type real in RatArith.thy
167.40 - (trick by Markus Wenzel)
167.41 -*)
167.42 -
167.43 -
167.44 -
167.45 -
167.46 -(** calculate numerals **)
167.47 -
167.48 -(*27.3.00: problems with patterns below:
167.49 -"Vars (a // #2 = r * xxxxx b)" doesn't work, but
167.50 -"Vars (a // #2 = r * sqrt b)" works
167.51 -*)
167.52 -
167.53 -fun popt2str (SOME (str, term)) = "SOME "^term2str term
167.54 - | popt2str NONE = "NONE";
167.55 -
167.56 -(* scan a term for applying eval_fn ef
167.57 -args
167.58 - thy:
167.59 - op_: operator (as string) selecting the root of the pair
167.60 - ef : fn : (string -> term -> theory -> (string * term) option)
167.61 - ^^^^^^... for creating the string for the resulting theorem
167.62 - t : term to be scanned
167.63 -result:
167.64 - (string * term) option: found by the eval_* -function of type
167.65 - fn : string -> string -> term -> theory -> (string * term) option
167.66 - ^^^^^^... the selecting operator op_ (variable for eval_binop)
167.67 -*)
167.68 -fun get_pair thy op_ (ef:string -> term -> theory -> (string * term) option)
167.69 - (t as (Const(op0,t0) $ arg)) = (* unary fns *)
167.70 -(* val (thy, op_, (ef), (t as (Const(op0,t0) $ arg))) =
167.71 - (thy, op_, eval_fn, ct);
167.72 - *)
167.73 - if op_ = op0 then
167.74 - let val popt = ef op_ t thy
167.75 - in case popt of
167.76 - SOME _ => popt
167.77 - | NONE => get_pair thy op_ ef arg end
167.78 - else get_pair thy op_ ef arg
167.79 -
167.80 - | get_pair thy "Atools.ident" ef (t as (Const("Atools.ident",t0) $ _ $ _ )) =
167.81 -(* val (thy, "Atools.ident", ef, t as (Const(op0,_) $ t1 $ t2)) =
167.82 - (thy, op_, eval_fn, ct);
167.83 - *)
167.84 - ef "Atools.ident" t thy (* not nested *)
167.85 -
167.86 - | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2)) = (* binary funs*)
167.87 -(* val (thy, op_, ef, (t as (Const(op0,_) $ t1 $ t2))) =
167.88 - (thy, op_, eval_fn, ct);
167.89 - *)
167.90 - ((*writeln("1.. get_pair: binop = "^op_);*)
167.91 - if op_ = op0 then
167.92 - let val popt = ef op_ t thy
167.93 - (*val _ = writeln("2.. get_pair: "^term2str t^" -> "^popt2str popt)*)
167.94 - in case popt of
167.95 - SOME (id,_) => popt
167.96 - | NONE =>
167.97 - let val popt = get_pair thy op_ ef t1
167.98 - (*val _ = writeln("3.. get_pair: "^term2str t1^
167.99 - " -> "^popt2str popt)*)
167.100 - in case popt of
167.101 - SOME (id,_) => popt
167.102 - | NONE => get_pair thy op_ ef t2
167.103 - end
167.104 - end
167.105 - else (*search subterms*)
167.106 - let val popt = get_pair thy op_ ef t1
167.107 - (*val _ = writeln("4.. get_pair: "^term2str t^" -> "^popt2str popt)*)
167.108 - in case popt of
167.109 - SOME (id,_) => popt
167.110 - | NONE => get_pair thy op_ ef t2
167.111 - end)
167.112 - | get_pair thy op_ ef (t as (Const(op0,_) $ t1 $ t2 $ t3)) =(* trinary funs*)
167.113 - ((*writeln("### get_pair 4a: t= "^term2str t);
167.114 - writeln("### get_pair 4a: op_= "^op_);
167.115 - writeln("### get_pair 4a: op0= "^op0);*)
167.116 - if op_ = op0 then
167.117 - case ef op_ t thy of
167.118 - SOME tt => SOME tt
167.119 - | NONE => (case get_pair thy op_ ef t2 of
167.120 - SOME tt => SOME tt
167.121 - | NONE => get_pair thy op_ ef t3)
167.122 - else (case get_pair thy op_ ef t1 of
167.123 - SOME tt => SOME tt
167.124 - | NONE => (case get_pair thy op_ ef t2 of
167.125 - SOME tt => SOME tt
167.126 - | NONE => get_pair thy op_ ef t3)))
167.127 - | get_pair thy op_ ef (Const _) = NONE
167.128 - | get_pair thy op_ ef (Free _) = NONE
167.129 - | get_pair thy op_ ef (Var _) = NONE
167.130 - | get_pair thy op_ ef (Bound _) = NONE
167.131 - | get_pair thy op_ ef (Abs(a,T,body)) = get_pair thy op_ ef body
167.132 - | get_pair thy op_ ef (t1$t2) =
167.133 - let(*val _= writeln("5.. get_pair t1 $ t2: "^term2str t1^"
167.134 - $ "^term2str t2)*)
167.135 - val popt = get_pair thy op_ ef t1
167.136 - in case popt of
167.137 - SOME _ => popt
167.138 - | NONE => ((*writeln"### get_pair: t1 $ t2 -> NONE";*)
167.139 - get_pair thy op_ ef t2)
167.140 - end;
167.141 - (*
167.142 -> val t = (term_of o the o (parse thy)) "#3 + #4";
167.143 -> val eval_fn = the (assoc (!eval_list, "op +"));
167.144 -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
167.145 -> Syntax.string_of_term (thy2ctxt thy) t';
167.146 -> atomty t';
167.147 ->
167.148 -> val t = (term_of o the o (parse thy)) "(a + #3) + #4";
167.149 -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
167.150 -> Syntax.string_of_term (thy2ctxt thy) t';
167.151 ->
167.152 -> val t = (term_of o the o (parse thy)) "#3 + (#4 + (a::real))";
167.153 -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
167.154 -> Syntax.string_of_term (thy2ctxt thy) t';
167.155 ->
167.156 -> val t = (term_of o the o (parse thy)) "x = #5 * (#3 + (#4 + a))";
167.157 -> atomty t;
167.158 -> val (SOME (id,t')) = get_pair thy "op +" eval_fn t;
167.159 -> Syntax.string_of_term (thy2ctxt thy) t';
167.160 -> val it = "#3 + (#4 + a) = #7 + a" : string
167.161 ->
167.162 ->
167.163 -> val t = (term_of o the o (parse thy)) "#-4//#-2";
167.164 -> val eval_fn = the (assoc (!eval_list, "cancel"));
167.165 -> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t;
167.166 -> Syntax.string_of_term (thy2ctxt thy) t';
167.167 ->
167.168 -> val t = (term_of o the o (parse thy)) "#2^^^#3";
167.169 -> eval_binop "xxx" "pow" t thy;
167.170 -> val eval_fn = (eval_binop "xxx")
167.171 -> : string -> term -> theory -> (string * term) option;
167.172 -> val SOME (id,t') = get_pair thy "pow" eval_fn t;
167.173 -> Syntax.string_of_term (thy2ctxt thy) t';
167.174 -> val eval_fn = the (assoc (!eval_list, "pow"));
167.175 -> val (SOME (id,t')) = get_pair thy "pow" eval_fn t;
167.176 -> Syntax.string_of_term (thy2ctxt thy) t';
167.177 ->
167.178 -> val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4";
167.179 -> val eval_fn = the (assoc (!eval_list, "op *"));
167.180 -> val (SOME (id,t')) = get_pair thy "op *" eval_fn t;
167.181 -> Syntax.string_of_term (thy2ctxt thy) t';
167.182 ->
167.183 -> val t = (term_of o the o (parse thy)) "#0 < #4";
167.184 -> val eval_fn = the (assoc (!eval_list, "op <"));
167.185 -> val (SOME (id,t')) = get_pair thy "op <" eval_fn t;
167.186 -> Syntax.string_of_term (thy2ctxt thy) t';
167.187 -> val t = (term_of o the o (parse thy)) "#0 < #-4";
167.188 -> val (SOME (id,t')) = get_pair thy "op <" eval_fn t;
167.189 -> Syntax.string_of_term (thy2ctxt thy) t';
167.190 ->
167.191 -> val t = (term_of o the o (parse thy)) "#3 is_const";
167.192 -> val eval_fn = the (assoc (!eval_list, "is'_const"));
167.193 -> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t;
167.194 -> Syntax.string_of_term (thy2ctxt thy) t';
167.195 -> val t = (term_of o the o (parse thy)) "a is_const";
167.196 -> val (SOME (id,t')) = get_pair thy "is'_const" eval_fn t;
167.197 -> Syntax.string_of_term (thy2ctxt thy) t';
167.198 ->
167.199 -> val t = (term_of o the o (parse thy)) "#6//(#8::real)";
167.200 -> val eval_fn = the (assoc (!eval_list, "cancel"));
167.201 -> val (SOME (id,t')) = get_pair thy "cancel" eval_fn t;
167.202 -> Syntax.string_of_term (thy2ctxt thy) t';
167.203 ->
167.204 -> val t = (term_of o the o (parse thy)) "sqrt #12";
167.205 -> val eval_fn = the (assoc (!eval_list, "SqRoot.sqrt"));
167.206 -> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t;
167.207 -> Syntax.string_of_term (thy2ctxt thy) t';
167.208 -> val it = "sqrt #12 = #2 * sqrt #3 " : string
167.209 ->
167.210 -> val t = (term_of o the o (parse thy)) "sqrt #9";
167.211 -> val (SOME (id,t')) = get_pair thy "SqRoot.sqrt" eval_fn t;
167.212 -> Syntax.string_of_term (thy2ctxt thy) t';
167.213 ->
167.214 -> val t = (term_of o the o (parse thy)) "Nth #2 [#11,#22,#33]";
167.215 -> val eval_fn = the (assoc (!eval_list, "Tools.Nth"));
167.216 -> val (SOME (id,t')) = get_pair thy "Tools.Nth" eval_fn t;
167.217 -> Syntax.string_of_term (thy2ctxt thy) t';
167.218 -*)
167.219 -
167.220 -(* val ((op_, eval_fn),ct)=(cc,pre);
167.221 - (get_calculation_ Isac.thy (op_, eval_fn) ct) handle e => print_exn e;
167.222 - parse thy ""
167.223 - *)
167.224 -(*.get a thm from an op_ somewhere in the term;
167.225 - apply ONLY to (uminus_to_string term), uminus_to_string (- 4711) --> (-4711).*)
167.226 -fun get_calculation_ thy (op_, eval_fn) ct =
167.227 -(* val (thy, (op_, eval_fn), ct) =
167.228 - (thy, (the (assoc(!calclist',"order_system"))), t);
167.229 - *)
167.230 - case get_pair thy op_ eval_fn ct of
167.231 - NONE => ((*writeln("@@@ get_calculation: NONE, op_="^op_);
167.232 - writeln("@@@ get_calculation: ct= ");atomty ct;*)
167.233 - NONE)
167.234 - | SOME (thmid,t) =>
167.235 - ((*writeln("@@@ get_calculation: NONE, op_="^op_);
167.236 - writeln("@@@ get_calculation: ct= ");atomty ct;*)
167.237 - SOME (thmid, (make_thm o (cterm_of thy)) t));
167.238 -(*
167.239 -> val ct = (the o (parse thy)) "#9 is_const";
167.240 -> get_calculation_ thy ("is'_const",the (assoc(!eval_list,"is'_const"))) ct;
167.241 -val it = SOME ("is_const9_","(is_const 9 ) = True [(is_const 9 ) = True]")
167.242 -
167.243 -> val ct = (the o (parse thy)) "sqrt #9";
167.244 -> get_calculation_ thy ("sqrt",the (assoc(!eval_list,"sqrt"))) ct;
167.245 -val it = SOME ("sqrt_9_","sqrt 9 = 3 [sqrt 9 = 3]") : (string * thm) option
167.246 -
167.247 -> val ct = (the o (parse thy)) "#4<#4";
167.248 -> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct;fun is_no str = (hd o explode) str = "#";
167.249 -
167.250 -val it = SOME ("less_5_4","(5 < 4) = False [(5 < 4) = False]")
167.251 -
167.252 -> val ct = (the o (parse thy)) "a<#4";
167.253 -> get_calculation_ thy ("op <",the (assoc(!eval_list,"op <"))) ct;
167.254 -val it = NONE : (string * thm) option
167.255 -
167.256 -> val ct = (the o (parse thy)) "#5<=#4";
167.257 -> get_calculation_ thy ("op <=",the (assoc(!eval_list,"op <="))) ct;
167.258 -val it = SOME ("less_equal_5_4","(5 <= 4) = False [(5 <= 4) = False]")
167.259 -
167.260 --------------------------------------------------------------------6.8.02:
167.261 - val thy = SqRoot.thy;
167.262 - val t = (term_of o the o (parse thy)) "1+2";
167.263 - get_calculation_ thy (the(assoc(!calc_list,"PLUS"))) t;
167.264 - val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option
167.265 --------------------------------------------------------------------6.8.02:
167.266 - val t = (term_of o the o (parse thy)) "-1";
167.267 - atomty t;
167.268 - val t = (term_of o the o (parse thy)) "0";
167.269 - atomty t;
167.270 - val t = (term_of o the o (parse thy)) "1";
167.271 - atomty t;
167.272 - val t = (term_of o the o (parse thy)) "2";
167.273 - atomty t;
167.274 - val t = (term_of o the o (parse thy)) "999999999";
167.275 - atomty t;
167.276 --------------------------------------------------------------------6.8.02:
167.277 -
167.278 -> val ct = (the o (parse thy)) "a+#3+#4";
167.279 -> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct;
167.280 -val it = SOME ("add_3_4","a + 3 + 4 = a + 7 [a + 3 + 4 = a + 7]")
167.281 -
167.282 -> val ct = (the o (parse thy)) "#3+(#4+a)";
167.283 -> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct;
167.284 -val it = SOME ("add_3_4","3 + (4 + a) = 7 + a [3 + (4 + a) = 7 + a]")
167.285 -
167.286 -> val ct = (the o (parse thy)) "a+(#3+#4)+#5";
167.287 -> get_calculation_ thy ("op +",the (assoc(!eval_list,"op +"))) ct;
167.288 -val it = SOME ("add_3_4","3 + 4 = 7 [3 + 4 = 7]") : (string * thm) option
167.289 -
167.290 -> val ct = (the o (parse thy)) "#3*(#4*a)";
167.291 -> get_calculation_ thy ("op *",the (assoc(!eval_list,"op *"))) ct;
167.292 -val it = SOME ("mult_3_4","3 * (4 * a) = 12 * a [3 * (4 * a) = 12 * a]")
167.293 -
167.294 -> val ct = (the o (parse thy)) "#3 + #4^^^#2 + #5";
167.295 -> get_calculation_ thy ("pow",the (assoc(!eval_list,"pow"))) ct;
167.296 -val it = SOME ("4_(+2)","4 ^ 2 = 16 [4 ^ 2 = 16]") : (string * thm) option
167.297 -
167.298 -> val ct = (the o (parse thy)) "#-4//#-2";
167.299 -> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct;
167.300 -val it = SOME ("cancel_(-4)_(-2)","(-4) // (-2) = (+2) [(-4) // (-2) = (+2)]")
167.301 -
167.302 -> val ct = (the o (parse thy)) "#6//#-8";
167.303 -> get_calculation_ thy ("cancel",the (assoc(!eval_list,"cancel"))) ct;
167.304 -val it = SOME ("cancel_6_(-8)","6 // (-8) = (-3) // 4 [6 // (-8) = (-3) // 4]")
167.305 -
167.306 -*)
167.307 -
167.308 -
167.309 -(*
167.310 -> val ct = (the o (parse thy)) "a + 3*4";
167.311 -> applicable "calculate" (Calc("op *", "mult_")) ct;
167.312 -val it = SOME "3 * 4 = 12 [3 * 4 = 12]" : thm option
167.313 -
167.314 ---------------------------
167.315 -> val ct = (the o (parse thy)) "3 =!= 3";
167.316 -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
167.317 -val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm
167.318 -
167.319 -> val ct = (the o (parse thy)) "~ (3 =!= 3)";
167.320 -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
167.321 -val thm = "(3 =!= 3) = True [(3 =!= 3) = True]" : thm
167.322 -
167.323 -> val ct = (the o (parse thy)) "3 =!= 4";
167.324 -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
167.325 -val thm = "(3 =!= 4) = False [(3 =!= 4) = False]" : thm
167.326 -
167.327 -> val ct = (the o (parse thy)) "( 4 + (4 * x + x ^ 2) =!= (+0))";
167.328 -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
167.329 - "(4 + (4 * x + x ^ 2) =!= (+0)) = False"
167.330 -
167.331 -> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))";
167.332 -> val (thmid, thm) = the (get_calculation_ thy "Atools.ident" ct);
167.333 - "(4 + (4 * x + x ^ 2) =!= (+0)) = False"
167.334 -
167.335 -> val ct = (the o (parse thy)) "~ ( 4 + (4 * x + x ^ 2) =!= (+0))";
167.336 -> val rls = eval_rls;
167.337 -> val (ct,_) = the (rewrite_set_ thy false rls ct);
167.338 -val ct = "True" : cterm
167.339 ---------------------------
167.340 -*)
167.341 -
167.342 -
167.343 -(*.get a thm applying an op_ to a term;
167.344 - apply ONLY to (numbers_to_string term), numbers_to_string (- 4711) --> (-4711).*)
167.345 -(* val (thy, (op_, eval_fn), ct) =
167.346 - (thy, ("Integrate.add'_new'_c", eval_add_new_c "add_new_c_"), term);
167.347 - *)
167.348 -fun get_calculation1_ thy ((op_, eval_fn):cal) ct =
167.349 - case eval_fn op_ ct thy of
167.350 - NONE => NONE
167.351 - | SOME (thmid,t) =>
167.352 - SOME (thmid, (make_thm o (cterm_of thy)) t);
167.353 -
167.354 -
167.355 -
167.356 -
167.357 -
167.358 -(*.substitute bdv in an rls and leave Calc as they are.(*28.10.02*)
167.359 -fun inst_thm' subs (Thm (id, thm)) =
167.360 - Thm (id, (*read_instantiate throws: *** No such variable in term: ?bdv*)
167.361 - (read_instantiate subs thm) handle _ => thm)
167.362 - | inst_thm' _ calc = calc;
167.363 -fun inst_thm' (subs as (bdv,_)::_) (Thm (id, thm)) =
167.364 - Thm (id, (writeln("@@@ inst_thm': thm= "^(string_of_thmI thm));
167.365 - if bdv mem (vars_str o #prop o rep_thm) thm
167.366 - then (writeln("@@@ inst_thm': read_instantiate, thm="^((string_of_thmI thm)));
167.367 - read_instantiate subs thm)
167.368 - else (writeln("@@@ inst_thm': not mem.. "^bdv);
167.369 - thm)))
167.370 - | inst_thm' _ calc = calc;
167.371 -
167.372 -fun instantiate_rls subs
167.373 - (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca,
167.374 - asm_thm=at,rules=rules,scr=scr}:rls) =
167.375 - (Rls{preconds=preconds,rew_ord=rew_ord,erls=ev,srls=sr,calc=ca,
167.376 - asm_thm=at,scr=scr,
167.377 - rules = map (inst_thm' subs) rules}:rls);---------------------------*)
167.378 -
167.379 -
167.380 -
167.381 -(** rewriting: ordered, conditional **)
167.382 -
167.383 -fun mk_rule (prems,l,r) =
167.384 - Trueprop $ (list_implies (prems, mk_equality (l,r)));
167.385 -
167.386 -(* 'norms' a rule, e.g.
167.387 -(*1*) a = 1 ==> a*(b+c) = b+c
167.388 - => a = 1 ==> a*(b+c) = b+c no change
167.389 -(*2*) t = t => (t=t) = True !!
167.390 -(*3*) [| k < l; m + l = k + n |] ==> m < n
167.391 - => [| k<l; m+l=k+n |] ==> m < n = True !! *)
167.392 -(* val it = fn : term -> term *)
167.393 -fun norm rule =
167.394 - let
167.395 - val (prems,concl)=(map strip_trueprop(Logic.strip_imp_prems rule),
167.396 - (strip_trueprop o Logic.strip_imp_concl)rule)
167.397 - in if is_equality concl then
167.398 - let val (l,r) = dest_equals' concl
167.399 - in if l = r then
167.400 - (*2*) mk_rule(prems,concl,true_as_term)
167.401 - else (*1*) rule end
167.402 - else (*3*) mk_rule(prems,concl,true_as_term)
167.403 - end;
167.404 -
167.405 -
167.406 -
167.407 -
167.408 -
167.409 -
167.410 -
167.411 -
168.1 --- a/src/Tools/isac/Scripts/rewrite.sml Wed Aug 25 15:15:01 2010 +0200
168.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
168.3 @@ -1,736 +0,0 @@
168.4 -(* isac's rewriter
168.5 - (c) Walther Neuper 2000
168.6 -
168.7 -use"Scripts/rewrite.sml";
168.8 -use"rewrite.sml";
168.9 -*)
168.10 -
168.11 -
168.12 -exception NO_REWRITE;
168.13 -exception STOP_REW_SUB; (*WN050820 quick and dirty*)
168.14 -
168.15 -(*17.6.00: rewrite by going down the term with rew_sub*)
168.16 -(* val (thy, i, bdv, tless, rls, put_asm, thm, ct) =
168.17 - (thy, 1, []:(Term.term * Term.term) list, rew_ord, erls, bool,thm,term);
168.18 - *)
168.19 -fun rewrite__ thy i bdv tless rls put_asm thm ct =
168.20 - ((*writeln ("@@@ r..te__ begin: t = "^(term2str ct));*)
168.21 - let
168.22 - val (t',asms,lrd,rew) =
168.23 - rew_sub thy i bdv tless rls put_asm [(*root of the term*)]
168.24 - (((inst_bdv bdv) o norm o #prop o rep_thm) thm) ct;
168.25 - in if rew then SOME (t', distinct asms)
168.26 - else NONE end)
168.27 -(* val(r,t)=(((inst_bdv bdv) o norm o #prop o rep_thm) thm,ct);
168.28 - val t1 = (#prop o rep_thm) thm;
168.29 - val t2 = norm t1;
168.30 - val t3 = inst_bdv bdv t2;
168.31 -
168.32 - val thm4 = read_instantiate [("bdv","x")] thm;
168.33 - val t4 = (norm o #prop o rep_thm) thm4;
168.34 - *)
168.35 -(* val (thy, i, bdv, tless, rls, put_asm, r, t) =
168.36 - (thy, i,bdv, tless, rls, put_asm,
168.37 - (((inst_bdv bdv) o norm o #prop o rep_thm) thm), ct);
168.38 - val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) =
168.39 - (thy, 1, [], ord, erls,false, [], r, t);
168.40 - val (thy, i, bdv, tless, rls, put_asm, lrd, r, t) =
168.41 - (thy, i, bdv, tless, rls, put_asm, [],
168.42 - ((inst_bdv bdv) o norm o #prop o rep_thm) thm, ct);
168.43 - *)
168.44 -and rew_sub thy i bdv tless rls put_asm lrd r t =
168.45 - ((*writeln ("@@@ rew_sub begin: t = "^(term2str t));*)
168.46 - let (* copy from Pure/thm.ML: fun rewritec *)
168.47 - (*val (lhs,rhs) = (dest_equals' o strip_trueprop
168.48 - o Logic.strip_imp_concl) r;
168.49 - val insts = Pattern.match (Sign.tsig_of (sign_of thy)) (lhs,t);
168.50 - val r' = ren_inst (insts, r, lhs, t);
168.51 - val p' = map strip_trueprop (Logic.strip_imp_prems r');
168.52 - val t' = (snd o dest_equals' o strip_trueprop
168.53 - o Logic.strip_imp_concl) r';*)
168.54 - val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop
168.55 - o Logic.strip_imp_concl) r;
168.56 - val r' = Envir.subst_term (Pattern.match thy (lhs, t)
168.57 - (Vartab.empty, Vartab.empty)) r;
168.58 - val p' = (fst o Logic.strip_prems) (Logic.count_prems r', [], r');
168.59 - val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop
168.60 - o Logic.strip_imp_concl) r';
168.61 - (*val _= writeln("@@@ rew_sub match: t'= "^(term2str t'));*)
168.62 - val _= if ! trace_rewrite andalso i < ! depth andalso p' <> []
168.63 - then writeln((idt"#"(i+1))^" eval asms: "^(term2str r')) else();
168.64 - val (t'',p'') = (*conditional rewriting*)
168.65 - let val (simpl_p', nofalse) = eval__true thy (i+1) p' bdv rls
168.66 - in if nofalse
168.67 - then (if ! trace_rewrite andalso i < ! depth andalso p' <> []
168.68 - then writeln((idt"#"(i+1))^" asms accepted: "^(terms2str p')^
168.69 - " stored: "^(terms2str simpl_p'))
168.70 - else(); (t',simpl_p')) (* + uncond.rew. *)
168.71 - else
168.72 - (if ! trace_rewrite andalso i < ! depth
168.73 - then writeln((idt"#"(i+1))^" asms false: "^(terms2str p'))
168.74 - else(); raise STOP_REW_SUB (*dont go into subterms of cond*))
168.75 - end
168.76 - in if perm lhs rhs andalso not (tless bdv (t',t)) (*ordered rewriting*)
168.77 - then (if ! trace_rewrite andalso i < ! depth
168.78 - then writeln((idt"#"i)^" not: \""^
168.79 - (term2str t)^"\" > \""^
168.80 - (term2str t')^"\"") else ();
168.81 - raise NO_REWRITE )
168.82 - else ((*writeln("##@ rew_sub: (t''= "^(term2str t'')^
168.83 - ", p'' ="^(terms2str p'')^", true)");*)
168.84 - (t'',p'',[],true))
168.85 - end
168.86 - ) handle _ (*NO_REWRITE WN050820 causes diff.behav. in tests + MATCH!*) =>
168.87 - ((*writeln ("@@@ rew_sub gosub: t = "^(term2str t));*)
168.88 - case t of
168.89 - Const(s,T) => (Const(s,T),[],lrd,false)
168.90 - | Free(s,T) => (Free(s,T),[],lrd,false)
168.91 - | Var(n,T) => (Var(n,T),[],lrd,false)
168.92 - | Bound i => (Bound i,[],lrd,false)
168.93 - | Abs(s,T,body) =>
168.94 - let val (t', asms, lrd, rew) =
168.95 - rew_sub thy i bdv tless rls put_asm (lrd@[D]) r body
168.96 - in (Abs(s,T,t'), asms, [], rew) end
168.97 - | t1 $ t2 =>
168.98 - let val (t2', asm2, lrd, rew2) =
168.99 - rew_sub thy i bdv tless rls put_asm (lrd@[R]) r t2
168.100 - in if rew2 then (t1 $ t2', asm2, lrd, true)
168.101 - else let val (t1', asm1, lrd, rew1) =
168.102 - rew_sub thy i bdv tless rls put_asm (lrd@[L]) r t1
168.103 - in if rew1 then (t1' $ t2, asm1, lrd, true)
168.104 - else (t1 $ t2,[], lrd, false) end
168.105 - end)
168.106 -(* val (cprems',rls)=([pre],prls);
168.107 - rewrite__set_ thy i false rls pre;
168.108 - *)
168.109 -and eval__true thy i asms bdv rls =
168.110 -(* val (thy, i, asms, bdv, rls) = (thy, (i+1), p', bdv, rls);
168.111 - *)
168.112 - if asms = [HOLogic.true_const] orelse asms = []
168.113 - then ([], true) else if asms = [HOLogic.false_const] then ([], false)
168.114 - else let
168.115 - fun chk indets [] = (indets, true)(*return asms<>True until false*)
168.116 - | chk indets (a::asms) =
168.117 -(* val (indets, (a::asms)) = ([], asms);
168.118 - *)
168.119 - (case rewrite__set_ thy (i+1) false bdv rls a of
168.120 - NONE => (chk (indets @ [a]) asms)
168.121 - | SOME (t, a') =>
168.122 - if t = HOLogic.true_const
168.123 - then (chk (indets @ a') asms)
168.124 - else if t = HOLogic.false_const then ([], false)
168.125 - (*asm false .. thm not applied ^^^; continue until False vvv*)
168.126 - else (chk (indets @ [t] @ a') asms));
168.127 - in chk [] asms end
168.128 -
168.129 -and rewrite__set_ _ _ __ Erls t =
168.130 - raise error("rewrite__set_ called with 'Erls' for '"^term2str t^"'")
168.131 - | rewrite__set_ thy i _ _ (rrls as Rrls _) t =
168.132 - let val _= if ! trace_rewrite andalso i < ! depth
168.133 - then writeln ((idt"#"i)^" rls: "^(id_rls rrls)^" on: "^
168.134 - (term2str t)) else ()
168.135 - val (t', asm, rew) = app_rev thy (i+1) rrls t
168.136 - in if rew then SOME (t', distinct asm)
168.137 - else NONE end
168.138 - | rewrite__set_ thy i put_asm bdv rls ct =
168.139 -(* val (thy, i, put_asm, bdv, rls, ct) = (thy, 1, bool, [], rls, term);
168.140 - *)
168.141 - let
168.142 - datatype switch = Appl | Noap;
168.143 - fun rew_once ruls asm ct Noap [] = (ct,asm)
168.144 - | rew_once ruls asm ct Appl [] =
168.145 - (case rls of Rls _ => rew_once ruls asm ct Noap ruls
168.146 - | Seq _ => (ct,asm))
168.147 - | rew_once ruls asm ct apno (rul::thms) =
168.148 -(* val (ruls, asm, ct, apno, (rul::thms)) = (ruls, [], ct, Noap, ruls);
168.149 - val Thm (thmid, thm) = rul;
168.150 - *)
168.151 - case rul of
168.152 - Thm (thmid, thm) =>
168.153 - (if !trace_rewrite andalso i < ! depth
168.154 - then writeln((idt"#"(i+1))^" try thm: "^thmid) else ();
168.155 - case rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
168.156 - ((#erls o rep_rls) rls) put_asm thm ct of
168.157 - NONE => rew_once ruls asm ct apno thms
168.158 - | SOME (ct',asm') => (if ! trace_rewrite andalso i < ! depth
168.159 - then writeln((idt"="(i+1))^" rewrites to: "^
168.160 - (term2str ct')) else ();
168.161 - rew_once ruls (union (op =) asm asm') ct' Appl (rul::thms)))
168.162 - | Calc (cc as (op_,_)) =>
168.163 - (let val _= if !trace_rewrite andalso i < ! depth then
168.164 - writeln((idt"#"(i+1))^" try calc: "^op_^"'") else ();
168.165 - val ct = uminus_to_string ct
168.166 - in case get_calculation_ thy cc ct of
168.167 - NONE => ((*writeln "@@@ rewrite__set_: get_calculation_-> NONE";*)
168.168 - rew_once ruls asm ct apno thms)
168.169 - | SOME (thmid, thm') =>
168.170 - let
168.171 - val pairopt =
168.172 - rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
168.173 - ((#erls o rep_rls) rls) put_asm thm' ct;
168.174 - val _ = if pairopt <> NONE then ()
168.175 - else raise error("rewrite_set_, rewrite_ \""^
168.176 - (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE")
168.177 - val _ = if ! trace_rewrite andalso i < ! depth
168.178 - then writeln((idt"="(i+1))^" calc. to: "^
168.179 - (term2str ((fst o the) pairopt)))
168.180 - else()
168.181 - in rew_once ruls asm ((fst o the) pairopt) Appl(rul::thms) end
168.182 - end)
168.183 -(* use"Scripts/rewrite.sml";
168.184 - @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
168.185 - | Cal1 (cc as (op_,_)) =>
168.186 - (let val _= if !trace_rewrite andalso i < ! depth then
168.187 - writeln((idt"#"(i+1))^" try cal1: "^op_^"'") else ();
168.188 - val ct = uminus_to_string ct
168.189 - in case get_calculation1_ thy cc ct of
168.190 - NONE => (ct, asm)
168.191 - | SOME (thmid, thm') =>
168.192 - let
168.193 - val pairopt =
168.194 - rewrite__ thy (i+1) bdv ((snd o #rew_ord o rep_rls) rls)
168.195 - ((#erls o rep_rls) rls) put_asm thm' ct;
168.196 - val _ = if pairopt <> NONE then ()
168.197 - else raise error("rewrite_set_, rewrite_ \""^
168.198 - (string_of_thmI thm')^"\" "^(term2str ct)^" = NONE")
168.199 - val _ = if ! trace_rewrite andalso i < ! depth
168.200 - then writeln((idt"="(i+1))^" cal1. to: "^
168.201 - (term2str ((fst o the) pairopt)))
168.202 - else()
168.203 - in the pairopt end
168.204 - end)
168.205 -(*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
168.206 - | Rls_ rls' =>
168.207 - (case rewrite__set_ thy (i+1) put_asm bdv rls' ct of
168.208 - SOME (t',asm') => rew_once ruls (union (op =) asm asm') t' Appl thms
168.209 - | NONE => rew_once ruls asm ct apno thms);
168.210 -
168.211 - val ruls = (#rules o rep_rls) rls;
168.212 - val _= if ! trace_rewrite andalso i < ! depth
168.213 - then writeln ((idt"#"i)^" rls: "^(id_rls rls)^" on: "^
168.214 - (term2str ct)) else ()
168.215 - val (ct',asm') = rew_once ruls [] ct Noap ruls;
168.216 - in if ct = ct' then NONE else SOME (ct', distinct asm') end
168.217 -
168.218 -and app_rev thy i rrls t =
168.219 - let (*.check a (precond, pattern) of a rev-set; stops with 1st true.*)
168.220 - fun chk_prepat thy erls [] t = true
168.221 - | chk_prepat thy erls prepat t =
168.222 - let fun chk (pres, pat) =
168.223 - (let val subst: Type.tyenv * Envir.tenv =
168.224 - Pattern.match thy (pat, t)
168.225 - (Vartab.empty, Vartab.empty)
168.226 - in snd (eval__true thy (i+1)
168.227 - (map (Envir.subst_term subst) pres)
168.228 - [] erls)
168.229 - end)
168.230 - handle _ => false
168.231 - fun scan_ f [] = false (*scan_ NEVER called by []*)
168.232 - | scan_ f (pp::pps) = if f pp then true
168.233 - else scan_ f pps;
168.234 - in scan_ chk prepat end;
168.235 -
168.236 - (*.apply the normal_form of a rev-set.*)
168.237 - fun app_rev' thy (Rrls{erls,prepat,scr=Rfuns{normal_form,...},...}) t =
168.238 - if chk_prepat thy erls prepat t
168.239 - then ((*writeln("### app_rev': t = "^(term2str t));*)
168.240 - normal_form t)
168.241 - else NONE;
168.242 -
168.243 - val opt = app_rev' thy rrls t
168.244 - in case opt of
168.245 - SOME (t', asm) => (t', asm, true)
168.246 - | NONE => app_sub thy i rrls t
168.247 - end
168.248 -and app_sub thy i rrls t =
168.249 - ((*writeln("### app_sub: subterm = "^(term2str t));*)
168.250 - case t of
168.251 - Const (s, T) => (Const(s, T), [], false)
168.252 - | Free (s, T) => (Free(s, T), [], false)
168.253 - | Var (n, T) => (Var(n, T), [], false)
168.254 - | Bound i => (Bound i, [], false)
168.255 - | Abs (s, T, body) =>
168.256 - let val (t', asm, rew) = app_rev thy i rrls body
168.257 - in (Abs(s, T, t'), asm, rew) end
168.258 - | t1 $ t2 =>
168.259 - let val (t2', asm2, rew2) = app_rev thy i rrls t2
168.260 - in if rew2 then (t1 $ t2', asm2, true)
168.261 - else let val (t1', asm1, rew1) = app_rev thy i rrls t1
168.262 - in if rew1 then (t1' $ t2, asm1, true)
168.263 - else (t1 $ t2, [], false) end
168.264 - end);
168.265 -
168.266 -
168.267 -
168.268 -(*.rewriting without argument [] for rew_ord.*)
168.269 -(*WN.11.6.03: shouldnt asm<>[] lead to false ????*)
168.270 -fun eval_true thy terms rls = (snd o (eval__true thy 1 terms [])) rls;
168.271 -
168.272 -
168.273 -(*.rewriting without internal argument [] for rew_ord.*)
168.274 -(* val (thy, rew_ord, erls, bool, thm, term) =
168.275 - (thy, (assoc_rew_ord ro), rls', false, (assoc_thm' thy thm'), f);
168.276 - val (thy, rew_ord, erls, bool, thm, term) =
168.277 - (thy, rew_ord, erls, false, thm, t'');
168.278 - *)
168.279 -fun rewrite_ thy rew_ord erls bool thm term =
168.280 - rewrite__ thy 1 [] rew_ord erls bool thm term;
168.281 -fun rewrite_set_ thy bool rls term =
168.282 -(* val (thy, bool, rls, term) = (thy, false, srls, t);
168.283 - *)
168.284 - rewrite__set_ thy 1 bool [] rls term;
168.285 -
168.286 -
168.287 -fun subs'2subst thy (s:subs') =
168.288 - (((map (apfst (term_of o the o (parse thy))))
168.289 - o (map (apsnd (term_of o the o (parse thy))))) s):subst;
168.290 -
168.291 -(*.variants of rewrite.*)
168.292 -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst,
168.293 - thus the argument put_asm IS NOT NECESSARY -- FIXME*)
168.294 -(* val (rew_ord,rls,put_asm,thm,ct)=
168.295 - (e_rew_ord,poly_erls,false,num_str d1_isolate_add2,t);
168.296 - *)
168.297 -fun rewrite_inst_ (thy:theory) rew_ord (rls:rls) (put_asm:bool)
168.298 - (subst:(term * term) list) (thm:thm) (ct:term) =
168.299 - rewrite__ thy 1 subst rew_ord rls put_asm thm ct;
168.300 -
168.301 -fun rewrite_set_inst_ (thy:theory)
168.302 - (put_asm:bool) (subst:(term * term) list) (rls:rls) (ct:term) =
168.303 - (*let
168.304 - val subst = subs'2subst thy subs';
168.305 - val subrls = instantiate_rls subs' rls
168.306 - in*) rewrite__set_ thy 1 put_asm subst (*sub*)rls ct
168.307 - (*end*);
168.308 -
168.309 -(* val (thy, ord, erls, subte, t) = (thy, dummy_ord, Erls, subte, t);
168.310 - *)
168.311 -(*.rewrite using a list of terms.*)
168.312 -fun rewrite_terms_ thy ord erls subte t =
168.313 - let (*val _=writeln("### rewrite_terms_ subte= '"^terms2str subte^"' ..."^
168.314 - term_detail2str (hd subte)^
168.315 - "### rewrite_terms_ t= '"^term2str t^"' ..."^
168.316 - term_detail2str t);*)
168.317 - fun rew_ (t', asm') [] _ = (t', asm')
168.318 - (* 1st val (t', asm', rules as r::rs, t) = (e_term, [], subte, t);
168.319 - 2nd val (t', asm', rules as r::rs, t) = (t'', [], rules, t'');
168.320 - rew_ (t', asm') (r::rs) t;
168.321 - *)
168.322 - | rew_ (t', asm') (rules as r::rs) t =
168.323 - let val _ = writeln("rew_ "^term2str t);
168.324 - val (t'', asm'', lrd, rew) =
168.325 - rew_sub thy 1 [] ord erls false [] r t
168.326 - in if rew
168.327 - then (writeln("true rew_ "^term2str t'');
168.328 - rew_ (t'', asm' @ asm'') rules t'')
168.329 - else (writeln("false rew_ "^term2str t'');
168.330 - rew_ (t', asm') rs t')
168.331 - end
168.332 - val (t'', asm'') = rew_ (e_term, []) subte t
168.333 - in if t'' = e_term
168.334 - then NONE else SOME (t'', asm'')
168.335 - end;
168.336 -
168.337 -
168.338 -(*. search ct for adjacent numerals and calculate them by operator isa_fn .*)
168.339 -fun calculate_ thy isa_fn ct =
168.340 - let val ct = uminus_to_string ct
168.341 - in case get_calculation_ thy isa_fn ct of
168.342 - NONE => NONE
168.343 - | SOME (thmID, thm) =>
168.344 - (let val SOME (rew,_) = rewrite_ thy dummy_ord e_rls false thm ct
168.345 - in SOME (rew,(thmID, thm)) end)
168.346 - handle _ => error ("calculate_: "^thmID^" does not rewrite")
168.347 - end;
168.348 -(*
168.349 -> val thy = InsSort.thy;
168.350 -> val op_ = "le"; (* < *)
168.351 -> val ct = (the o (parse thy))
168.352 - "foldr ins [#2] (if #1 < #3 then #1 # ins [] #3 else [#3, #1])";
168.353 -> calculate_ thy op_ ct;
168.354 - SOME
168.355 - ("foldr ins [#2] (if True then #1 # ins [] #3 else [#3, #1])",
168.356 - "(#1 < #3) = True") : (cterm * thm) option *)
168.357 -
168.358 -
168.359 -(* for test-printouts:
168.360 -val _ = writeln("in rew_sub : "^( Syntax.string_of_term (thy2ctxt thy) t))
168.361 -val _ = writeln("in eval_true: prems= "^(commas (map (Syntax.string_of_term (thy2ctxt thy)) prems')))
168.362 -*)
168.363 -
168.364 -
168.365 -
168.366 -
168.367 -
168.368 -
168.369 -fun get_rls_scr rs' = ((#scr o rep_rls o #2 o the o assoc') (!ruleset',rs'))
168.370 - handle _ => raise error ("get_rls_scr: no script for "^rs');
168.371 -
168.372 -
168.373 -(*make_thm added to Pure/thm.ML*)
168.374 -fun mk_thm thy str =
168.375 - let val t = (term_of o the o (parse thy)) str
168.376 - val t' = case t of
168.377 - Const ("==>",_) $ _ $ _ => t
168.378 - | _ => Trueprop $ t
168.379 - in make_thm (cterm_of thy t') end;
168.380 -(*
168.381 - val str = "?r ^^^ 2 = ?r * ?r";
168.382 - val thm = realpow_twoI;
168.383 -
168.384 - val t1 = (#prop o rep_thm) (num_str thm);
168.385 - val t2 = Trueprop $ ((term_of o the o (parse thy)) str);
168.386 - t1 = t2;
168.387 -val it = true : bool ... !!!
168.388 - val th1 = (num_str thm);
168.389 - val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e;
168.390 - th1 = th2;
168.391 -ML> val it = false : bool ... HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?!
168.392 -
168.393 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168.394 - val str = "k ~= 0 ==> m * k / (n * k) = m / n";
168.395 - val thm = real_mult_div_cancel2;
168.396 -
168.397 - val t1 = (#prop o rep_thm) (num_str thm);
168.398 - val t2 = ((term_of o the o (parse thy)) str);
168.399 - t1 = t2;
168.400 -val it = false : bool ... Var .. Free
168.401 - val th1 = (num_str thm);
168.402 - val th2 = ((*num_str*) (mk_thm thy str)) handle e => print_exn e;
168.403 - th1 = th2;
168.404 -ML> val it = false : bool ... PLUS HIDDEN DIFFERENCES IRRELEVANT FOR ISAC ?!
168.405 -*)
168.406 -
168.407 -
168.408 -(*prints subgoal etc.
168.409 -((goal thy);(topthm()) o ) str; *)
168.410 -(*assume rejects scheme variables
168.411 - assume ((cterm_of thy) (Trueprop $
168.412 - (term_of o the o (parse thy)) str)); *)
168.413 -
168.414 -
168.415 -(* outcommented 18.11.xx, xx < 02 -------
168.416 -fun rul2rul' (Thm (thmid, thm)) = Thm'(thmid, string_of_thmI thm)
168.417 - | rul2rul' (Calc op_) = Calc' op_;
168.418 -fun rul'2rul thy (Thm'(thmid, ct')) =
168.419 - Thm (thmid, mk_thm thy ct')
168.420 - | rul'2rul thy' (Calc' op_) = Calc op_;
168.421 -
168.422 -
168.423 -fun rls2rls' (Rls{preconds=preconds,rew_ord=rew_ord,rules=rules}:rls) =
168.424 - Rls'{preconds'= map string_of_cterm preconds,
168.425 - rew_ord' = fst rew_ord,
168.426 - rules' = map rul2rul' rules}:rlsdat';
168.427 -
168.428 -fun rls'2rls thy' (Rls'{preconds'=preconds,rew_ord'=rew_ord,
168.429 - rules'=rules}:rlsdat') =
168.430 - let val thy = the (assoc' (theory',thy'))
168.431 - in Rls{preconds = map (the o (parse thy)) preconds,
168.432 - rew_ord = (rew_ord, the (assoc'(rew_ord',rew_ord))),
168.433 - rules = map (rul'2rul thy) rules}:rls end;
168.434 -------- *)
168.435 -
168.436 -(*.get the theorem associated with the xstring-identifier;
168.437 - if the identifier starts with "sym_" then swap lhs = rhs around =
168.438 - (ATTENTION: "RS sym" attaches a [.] -- remove it with string_of_thmI);
168.439 - identifiers starting with "#" come from Calc and
168.440 - get a hand-made theorem (containing numerals only).*)
168.441 -fun assoc_thm' (thy:theory) ((thmid, ct'):thm') =
168.442 - (case explode thmid of
168.443 - "s"::"y"::"m"::"_"::id =>
168.444 - if hd id = "#"
168.445 - then mk_thm thy ct'
168.446 - else ((num_str o (PureThy.get_thm thy)) (implode id)) RS sym
168.447 - | id =>
168.448 - if hd id = "#"
168.449 - then mk_thm thy ct'
168.450 - else (num_str o (PureThy.get_thm thy)) thmid
168.451 - ) handle _ =>
168.452 - raise error ("assoc_thm': '"^thmid^"' not in '"^
168.453 - (theory2domID thy)^"' (and parents)");
168.454 -(*> assoc_thm' Isac.thy ("sym_#mult_2_3","6 = 2 * 3");
168.455 -val it = "6 = 2 * 3" : thm
168.456 -
168.457 -> assoc_thm' Isac.thy ("real_add_zero_left","");
168.458 -val it = "0 + ?z = ?z" : thm
168.459 -
168.460 -> assoc_thm' Isac.thy ("sym_real_add_zero_left","");
168.461 -val it = "?t = 0 + ?t" [.] : thm
168.462 -
168.463 -> assoc_thm' HOL.thy ("sym_real_add_zero_left","");
168.464 -*** Unknown theorem(s) "real_add_zero_left"
168.465 -*** assoc_thm': 'sym_real_add_zero_left' not in 'HOL.thy' (and parents)
168.466 - uncaught exception ERROR*)
168.467 -
168.468 -
168.469 -fun parse' (thy:theory') (ct:cterm') =
168.470 - case parse ((the o assoc')(!theory',thy)) ct of
168.471 - NONE => NONE
168.472 - | SOME ct => SOME ((term2str (term_of ct)):cterm');
168.473 -
168.474 -
168.475 -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
168.476 - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
168.477 -fun rewrite (thy':theory') (rew_ord:rew_ord') (rls:rls')
168.478 - (put_asm:bool) (thm:thm') (ct:cterm') =
168.479 -(* val (rew_ord, rls, thm, ct) = (rew_ord', id_rls rls', thm', f);
168.480 - *)
168.481 - let val thy = (the o assoc')(!theory',thy');
168.482 - in
168.483 - case rewrite_ thy
168.484 - ((the o assoc')(!rew_ord',rew_ord))((#2 o the o assoc')(!ruleset',rls))
168.485 - put_asm ((assoc_thm' thy) thm)
168.486 - ((term_of o the o (parse thy)) ct) of
168.487 - NONE => NONE
168.488 - | SOME (t, ts) => SOME (term2str t, terms2str ts)
168.489 - end;
168.490 -
168.491 -(*
168.492 -val thy = "RatArith.thy";
168.493 -val rew_ord = "dummy_ord";
168.494 -> val rls = "eval_rls";
168.495 -val put_asm = true;
168.496 -val thm = ("square_equation_left","");
168.497 -val ct = "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
168.498 -
168.499 -val Zthy = ((the o assoc')(!theory',thy));
168.500 -val Zrew_ord = ((the o assoc')(!rew_ord',rew_ord));
168.501 -val Zrls = ((the o assoc')(!ruleset',rls));
168.502 -val Zput_asm = put_asm;
168.503 -val Zthm = ((the o (assoc'_thm' thy)) thm);
168.504 -val Zct = ((the o (parse ((the o assoc')(!theory',thy)))) ct);
168.505 -
168.506 -rewrite_ Zthy Zrew_ord Zrls Zput_asm Zthm Zct;
168.507 -
168.508 - use"Isa99/interface_ME_ISA.sml";
168.509 -*)
168.510 -
168.511 -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
168.512 - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
168.513 -fun rewrite_set (thy':theory') (put_asm:bool)
168.514 - (rls:rls') (ct:cterm') =
168.515 - let val thy = (the o assoc')(!theory',thy');
168.516 - in
168.517 - case rewrite_set_ thy put_asm ((#2 o the o assoc')(!ruleset',rls))
168.518 - ((term_of o the o (parse thy)) ct) of
168.519 - NONE => NONE
168.520 - | SOME (t, ts) => SOME (term2str t, terms2str ts)
168.521 - end;
168.522 -
168.523 -(*evaluate list-expressions
168.524 - should work on term, and stand in Isa99/rewrite-parse.sml,
168.525 - but there list_rls <- eval_binop is not yet defined*)
168.526 -(*fun eval_listexpr' ct =
168.527 - let val rew = rewrite_set "ListG.thy" false "list_rls" ct;
168.528 - in case rew of
168.529 - SOME (res,_) => res
168.530 - | NONE => ct end;-----------------30.9.02---*)
168.531 -fun eval_listexpr_ thy srls t =
168.532 -(* val (thy, srls, t) =
168.533 - ((assoc_thy th), sr, (subst_atomic (upd_env_opt E (a,v)) t));
168.534 - *)
168.535 - let val rew = rewrite_set_ thy false srls t;
168.536 - in case rew of
168.537 - SOME (res,_) => res
168.538 - | NONE => t end;
168.539 -
168.540 -
168.541 -fun get_calculation' (thy:theory') op_ (ct:cterm') =
168.542 - case get_calculation_ ((the o assoc')(!theory',thy)) op_
168.543 - ((uminus_to_string o term_of o the o
168.544 - (parse ((the o assoc')(!theory',thy)))) ct) of
168.545 - NONE => NONE
168.546 - | SOME (thmid, thm) =>
168.547 - SOME ((thmid, string_of_thmI thm):thm');
168.548 -
168.549 -fun calculate (thy':theory') op_ (ct:cterm') =
168.550 - let val thy = (the o assoc')(!theory',thy');
168.551 - in
168.552 - case calculate_ thy op_
168.553 - ((term_of o the o (parse thy)) ct) of
168.554 - NONE => NONE
168.555 - | SOME (ct,(thmID,thm)) =>
168.556 - SOME (term2str ct,
168.557 - (thmID, string_of_thmI thm):thm')
168.558 - end;
168.559 -(*
168.560 -fun instantiate'' thy' subs ((thmid,ct'):thm') =
168.561 - let val thmid_ = implode ("#"::(explode thmid)) (*see type thm'*)
168.562 - in (thmid_, (string_of_thmI o (read_instantiate subs))
168.563 - ((the o (assoc_thm' thy')) (thmid_,ct'))):thm' end;
168.564 -
168.565 -fun instantiate_rls' thy' subs (rls:rls') =
168.566 - rls2rls' (instantiate_rls subs ((the o (assoc_rls thy')) rls)):rlsdat';
168.567 -
168.568 -... problem with these functions:
168.569 -> val thm = mk_thm thy "(bdv + a = b) = (bdv = b - a)";
168.570 -val thm = "(bdv + a = b) = (bdv = b - a)" : thm
168.571 -> show_types:=true; thm;
168.572 -val it = "((bdv::'a) + (a::'a) = (b::'a)) = (bdv = b - a)" : thm
168.573 -... and this doesn't match because of too general typing (?!)
168.574 - and read_insitantiate doesn't instantiate the types (?!)
168.575 -=== solutions:
168.576 -(1) hard-coded type-instantiation ("'a", "RatArith.rat")
168.577 -(2) instantiate', instantiate ... no help by isabelle-users@ !!!
168.578 -=== conclusion:
168.579 - rewrite_inst, rewrite_set_inst circumvent the problem,
168.580 - according functions out-commented with 'instantiate''
168.581 -*)
168.582 -
168.583 -(* instantiate''
168.584 -fun instantiate'' thy' subs ((thmid,ct'):thm') =
168.585 - let
168.586 - val thmid_ = implode ("#"::(explode thmid)); (*see type thm'*)
168.587 - val thy = (the o assoc')(!theory',thy');
168.588 - val typs = map (#T o rep_cterm o the o (parse thy))
168.589 - ((snd o split_list) subs);
168.590 - val ctyps = map
168.591 - ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o (parse thy))
168.592 - ((snd o split_list) subs);
168.593 -
168.594 -> val thy' = "RatArith.thy";
168.595 -> val subs = [("bdv","x::rat"),("zzz","z::nat")];
168.596 -> (the o (parse ((the o assoc')(!theory',thy')))) "x::rat";
168.597 -> (#T o rep_cterm o the o (parse ((the o assoc')(!theory',thy'))));
168.598 -
168.599 -> val ctyp = ((ctyp_of (sign_of thy)) o #T o rep_cterm o the o
168.600 - (parse ((the o assoc')(!theory',thy')))) "x::rat";
168.601 -> val bdv = (the o (parse thy)) "bdv";
168.602 -> val x = (the o (parse thy)) "x";
168.603 -> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add)
168.604 - handle e => print_exn e;
168.605 -uncaught exception THM
168.606 - raised at: thm.ML:1085.18-1085.69
168.607 - thm.ML:1092.34
168.608 - goals.ML:536.61
168.609 -
168.610 -> val bdv = (the o (parse thy)) "bdv::nat";
168.611 -> val x = (the o (parse thy)) "x::nat";
168.612 -> (instantiate ([(("'a",0),ctyp)],[(bdv,x)]) isolate_bdv_add)
168.613 - handle e => print_exn e;
168.614 -uncaught exception THM
168.615 - raised at: thm.ML:1085.18-1085.69
168.616 - thm.ML:1092.34
168.617 - goals.ML:536.61
168.618 -
168.619 -> (instantiate' [SOME ctyp] [] isolate_bdv_add)
168.620 - handle e => print_exn e;
168.621 -uncaught exception TYPE
168.622 - raised at: drule.ML:613.13-615.44
168.623 - goals.ML:536.61
168.624 -
168.625 -> val repct = (rep_cterm o the o (parse ((the o assoc')(!theory',thy')))) "x::rat";
168.626 -*)
168.627 -
168.628 -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
168.629 - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
168.630 -fun rewrite_inst (thy':theory') (rew_ord:rew_ord') (rls:rls')
168.631 - (put_asm:bool) subs (thm:thm') (ct:cterm') =
168.632 - let
168.633 - val thy = (the o assoc')(!theory',thy');
168.634 - val thm = assoc_thm' thy thm; (*28.10.02*)
168.635 - (*val subthm = read_instantiate subs ((assoc_thm' thy) thm)*)
168.636 - in
168.637 - case rewrite_ thy
168.638 - ((the o assoc')(!rew_ord',rew_ord)) ((#2 o the o assoc')(!ruleset',rls))
168.639 - put_asm (*sub*)thm ((term_of o the o (parse thy)) ct) of
168.640 - NONE => NONE
168.641 - | SOME (ctm, ctms) =>
168.642 - SOME ((term2str ctm):cterm', (map term2str ctms):cterm' list)
168.643 - end;
168.644 -
168.645 -(*FIXME 12.8.02: put_asm = true <==> rewrite_inst, rewrite_set_inst
168.646 - thus the argument put_asm IS NOT NECESSARY -- FIXME ~~~~~*)
168.647 -fun rewrite_set_inst (thy':theory') (put_asm:bool)
168.648 - subs' (rls:rls') (ct:cterm') =
168.649 - let
168.650 - val thy = (the o assoc')(!theory',thy');
168.651 - val rls = assoc_rls rls
168.652 - val subst = subs'2subst thy subs'
168.653 - (*val subrls = instantiate_rls subs ((the o assoc')(!ruleset',rls))*)
168.654 - in case rewrite_set_inst_ thy put_asm subst (*sub*)rls
168.655 - ((term_of o the o (parse thy)) ct) of
168.656 - NONE => NONE
168.657 - | SOME (t, ts) => SOME (term2str t, terms2str ts)
168.658 - end;
168.659 -
168.660 -
168.661 -(*vor check_elementwise: SqRoot_eval_rls .. wie *_simplify ?! TODO *)
168.662 -fun eval_true' (thy':theory') (rls':rls') (Const ("True",_)) = true
168.663 -
168.664 - | eval_true' (thy':theory') (rls':rls') (t:term) =
168.665 -(* val thy'="Isac.thy"; val rls'="eval_rls"; val t=hd pres';
168.666 - *)
168.667 - let val ct' = term2str t;
168.668 - in case rewrite_set thy' false rls' ct' of
168.669 - SOME ("True",_) => true
168.670 - | _ => false
168.671 - end;
168.672 -fun eval_true_ _ _ (Const ("True",_)) = true
168.673 - | eval_true_ (thy':theory') rls t =
168.674 - case rewrite_set_ (assoc_thy thy') false rls t of
168.675 - SOME (Const ("True",_),_) => true
168.676 - | _ => false;
168.677 -
168.678 -(*
168.679 -val test_rls =
168.680 - Rls{preconds = [], rew_ord = ("sqrt_right",sqrt_right),
168.681 - rules = [Calc ("matches",eval_matches "")
168.682 - ],
168.683 - scr = Script ((term_of o the o (parse thy))
168.684 - "empty_script")
168.685 - }:rls;
168.686 -
168.687 -
168.688 -
168.689 - rewrite_set_ Isac.thy eval_rls false test_rls
168.690 - ((the o (parse thy)) "matches (?a = ?b) (x = #0)");
168.691 - val xxx = (term_of o the o (parse thy))
168.692 - "matches (?a = ?b) (x = #0)";
168.693 - eval_matches """" xxx thy;
168.694 -SOME ("matches (?a = ?b) (x + #1 + #-1 * #2 = #0) = True",
168.695 - Const ("Trueprop","bool => prop") $ (Const # $ (# $ #) $ Const (#,#)))
168.696 -
168.697 -
168.698 -
168.699 - rewrite_set_ Isac.thy eval_rls false eval_rls
168.700 - ((the o (parse thy)) "contains_root (sqrt #0)");
168.701 -val it = SOME ("True",[]) : (cterm * cterm list) option
168.702 -
168.703 -*)
168.704 -
168.705 -
168.706 -(*----------WN:16.5.03 stuff below considered illdesigned, thus coded from scratch in appl.sml fun check_elementwise
168.707 -datatype det = TRUE | FALSE | INDET;(*FIXXME.WN:16.5.03
168.708 - introduced with quick-and-dirty code*)
168.709 -fun determine dts =
168.710 - let val false_indet =
168.711 - filter_out ((curry op= TRUE) o (#1:det * term -> det)) dts
168.712 - val ts = map (#2: det * term -> term) dts
168.713 - in if nil = false_indet then (TRUE, ts)
168.714 - else if nil = filter ((curry op= FALSE) o (#1:det * term -> det))
168.715 - false_indet
168.716 - then (INDET, ts)
168.717 - else (FALSE, ts) end;
168.718 -(* val dts = [(INDET,e_term), (FALSE,HOLogic.false_const),
168.719 - (INDET,e_term), (TRUE,HOLogic.true_const)];
168.720 - determine dts;
168.721 -val it =
168.722 - (FALSE,
168.723 - [Const ("empty","'a"),Const ("False","bool"),Const ("empty","'a"),
168.724 - Const ("True","bool")]) : det * term list*)
168.725 -
168.726 -fun eval__indet_ thy cs rls = (*FIXXME.WN:16.5.03 pull into eval__true_, update check (check_elementwise), and regard eval_true_ + eval_true*)
168.727 -if cs = [HOLogic.true_const] orelse cs = [] then (TRUE, [])
168.728 - else if cs = [HOLogic.false_const] then (FALSE, cs)
168.729 - else
168.730 - let fun eval t =
168.731 - let val taopt = rewrite__set_ thy 1 false [] rls t
168.732 - in case taopt of
168.733 - SOME (t,_) =>
168.734 - if t = HOLogic.true_const then (TRUE, t)
168.735 - else if t = HOLogic.false_const then (FALSE, t)
168.736 - else (INDET, t)
168.737 - | NONE => (INDET, t) end
168.738 - in (determine o (map eval)) cs end;
168.739 -WN.16.5.0-------------------------------------------------------------*)
169.1 --- a/src/Tools/isac/Scripts/scrtools.sml Wed Aug 25 15:15:01 2010 +0200
169.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
169.3 @@ -1,491 +0,0 @@
169.4 -(* tools which depend on Script.thy and thus are not in term_G.sml
169.5 - (c) Walther Neuper 2000
169.6 -
169.7 -use"Scripts/scrtools.sml";
169.8 -use"scrtools.sml";
169.9 -*)
169.10 -
169.11 -
169.12 -fun is_reall_dsc
169.13 - (Const(_,Type("fun",[Type("List.list",
169.14 - [Type ("real",[])]),_]))) = true
169.15 - | is_reall_dsc
169.16 - (Const(_,Type("fun",[Type("List.list",
169.17 - [Type ("real",[])]),_])) $ t) = true
169.18 - | is_reall_dsc _ = false;
169.19 -fun is_booll_dsc
169.20 - (Const(_,Type("fun",[Type("List.list",
169.21 - [Type ("bool",[])]),_]))) = true
169.22 - | is_booll_dsc
169.23 - (Const(_,Type("fun",[Type("List.list",
169.24 - [Type ("bool",[])]),_])) $ t) = true
169.25 - | is_booll_dsc _ = false;
169.26 -(*
169.27 -> val t = (term_of o the o (parse thy)) "relations";
169.28 -> atomtyp (type_of t);
169.29 -*** Type (fun,[
169.30 -*** Type (List.list,[
169.31 -*** Type (bool,[])
169.32 -*** ]
169.33 -*** Type (Tools.una,[])
169.34 -*** ]
169.35 -> is_booll_dsc t;
169.36 -val it = true : bool
169.37 -> is_reall_dsc t;
169.38 -val it = false : bool
169.39 -*)
169.40 -
169.41 -fun is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_]))) = true
169.42 - | is_list_dsc (Const(_,Type("fun",[Type("List.list",_),_])) $ t) = true
169.43 - (*WN:8.5.03: ??? ~~~~ ???*)
169.44 - | is_list_dsc _ = false;
169.45 -(*
169.46 -> val t = str2term "someList";
169.47 -> is_list_dsc t;
169.48 -val it = true : bool
169.49 -
169.50 -> val t = (term_of o the o (parse thy))
169.51 - "additional_relations [a=b,c=(d::real)]";
169.52 -> is_list_dsc t;
169.53 -val it = true : bool
169.54 -> is_list_dsc (head_of t);
169.55 -val it = true : bool
169.56 -
169.57 -> val t = (term_of o the o (parse thy))"max_relation (A=#2*a*b-a^^^#2)";
169.58 -> is_list_dsc t;
169.59 -val it = false : bool
169.60 -> is_list_dsc (head_of t);
169.61 -val it = false : bool
169.62 -> val t = (term_of o the o (parse thy)) "testdscforlist";
169.63 -> is_list_dsc (head_of t);
169.64 -val it = true : bool
169.65 -*)
169.66 -
169.67 -
169.68 -fun is_unl (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true
169.69 - | is_unl _ = false;
169.70 -(*
169.71 -> val t = str2term "someList"; is_unl t;
169.72 -val it = true : bool
169.73 -> val t = (term_of o the o (parse thy)) "maximum";
169.74 -> is_unl t;
169.75 -val it = false : bool
169.76 -*)
169.77 -
169.78 -fun is_dsc (Const(_,Type("fun",[_,Type("Tools.nam",_)]))) = true
169.79 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.una",_)]))) = true
169.80 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.unl",_)]))) = true
169.81 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.str",_)]))) = true
169.82 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreal",_)]))) = true
169.83 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.toreall",_)])))= true
169.84 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.tobooll",_)])))= true
169.85 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.unknow",_)])))= true
169.86 - | is_dsc (Const(_,Type("fun",[_,Type("Tools.cpy",_)])))= true
169.87 - | is_dsc _ = false;
169.88 -fun is_dsc term =
169.89 - (case (range_type o type_of) term of
169.90 - Type("Tools.nam",_) => true
169.91 - | Type("Tools.una",_) => true
169.92 - | Type("Tools.unl",_) => true
169.93 - | Type("Tools.str",_) => true
169.94 - | Type("Tools.toreal",_) => true
169.95 - | Type("Tools.toreall",_) => true
169.96 - | Type("Tools.tobooll",_) => true
169.97 - | Type("Tools.unknow",_) => true
169.98 - | Type("Tools.cpy",_) => true
169.99 - | _ => false)
169.100 - handle Match => false;
169.101 -
169.102 -
169.103 -(*
169.104 -val t as t1 $ t2 = str2term "antiDerivativeName M_b";
169.105 -val Const (_, Type ("fun", [Type ("fun", _), Type ("Tools.una",[])])) $ _ = t;
169.106 -is_dsc t1;
169.107 -
169.108 -> val t = (term_of o the o (parse thy)) "maximum";
169.109 -> is_dsc t;
169.110 -val it = true : bool
169.111 -> val t = (term_of o the o (parse thy)) "testdscforlist";
169.112 -> is_dsc t;
169.113 -val it = true : bool
169.114 -
169.115 -> val t = (head_of o term_of o the o (parse thy)) "maximum A";
169.116 -> is_dsc t;
169.117 -val it = true : bool
169.118 -> val t = (head_of o term_of o the o (parse thy))
169.119 - "fixedValues [R=(R::real)]";
169.120 -> is_dsc t;
169.121 -val it = true : bool
169.122 -*)
169.123 -
169.124 -
169.125 -(*make the term 'Subproblem (domID, pblID)' to a formula for frontend;
169.126 - needs to be here after def. Subproblem in Script.thy*)
169.127 -val t as (subpbl_t $ (pair_t $ Free (domID,_) $ pblID)) =
169.128 - (term_of o the o (parse @{theory Script}))
169.129 - "Subproblem (Isac,[equation,univar])";
169.130 -val t as (pbl_t $ _) =
169.131 - (term_of o the o (parse @{theory Script}))
169.132 - "Problem (Isac,[equation,univar])";
169.133 -val Free (_, ID_type) = (term_of o the o (parse @{theory Script})) "x::ID";
169.134 -
169.135 -
169.136 -fun subpbl domID pblID =
169.137 - subpbl_t $ (pair_t $ Free (domID,ID_type) $
169.138 - (((list2isalist ID_type) o (map (mk_free ID_type))) pblID));
169.139 -(*> subpbl "Isac" ["equation","univar"] = t;
169.140 -val it = true : bool *)
169.141 -
169.142 -
169.143 -fun pblterm (domID:domID) (pblID:pblID) =
169.144 - pbl_t $ (pair_t $ Free (domID,ID_type) $
169.145 - (((list2isalist ID_type) o (map (mk_free ID_type))) pblID));
169.146 -
169.147 -
169.148 -(**.construct scr-env from scr(created automatically) and Rewrite_Set.**)
169.149 -
169.150 -fun one_scr_arg (Const _ $ arg $ _) = arg
169.151 - | one_scr_arg t = raise error ("one_scr_arg: called by "^(term2str t));
169.152 -fun two_scr_arg (Const _ $ a1 $ a2 $ _) = (a1, a2)
169.153 - | two_scr_arg t = raise error ("two_scr_arg: called by "^(term2str t));
169.154 -
169.155 -
169.156 -(**.generate calc from a script.**)
169.157 -
169.158 -(*.instantiate a stactic or scriptexpr, and ev. attach (curried) argument
169.159 -args:
169.160 - E environment
169.161 - v current value, is attached to curried stactics
169.162 - stac stactic to be instantiated
169.163 -precond:
169.164 - not (a = NONE) /\ (v = e_term) /\ (stac curried, i.e. without last arg.)
169.165 - this ........................ is the initialization for assy with l=[],
169.166 - but the 1st stac is
169.167 - (a) curried: then (a = SOME _), or
169.168 - (b) not curried: then the values of the initialization are not used
169.169 -.*)
169.170 -datatype stacexpr = STac of term | Expr of term
169.171 -fun rep_stacexpr (STac t ) = t
169.172 - | rep_stacexpr (Expr t) =
169.173 - raise error ("rep_stacexpr called with t= "^(term2str t));
169.174 -
169.175 -type env = (term * term) list;
169.176 -
169.177 -(*update environment; t <> empty if coming from listexpr*)
169.178 -fun upd_env (env:env) (v,t) =
169.179 - let val env' = if t = e_term then env else overwrite (env,(v,t));
169.180 - (*val _= writeln("### upd_env: = "^(subst2str env'));*)
169.181 - in env' end;
169.182 -
169.183 -(*.substitute the scripts environment in a leaf of the scripts parse-tree
169.184 - and attach the curried argument of a tactic, if any.
169.185 - a leaf is either a tactic or an 'exp' in 'let v = expr'
169.186 - where 'exp' does not contain a tactic.
169.187 -CAUTION: (1) currying with @@ requires 2 patterns for each tactic
169.188 - (2) the non-curried version must return NONE for a
169.189 - (3) non-matching patterns become an Expr by fall-through.
169.190 -WN060906 quick and dirty fix: due to (2) a is returned, too.*)
169.191 -fun subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ $ _ ))=
169.192 - (NONE, STac (subst_atomic E t))
169.193 -
169.194 - | subst_stacexpr E a v (t as (Const ("Script.Rewrite",_) $ _ $ _ ))=
169.195 - (a, (*in these cases we hope, that a = SOME _*)
169.196 - STac (case a of SOME a' => (subst_atomic E (t $ a'))
169.197 - | NONE => ((subst_atomic E t) $ v)))
169.198 -
169.199 - | subst_stacexpr E a v
169.200 - (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _ $ _ )) =
169.201 - (NONE, STac (subst_atomic E t))
169.202 -
169.203 - | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Inst",_) $ _ $ _ $ _))=
169.204 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.205 - | NONE => ((subst_atomic E t) $ v)))
169.206 -
169.207 - | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ $ _ ))=
169.208 - (NONE, STac (subst_atomic E t))
169.209 -
169.210 - | subst_stacexpr E a v (t as (Const ("Script.Rewrite'_Set",_) $ _ $ _ )) =
169.211 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.212 - | NONE => ((subst_atomic E t) $ v)))
169.213 -
169.214 - | subst_stacexpr E a v
169.215 - (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ $ _ )) =
169.216 - (NONE, STac (subst_atomic E t))
169.217 -
169.218 - | subst_stacexpr E a v
169.219 - (t as (Const ("Script.Rewrite'_Set'_Inst",_) $ _ $ _ $ _ )) =
169.220 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.221 - | NONE => ((subst_atomic E t) $ v)))
169.222 -
169.223 - | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ $ _ )) =
169.224 - (NONE, STac (subst_atomic E t))
169.225 -
169.226 - | subst_stacexpr E a v (t as (Const ("Script.Calculate",_) $ _ )) =
169.227 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.228 - | NONE => ((subst_atomic E t) $ v)))
169.229 -
169.230 - | subst_stacexpr E a v
169.231 - (t as (Const("Script.Check'_elementwise",_) $ _ $ _ )) =
169.232 - (NONE, STac (subst_atomic E t))
169.233 -
169.234 - | subst_stacexpr E a v (t as (Const("Script.Check'_elementwise",_) $ _ )) =
169.235 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.236 - | NONE => ((subst_atomic E t) $ v)))
169.237 -
169.238 - | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_) $ _ )) =
169.239 - (NONE, STac (subst_atomic E t))
169.240 -
169.241 - | subst_stacexpr E a v (t as (Const("Script.Or'_to'_List",_))) = (*t $ v*)
169.242 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.243 - | NONE => ((subst_atomic E t) $ v)))
169.244 -
169.245 - | subst_stacexpr E a v (t as (Const ("Script.SubProblem",_) $ _ $ _ )) =
169.246 - (NONE, STac (subst_atomic E t))
169.247 -
169.248 - | subst_stacexpr E a v (t as (Const ("Script.Take",_) $ _ )) =
169.249 - (NONE, STac (subst_atomic E t))
169.250 -
169.251 - | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ $ _ )) =
169.252 - (NONE, STac (subst_atomic E t))
169.253 -
169.254 - | subst_stacexpr E a v (t as (Const ("Script.Substitute",_) $ _ )) =
169.255 - (a, STac (case a of SOME a' => subst_atomic E (t $ a')
169.256 - | NONE => ((subst_atomic E t) $ v)))
169.257 -
169.258 - (*now all tactics are matched out and this leaf must be without a tactic*)
169.259 - | subst_stacexpr E a v t =
169.260 - (a, Expr (subst_atomic (case a of SOME a => upd_env E (a,v)
169.261 - | NONE => E) t));
169.262 -(*> val t = str2term "SubProblem(Test_, [linear, univariate, equation, test], [Test, solve_linear]) [bool_ e_, real_ v_]";
169.263 -> subst_stacexpr [] NONE e_term t;*)
169.264 -
169.265 -
169.266 -fun stacpbls (h $ body) =
169.267 - let
169.268 - fun scan ts (Const ("Let",_) $ e $ (Abs (v,T,b))) =
169.269 - (scan ts e) @ (scan ts b)
169.270 - | scan ts (Const ("If",_) $ c $ e1 $ e2) = (scan ts e1) @ (scan ts e2)
169.271 - | scan ts (Const ("Script.While",_) $ c $ e $ _) = scan ts e
169.272 - | scan ts (Const ("Script.While",_) $ c $ e) = scan ts e
169.273 - | scan ts (Const ("Script.Repeat",_) $ e $ _) = scan ts e
169.274 - | scan ts (Const ("Script.Repeat",_) $ e) = scan ts e
169.275 - | scan ts (Const ("Script.Try",_) $ e $ _) = scan ts e
169.276 - | scan ts (Const ("Script.Try",_) $ e) = scan ts e
169.277 - | scan ts (Const ("Script.Or",_) $e1 $ e2 $ _) =
169.278 - (scan ts e1) @ (scan ts e2)
169.279 - | scan ts (Const ("Script.Or",_) $e1 $ e2) =
169.280 - (scan ts e1) @ (scan ts e2)
169.281 - | scan ts (Const ("Script.Seq",_) $e1 $ e2 $ _) =
169.282 - (scan ts e1) @ (scan ts e2)
169.283 - | scan ts (Const ("Script.Seq",_) $e1 $ e2) =
169.284 - (scan ts e1) @ (scan ts e2)
169.285 - | scan ts t = case subst_stacexpr [] NONE e_term t of
169.286 - (_, STac _) => [t] | (_, Expr _) => []
169.287 - in (distinct o (scan [])) body end;
169.288 - (*sc = Solve_root_equation ...
169.289 -> val ts = stacpbls sc;
169.290 -> writeln (terms2str thy ts);
169.291 -["Rewrite square_equation_left True e_",
169.292 - "Rewrite_Set SqRoot_simplify False e_",
169.293 - "Rewrite_Set rearrange_assoc False e_",
169.294 - "Rewrite_Set isolate_root False e_",
169.295 - "Rewrite_Set norm_equation False e_",
169.296 - "Rewrite_Set_Inst [(bdv, v_)] isolate_bdv False e_"]
169.297 -*)
169.298 -
169.299 -
169.300 -
169.301 -fun is_calc (Const ("Script.Calculate",_) $ _) = true
169.302 - | is_calc (Const ("Script.Calculate",_) $ _ $ _) = true
169.303 - | is_calc _ = false;
169.304 -fun op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_)) = op_
169.305 - | op_of_calc (Const ("Script.Calculate",_) $ Free (op_,_) $ _) = op_
169.306 - | op_of_calc t = raise error ("op_of_calc called with"^term2str t);
169.307 -(*
169.308 - val Script sc = (#scr o rep_rls) Test_simplify;
169.309 - val stacs = stacpbls sc;
169.310 -
169.311 - val calcs = filter is_calc stacs;
169.312 - val ids = map op_of_calc calcs;
169.313 - map (curry assoc1 (!calclist')) ids;
169.314 -
169.315 - (((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
169.316 - (filter is_calc) o stacpbls) sc):calc list;
169.317 -*)
169.318 -
169.319 -(**.for automatic creation of scripts from rls.**)
169.320 -(* naming of identifiers in scripts ???...
169.321 -((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t::'z) = t";
169.322 -((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o
169.323 - (parse @{theory})) "(t't::'z) = t't";
169.324 -((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_t::'z) = t_t";
169.325 -(* not accepted !!!...*)
169.326 -((inst_abs @{theory}) o term_of o the o (parse @{theory})) "(t_::'z) = t_";
169.327 -((inst_abs @{theory}) o term_of o (the:cterm option -> cterm) o
169.328 - (parse @{theory})) "(_t::'z) = _t";
169.329 -*)
169.330 -((inst_abs @{theory}) o term_of o the o (parse @{theory}))
169.331 -"Script Stepwise (t::'z) =\
169.332 - \(Repeat\
169.333 - \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
169.334 - \ (Try (Repeat (Rewrite real_add_commute False))) @@ \
169.335 - \ (Try (Repeat (Rewrite real_mult_commute False)))) \
169.336 - \ t_t)";
169.337 -val ScrStep $ _ $ _ = (*'z not affected by parse: 'a --> real*)
169.338 - ((inst_abs @{theory}) o term_of o the o (parse @{theory}))
169.339 - "Script Stepwise (t::'z) =\
169.340 - \(Repeat\
169.341 - \ ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
169.342 - \ (Try (Repeat (Rewrite real_add_commute False))) @@ \
169.343 - \ (Try (Repeat (Rewrite real_mult_commute False)))) \
169.344 - \ t_t)";
169.345 -(*WN060605 script-arg (t_::'z) and "Free (t_, 'a)" at end of body
169.346 -are inconsistent !!!*)
169.347 -val ScrStep_inst $ Term $ Bdv $ _=(*'z not affected by parse: 'a --> real*)
169.348 - ((inst_abs @{theory}) o term_of o the o (parse @{theory}))
169.349 - "Script Stepwise_inst (t::'z) (v::real) =\
169.350 - \(Repeat\
169.351 - \ ((Try (Repeat (Rewrite_Inst [(bdv,v)] real_diff_minus False))) @@ \
169.352 - \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_add_commute False))) @@\
169.353 - \ (Try (Repeat (Rewrite_Inst [(bdv,v)] real_mult_commute False)))) \
169.354 - \ t)";
169.355 -val Repeat $ _ =
169.356 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.357 - "Repeat (Rewrite real_diff_minus False t)";
169.358 -val Try $ _ =
169.359 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.360 - "Try (Rewrite real_diff_minus False t)";
169.361 -val Cal $ _ =
169.362 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.363 - "Calculate PLUS";
169.364 -val Ca1 $ _ =
169.365 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.366 - "Calculate1 PLUS";
169.367 -val Rew $ (Free (_,IDtype)) $ _ $ t =
169.368 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.369 - "Rewrite real_diff_minus False t";
169.370 -val Rew_Inst $ Subs $ _ $ _ =
169.371 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.372 - "Rewrite_Inst [(bdv,v)] real_diff_minus False";
169.373 -val Rew_Set $ _ $ _ =
169.374 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.375 - "Rewrite_Set real_diff_minus False";
169.376 -val Rew_Set_Inst $ _ $ _ $ _ =
169.377 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.378 - "Rewrite_Set_Inst [(bdv,v)] real_diff_minus False";
169.379 -val SEq $ _ $ _ $ _ =
169.380 - ((inst_abs @{theory}) o term_of o the o (parseN @{theory}))
169.381 - " ((Try (Repeat (Rewrite real_diff_minus False))) @@ \
169.382 - \ (Try (Repeat (Rewrite real_add_commute False))) @@ \
169.383 - \ (Try (Repeat (Rewrite real_mult_commute False)))) t";
169.384 -
169.385 -fun rule2stac _ (Thm (thmID, _)) =
169.386 - Try $ (Repeat $ (Rew $ Free (thmID, IDtype) $ HOLogic.false_const))
169.387 - | rule2stac calc (Calc (c, _)) =
169.388 - Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype)))
169.389 - | rule2stac calc (Cal1 (c, _)) =
169.390 - Try $ (Repeat $ (Ca1 $ Free (assoc_calc (calc ,c), IDtype)))
169.391 - | rule2stac _ (Rls_ rls) =
169.392 - Try $ (Rew_Set $ Free (id_rls rls, IDtype) $ HOLogic.false_const);
169.393 -(*val t = rule2stac [] (Thm ("real_diff_minus", num_str real_diff_minus));
169.394 -atomt t; term2str t;
169.395 -val t = rule2stac calclist (Calc ("op +", eval_binop "#add_"));
169.396 -atomt t; term2str t;
169.397 -val t = rule2stac [] (Rls_ rearrange_assoc);
169.398 -atomt t; term2str t;
169.399 -*)
169.400 -fun rule2stac_inst _ (Thm (thmID, _)) =
169.401 - Try $ (Repeat $ (Rew_Inst $ Subs $ Free (thmID, IDtype) $
169.402 - HOLogic.false_const))
169.403 - | rule2stac_inst calc (Calc (c, _)) =
169.404 - Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype)))
169.405 - | rule2stac_inst calc (Cal1 (c, _)) =
169.406 - Try $ (Repeat $ (Cal $ Free (assoc_calc (calc ,c), IDtype)))
169.407 - | rule2stac_inst _ (Rls_ rls) =
169.408 - Try $ (Rew_Set_Inst $ Subs $ Free (id_rls rls, IDtype) $
169.409 - HOLogic.false_const);
169.410 -(*val t = rule2stac_inst [] (Thm ("real_diff_minus", num_str real_diff_minus));
169.411 -atomt t; term2str t;
169.412 -val t = rule2stac_inst calclist (Calc ("op +", eval_binop "#add_"));
169.413 -atomt t; term2str t;
169.414 -val t = rule2stac_inst [] (Rls_ rearrange_assoc);
169.415 -atomt t; term2str t;
169.416 -*)
169.417 -
169.418 -(*for appropriate nesting take stacs in _reverse_ order*)
169.419 -fun @@@ sts [s] = SEq $ s $ sts
169.420 - | @@@ sts (s::ss) = @@@ (SEq $ s $ sts) ss;
169.421 -fun @@ [stac] = stac
169.422 - | @@ [s1, s2] = SEq $ s1 $ s2 (*---------vvv--*)
169.423 - | @@ stacs =
169.424 - let val s3::s2::ss = rev stacs
169.425 - in @@@ (SEq $ s2 $ s3) ss end;
169.426 -(*
169.427 - val rules = (#rules o rep_rls) isolate_root;
169.428 - val rs = map (rule2stac calclist) rules;
169.429 - val tt = @@ rs;
169.430 - atomt tt; writeln (term2str tt);
169.431 - *)
169.432 -
169.433 -val contains_bdv = (not o null o (filter is_bdv) o ids2str o #prop o rep_thm);
169.434 -
169.435 -(*.does a rule contain a 'bdv'; descend recursively into Rls_.*)
169.436 -fun contain_bdv [] = false
169.437 - | contain_bdv (Thm (_, thm)::rs) =
169.438 - if (not o contains_bdv) thm
169.439 - then contain_bdv rs
169.440 - else true
169.441 - | contain_bdv (Calc _ ::rs) = contain_bdv rs
169.442 - | contain_bdv (Cal1 _ ::rs) = contain_bdv rs
169.443 - | contain_bdv (Rls_ rls ::rs) =
169.444 - contain_bdv (get_rules rls) orelse contain_bdv rs
169.445 - | contain_bdv (r::_) =
169.446 - raise error ("contain_bdv called with ["^(id_rule r)^",...]");
169.447 -
169.448 -fun rules2scr_Rls calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*)
169.449 - if contain_bdv rules
169.450 - then ScrStep_inst $ Term $ Bdv $
169.451 - (Repeat $ (((@@ o (map (rule2stac_inst calc))) rules) $ e_term))
169.452 - else ScrStep $ Term $
169.453 - (Repeat $ (((@@ o (map (rule2stac calc))) rules) $ e_term));
169.454 -(* val (calc, rules) = (!calclist', rules);
169.455 - *)
169.456 -fun rules2scr_Seq calc rules = (*WN100816 t_ -> t_t like "Script Stepwise..*)
169.457 - if contain_bdv rules
169.458 - then ScrStep_inst $ Term $ Bdv $
169.459 - (((@@ o (map (rule2stac_inst calc))) rules) $ e_term)
169.460 - else ScrStep $ Term $
169.461 - (((@@ o (map (rule2stac calc))) rules) $ e_term);
169.462 -
169.463 -(*.prepare the input for an rls for use:
169.464 - # generate a script for stepwise execution of the rls
169.465 - # filter the operators for Calc out of the script
169.466 - !!!use this function in ruleset' := !!! .*)
169.467 -fun prep_rls Erls = raise error "prep_rls not impl. for Erls"
169.468 - | prep_rls (Rls {id,preconds,rew_ord,erls,srls,calc,rules,...}) =
169.469 - let val sc = (rules2scr_Rls (!calclist') rules)
169.470 - in Rls {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls,
169.471 - srls=srls,
169.472 - calc = (*FIXXXME.040207 use also for met*)
169.473 - ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
169.474 - (filter is_calc) o stacpbls) sc,
169.475 - rules=rules,
169.476 - scr = Script sc} end
169.477 -(* val (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) = add_new_c;
169.478 - *)
169.479 - | prep_rls (Seq {id,preconds,rew_ord,erls,srls,calc,rules,...}) =
169.480 - let val sc = (rules2scr_Seq (!calclist') rules)
169.481 - in Seq {id=id,preconds=preconds,rew_ord=rew_ord,erls=erls,
169.482 - srls=srls,
169.483 - calc = ((map (curry assoc1 (!calclist'))) o (map op_of_calc) o
169.484 - (filter is_calc) o stacpbls) sc,
169.485 - rules=rules,
169.486 - scr = Script sc} end
169.487 - | prep_rls (Rrls {id,...}) =
169.488 - raise error ("prep_rls not required for Rrls \""^id^"\"");
169.489 -(*
169.490 - val Script sc = (#scr o rep_rls o prep_rls) isolate_root;
169.491 - (writeln o term2str) sc;
169.492 - val Script sc = (#scr o rep_rls o prep_rls) isolate_bdv;
169.493 - (writeln o term2str) sc;
169.494 - *)
170.1 --- a/src/Tools/isac/Scripts/term_G.sml Wed Aug 25 15:15:01 2010 +0200
170.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
170.3 @@ -1,1343 +0,0 @@
170.4 -(* extends Isabelle/src/Pure/term.ML
170.5 - (c) Walther Neuper 1999
170.6 -
170.7 -use"Scripts/term_G.sml";
170.8 -use"term_G.sml";
170.9 -*)
170.10 -
170.11 -(*
170.12 -> (cterm_of thy) a_term;
170.13 -val it = "empty" : cterm *)
170.14 -
170.15 -(*2003 fun match thy t pat =
170.16 - (snd (Pattern.match (Sign.tsig_of (sign_of thy)) (pat, t)))
170.17 - handle _ => [];
170.18 -fn : theory ->
170.19 - Term.term -> Term.term -> (Term.indexname * Term.term) list*)
170.20 -(*see src/Tools/eqsubst.ML fun clean_match*)
170.21 -(*2003 fun matches thy tm pa = if match thy tm pa = [] then false else true;*)
170.22 -fun matches thy tm pa =
170.23 - (Pattern.match thy (pa, tm) (Vartab.empty, Vartab.empty); true)
170.24 - handle _ => false
170.25 -
170.26 -fun atomtyp t = (*see raw_pp_typ*)
170.27 - let
170.28 - fun ato n (Type (s,[])) =
170.29 - ("\n*** "^indent n^"Type ("^s^",[])")
170.30 - | ato n (Type (s,Ts)) =
170.31 - ("\n*** "^indent n^"Type ("^s^",["^ atol (n+1) Ts)
170.32 -
170.33 - | ato n (TFree (s,sort)) =
170.34 - ("\n*** "^indent n^"TFree ("^s^",["^ strs2str' sort)
170.35 -
170.36 - | ato n (TVar ((s,i),sort)) =
170.37 - ("\n*** "^indent n^"TVar (("^s^","^
170.38 - string_of_int i ^ strs2str' sort)
170.39 - and atol n [] =
170.40 - ("\n*** "^indent n^"]")
170.41 - | atol n (T::Ts) = (ato n T ^ atol n Ts)
170.42 -(*in print (ato 0 t ^ "\n") end; TODO TUM10*)
170.43 -in writeln(ato 0 t) end;
170.44 -
170.45 -(*Prog.Tutorial.p.34*)
170.46 -local
170.47 - fun pp_pair (x, y) = Pretty.list "(" ")" [x, y]
170.48 - fun pp_list xs = Pretty.list "[" "]" xs
170.49 - fun pp_str s = Pretty.str s
170.50 - fun pp_qstr s = Pretty.quote (pp_str s)
170.51 - fun pp_int i = pp_str (string_of_int i)
170.52 - fun pp_sort S = pp_list (map pp_qstr S)
170.53 - fun pp_constr a args = Pretty.block [pp_str a, Pretty.brk 1, args]
170.54 -in
170.55 -fun raw_pp_typ (TVar ((a, i), S)) =
170.56 - pp_constr "TVar" (pp_pair (pp_pair (pp_qstr a, pp_int i), pp_sort S))
170.57 - | raw_pp_typ (TFree (a, S)) =
170.58 - pp_constr "TFree" (pp_pair (pp_qstr a, pp_sort S))
170.59 - | raw_pp_typ (Type (a, tys)) =
170.60 - pp_constr "Type" (pp_pair (pp_qstr a, pp_list (map raw_pp_typ tys)))
170.61 -end
170.62 -(* install
170.63 -PolyML.addPrettyPrinter
170.64 - (fn _ => fn _ => ml_pretty o Pretty.to_ML o raw_pp_typ);
170.65 -de-install
170.66 -PolyML.addPrettyPrinter
170.67 - (fn _ => fn _ => ml_pretty o Pretty.to_ML o Proof_Display.pp_typ Pure.thy);
170.68 -*)
170.69 -
170.70 -(*
170.71 -> val T = (type_of o term_of o the o (parse thy)) "a::[real,int] => nat";
170.72 -> atomtyp T;
170.73 -*** Type (fun,[
170.74 -*** Type (RealDef.real,[])
170.75 -*** Type (fun,[
170.76 -*** Type (IntDef.int,[])
170.77 -*** Type (nat,[])
170.78 -*** ]
170.79 -*** ]
170.80 -*)
170.81 -
170.82 -fun atomt t =
170.83 - let fun ato (Const(a,T)) n =
170.84 - ("\n*** "^indent n^"Const ("^a^")")
170.85 - | ato (Free (a,T)) n =
170.86 - ("\n*** "^indent n^"Free ("^a^", "^")")
170.87 - | ato (Var ((a,ix),T)) n =
170.88 - ("\n*** "^indent n^"Var (("^a^", "^(string_of_int ix)^"), "^")")
170.89 - | ato (Bound ix) n =
170.90 - ("\n*** "^indent n^"Bound "^(string_of_int ix))
170.91 - | ato (Abs(a,T,body)) n =
170.92 - ("\n*** "^indent n^"Abs("^a^",..")^ato body (n+1)
170.93 - | ato (f$t') n = (ato f n; ato t' (n+1))
170.94 - in writeln("\n*** -------------"^ ato t 0 ^"\n***") end;
170.95 -
170.96 -fun term_detail2str t =
170.97 - let fun ato (Const (a, T)) n =
170.98 - "\n*** "^indent n^"Const ("^a^", "^string_of_typ T^")"
170.99 - | ato (Free (a, T)) n =
170.100 - "\n*** "^indent n^"Free ("^a^", "^string_of_typ T^")"
170.101 - | ato (Var ((a, ix), T)) n =
170.102 - "\n*** "^indent n^"Var (("^a^", "^string_of_int ix^"), "^
170.103 - string_of_typ T^")"
170.104 - | ato (Bound ix) n =
170.105 - "\n*** "^indent n^"Bound "^string_of_int ix
170.106 - | ato (Abs(a, T, body)) n =
170.107 - "\n*** "^indent n^"Abs ("^a^", "^
170.108 - (string_of_typ T)^",.."
170.109 - ^ato body (n + 1)
170.110 - | ato (f $ t') n = ato f n^ato t' (n+1)
170.111 - in "\n*** "^ato t 0^"\n***" end;
170.112 -fun atomty t = (writeln o term_detail2str) t;
170.113 -
170.114 -fun term_str thy (Const(s,_)) = s
170.115 - | term_str thy (Free(s,_)) = s
170.116 - | term_str thy (Var((s,i),_)) = s^(string_of_int i)
170.117 - | term_str thy (Bound i) = "B."^(string_of_int i)
170.118 - | term_str thy (Abs(s,_,_)) = s
170.119 - | term_str thy t = raise error("term_str not for "^term2str t);
170.120 -
170.121 -(*.contains the fst argument the second argument (a leave! of term).*)
170.122 -fun contains_term (Abs(_,_,body)) t = contains_term body t
170.123 - | contains_term (f $ f') t =
170.124 - contains_term f t orelse contains_term f' t
170.125 - | contains_term s t = t = s;
170.126 -(*.contains the term a VAR(("*",_),_) ?.*)
170.127 -fun contains_Var (Abs(_,_,body)) = contains_Var body
170.128 - | contains_Var (f $ f') = contains_Var f orelse contains_Var f'
170.129 - | contains_Var (Var _) = true
170.130 - | contains_Var _ = false;
170.131 -(* contains_Var (str2term "?z = 3") (*true*);
170.132 - contains_Var (str2term "z = 3") (*false*);
170.133 - *)
170.134 -
170.135 -(*fun int_of_str str =
170.136 - let val ss = explode str
170.137 - val str' = case ss of
170.138 - "("::s => drop_last s | _ => ss
170.139 - in case BasisLibrary.Int.fromString (implode str') of
170.140 - SOME i => SOME i
170.141 - | NONE => NONE end;*)
170.142 -fun int_of_str str =
170.143 - let val ss = explode str
170.144 - val str' = case ss of
170.145 - "("::s => drop_last s | _ => ss
170.146 - in (SOME (Thy_Output.integer (implode str'))) handle _ => NONE end;
170.147 -(*
170.148 -> int_of_str "123";
170.149 -val it = SOME 123 : int option
170.150 -> int_of_str "(-123)";
170.151 -val it = SOME 123 : int option
170.152 -> int_of_str "#123";
170.153 -val it = NONE : int option
170.154 -> int_of_str "-123";
170.155 -val it = SOME ~123 : int option
170.156 -*)
170.157 -fun int_of_str' str =
170.158 - case int_of_str str of
170.159 - SOME i => i
170.160 - | NONE => raise TERM ("int_of_string: no int-string",[]);
170.161 -val str2int = int_of_str';
170.162 -
170.163 -fun is_numeral str = case int_of_str str of
170.164 - SOME _ => true
170.165 - | NONE => false;
170.166 -val is_no = is_numeral;
170.167 -fun is_num (Free (s,_)) = if is_numeral s then true else false
170.168 - | is_num _ = false;
170.169 -(*>
170.170 -> is_num ((term_of o the o (parse thy)) "#1");
170.171 -val it = true : bool
170.172 -> is_num ((term_of o the o (parse thy)) "#-1");
170.173 -val it = true : bool
170.174 -> is_num ((term_of o the o (parse thy)) "a123");
170.175 -val it = false : bool
170.176 -*)
170.177 -
170.178 -(*fun int_of_Free (Free (intstr, _)) =
170.179 - (case BasisLibrary.Int.fromString intstr of
170.180 - SOME i => i
170.181 - | NONE => raise error ("int_of_Free ( "^ intstr ^", _)"))
170.182 - | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )");*)
170.183 -fun int_of_Free (Free (intstr, _)) = (Thy_Output.integer intstr
170.184 - handle _ => raise error ("int_of_Free ( "^ intstr ^", _)"))
170.185 - | int_of_Free t = raise error ("int_of_Free ( "^ term2str t ^" )");
170.186 -
170.187 -fun vars t =
170.188 - let
170.189 - fun scan vs (Const(s,T)) = vs
170.190 - | scan vs (t as Free(s,T)) = if is_no s then vs else t::vs
170.191 - | scan vs (t as Var((s,i),T)) = t::vs
170.192 - | scan vs (Bound i) = vs
170.193 - | scan vs (Abs(s,T,t)) = scan vs t
170.194 - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
170.195 - in (distinct o (scan [])) t end;
170.196 -
170.197 -fun is_Free (Free _) = true
170.198 - | is_Free _ = false;
170.199 -fun is_fun_id (Const _) = true
170.200 - | is_fun_id (Free _) = true
170.201 - | is_fun_id _ = false;
170.202 -fun is_f_x (f $ x) = is_fun_id f andalso is_Free x
170.203 - | is_f_x _ = false;
170.204 -(* is_f_x (str2term "q_0/2 * L * x") (*false*);
170.205 - is_f_x (str2term "M_b x") (*true*);
170.206 - *)
170.207 -fun vars_str t =
170.208 - let
170.209 - fun scan vs (Const(s,T)) = vs
170.210 - | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs
170.211 - | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs
170.212 - | scan vs (Bound i) = vs
170.213 - | scan vs (Abs(s,T,t)) = scan vs t
170.214 - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
170.215 - in (distinct o (scan [])) t end;
170.216 -
170.217 -fun ids2str t =
170.218 - let
170.219 - fun scan vs (Const(s,T)) = if is_no s then vs else s::vs
170.220 - | scan vs (t as Free(s,T)) = if is_no s then vs else s::vs
170.221 - | scan vs (t as Var((s,i),T)) = (s^"_"^(string_of_int i))::vs
170.222 - | scan vs (Bound i) = vs
170.223 - | scan vs (Abs(s,T,t)) = scan (s::vs) t
170.224 - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
170.225 - in (distinct o (scan [])) t end;
170.226 -fun is_bdv str =
170.227 - case explode str of
170.228 - "b"::"d"::"v"::_ => true
170.229 - | _ => false;
170.230 -fun is_bdv_ (Free (s,_)) = is_bdv s
170.231 - | is_bdv_ _ = false;
170.232 -
170.233 -fun free2str (Free (s,_)) = s
170.234 - | free2str t = raise error ("free2str not for "^ term2str t);
170.235 -fun free2int (t as Free (s, _)) = ((str2int s)
170.236 - handle _ => raise error ("free2int: "^term_detail2str t))
170.237 - | free2int t = raise error ("free2int: "^term_detail2str t);
170.238 -
170.239 -(*27.8.01: unused*)
170.240 -fun var2free (t as Const(s,T)) = t
170.241 - | var2free (t as Free(s,T)) = t
170.242 - | var2free (Var((s,i),T)) = Free(s,T)
170.243 - | var2free (t as Bound i) = t
170.244 - | var2free (Abs(s,T,t)) = Abs(s,T,var2free t)
170.245 - | var2free (t1 $ t2) = (var2free t1) $ (var2free t2);
170.246 -
170.247 -(*27.8.01: doesn't find some subterm ???!???*)
170.248 -(*2010 Logic.varify !!!*)
170.249 -fun free2var (t as Const(s,T)) = t
170.250 - | free2var (t as Free(s,T)) = if is_no s then t else Var((s,0),T)
170.251 - | free2var (t as Var((s,i),T)) = t
170.252 - | free2var (t as Bound i) = t
170.253 - | free2var (Abs(s,T,t)) = Abs(s,T,free2var t)
170.254 - | free2var (t1 $ t2) = (free2var t1) $ (free2var t2);
170.255 -
170.256 -
170.257 -fun mk_listT T = Type ("List.list", [T]);
170.258 -fun list_const T =
170.259 - Const("List.list.Cons", [T, mk_listT T] ---> mk_listT T);
170.260 -(*28.8.01: TODO: get type from head of list: 1 arg less!!!*)
170.261 -fun list2isalist T [] = Const("List.list.Nil",mk_listT T)
170.262 - | list2isalist T (t::ts) = (list_const T) $ t $ (list2isalist T ts);
170.263 -(*
170.264 -> val tt = (term_of o the o (parse thy)) "R=(R::real)";
170.265 -> val TT = type_of tt;
170.266 -> val ss = list2isalist TT [tt,tt,tt];
170.267 -> (cterm_of thy) ss;
170.268 -val it = "[R = R, R = R, R = R]" : cterm *)
170.269 -
170.270 -fun isapair2pair (Const ("Pair",_) $ a $ b) = (a,b)
170.271 - | isapair2pair t =
170.272 - raise error ("isapair2pair called with "^term2str t);
170.273 -
170.274 -val listType = Type ("List.list",[Type ("bool",[])]);
170.275 -fun isalist2list ls =
170.276 - let
170.277 - fun get es (Const("List.list.Cons",_) $ t $ ls) = get (t::es) ls
170.278 - | get es (Const("List.list.Nil",_)) = es
170.279 - | get _ t =
170.280 - raise error ("isalist2list applied to NON-list '"^term2str t^"'")
170.281 - in (rev o (get [])) ls end;
170.282 -(*
170.283 -> val il = str2term "[a=b,c=d,e=f]";
170.284 -> val l = isalist2list il;
170.285 -> (writeln o terms2str) l;
170.286 -["a = b","c = d","e = f"]
170.287 -
170.288 -> val il = str2term "ss___::bool list";
170.289 -> val l = isalist2list il;
170.290 -[Free ("ss___", "bool List.list")]
170.291 -*)
170.292 -
170.293 -
170.294 -(*review Isabelle2009/src/HOL/Tools/hologic.ML*)
170.295 -val prop = Type ("prop",[]); (* ~/Diss.99/Integers-Isa/tools.sml*)
170.296 -val bool = Type ("bool",[]); (* 2002 Integ.int *)
170.297 -val Trueprop = Const("Trueprop",bool-->prop);
170.298 -fun mk_prop t = Trueprop $ t;
170.299 -val true_as_term = Const("True",bool);
170.300 -val false_as_term = Const("False",bool);
170.301 -val true_as_cterm = cterm_of (theory "HOL") true_as_term;
170.302 -val false_as_cterm = cterm_of (theory "HOL") false_as_term;
170.303 -
170.304 -infixr 5 -->; (*2002 /Pure/term.ML *)
170.305 -infixr --->; (*2002 /Pure/term.ML *)
170.306 -fun S --> T = Type("fun",[S,T]); (*2002 /Pure/term.ML *)
170.307 -val op ---> = foldr (op -->); (*2002 /Pure/term.ML *)
170.308 -fun list_implies ([], B) = B : term (*2002 /term.ML *)
170.309 - | list_implies (A::AS, B) = Logic.implies $ A $ list_implies(AS,B);
170.310 -
170.311 -
170.312 -
170.313 -(** substitution **)
170.314 -
170.315 -fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) = (* = thm.ML *)
170.316 - match_bvs(s, t, if x="" orelse y="" then al
170.317 - else (x,y)::al)
170.318 - | match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al))
170.319 - | match_bvs(_,_,al) = al;
170.320 -fun ren_inst(insts,prop,pat,obj) = (* = thm.ML *)
170.321 - let val ren = match_bvs(pat,obj,[])
170.322 - fun renAbs(Abs(x,T,b)) =
170.323 - Abs(case assoc_string(ren,x) of NONE => x
170.324 - | SOME(y) => y, T, renAbs(b))
170.325 - | renAbs(f$t) = renAbs(f) $ renAbs(t)
170.326 - | renAbs(t) = t
170.327 - in subst_vars insts (if null(ren) then prop else renAbs(prop)) end;
170.328 -
170.329 -
170.330 -
170.331 -
170.332 -
170.333 -
170.334 -fun dest_equals' (Const("op =",_) $ t $ u) = (t,u)(* logic.ML: Const("=="*)
170.335 - | dest_equals' t = raise TERM("dest_equals'", [t]);
170.336 -val lhs_ = (fst o dest_equals');
170.337 -val rhs_ = (snd o dest_equals');
170.338 -
170.339 -fun is_equality (Const("op =",_) $ t $ u) = true (* logic.ML: Const("=="*)
170.340 - | is_equality _ = false;
170.341 -fun mk_equality (t,u) = (Const("op =",[type_of t,type_of u]--->bool) $ t $ u);
170.342 -fun is_expliceq (Const("op =",_) $ (Free _) $ u) = true
170.343 - | is_expliceq _ = false;
170.344 -fun strip_trueprop (Const("Trueprop",_) $ t) = t
170.345 - | strip_trueprop t = t;
170.346 -(* | strip_trueprop t = raise TERM("strip_trueprop", [t]);
170.347 -*)
170.348 -
170.349 -(*.(A1==>...An==>B) goes to (A1==>...An==>).*)
170.350 -fun strip_imp_prems' (Const("==>", T) $ A $ t) =
170.351 - let fun coll_prems As (Const("==>", _) $ A $ t) =
170.352 - coll_prems (As $ (Logic.implies $ A)) t
170.353 - | coll_prems As _ = SOME As
170.354 - in coll_prems (Logic.implies $ A) t end
170.355 - | strip_imp_prems' _ = NONE; (* logic.ML: term -> term list*)
170.356 -(*
170.357 - val thm = real_mult_div_cancel1;
170.358 - val prop = (#prop o rep_thm) thm;
170.359 - atomt prop;
170.360 -*** -------------
170.361 -*** Const ( ==>)
170.362 -*** . Const ( Trueprop)
170.363 -*** . . Const ( Not)
170.364 -*** . . . Const ( op =)
170.365 -*** . . . . Var ((k, 0), )
170.366 -*** . . . . Const ( 0)
170.367 -*** . Const ( Trueprop)
170.368 -*** . . Const ( op =) *** .............
170.369 - val SOME t = strip_imp_prems' ((#prop o rep_thm) thm);
170.370 - atomt t;
170.371 -*** -------------
170.372 -*** Const ( ==>)
170.373 -*** . Const ( Trueprop)
170.374 -*** . . Const ( Not)
170.375 -*** . . . Const ( op =)
170.376 -*** . . . . Var ((k, 0), )
170.377 -*** . . . . Const ( 0)
170.378 -
170.379 - val thm = real_le_anti_sym;
170.380 - val prop = (#prop o rep_thm) thm;
170.381 - atomt prop;
170.382 -*** -------------
170.383 -*** Const ( ==>)
170.384 -*** . Const ( Trueprop)
170.385 -*** . . Const ( op <=)
170.386 -*** . . . Var ((z, 0), )
170.387 -*** . . . Var ((w, 0), )
170.388 -*** . Const ( ==>)
170.389 -*** . . Const ( Trueprop)
170.390 -*** . . . Const ( op <=)
170.391 -*** . . . . Var ((w, 0), )
170.392 -*** . . . . Var ((z, 0), )
170.393 -*** . . Const ( Trueprop)
170.394 -*** . . . Const ( op =)
170.395 -*** .............
170.396 - val SOME t = strip_imp_prems' ((#prop o rep_thm) thm);
170.397 - atomt t;
170.398 -*** -------------
170.399 -*** Const ( ==>)
170.400 -*** . Const ( Trueprop)
170.401 -*** . . Const ( op <=)
170.402 -*** . . . Var ((z, 0), )
170.403 -*** . . . Var ((w, 0), )
170.404 -*** . Const ( ==>)
170.405 -*** . . Const ( Trueprop)
170.406 -*** . . . Const ( op <=)
170.407 -*** . . . . Var ((w, 0), )
170.408 -*** . . . . Var ((z, 0), )
170.409 -*)
170.410 -
170.411 -(*. (A1==>...An==>) (B) goes to (A1==>...An==>B), where B is lowest branch.*)
170.412 -fun ins_concl (Const("==>", T) $ A $ t) B = Logic.implies $ A $ (ins_concl t B)
170.413 - | ins_concl (Const("==>", T) $ A ) B = Logic.implies $ A $ B
170.414 - | ins_concl t B = raise TERM("ins_concl", [t, B]);
170.415 -(*
170.416 - val thm = real_le_anti_sym;
170.417 - val prop = (#prop o rep_thm) thm;
170.418 - val concl = Logic.strip_imp_concl prop;
170.419 - val SOME prems = strip_imp_prems' prop;
170.420 - val prop' = ins_concl prems concl;
170.421 - prop = prop';
170.422 - atomt prop;
170.423 - atomt prop';
170.424 -*)
170.425 -
170.426 -
170.427 -fun vperm (Var _, Var _) = true (*2002 Pure/thm.ML *)
170.428 - | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t)
170.429 - | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2)
170.430 - | vperm (t, u) = (t = u);
170.431 -
170.432 -(*2002 cp from Pure/term.ML --- since 2009 in Pure/old_term.ML*)
170.433 -fun mem_term (_, []) = false
170.434 - | mem_term (t, t'::ts) = t aconv t' orelse mem_term(t,ts);
170.435 -fun subset_term ([], ys) = true
170.436 - | subset_term (x :: xs, ys) = mem_term (x, ys) andalso subset_term(xs, ys);
170.437 -fun eq_set_term (xs, ys) =
170.438 - xs = ys orelse (subset_term (xs, ys) andalso subset_term (ys, xs));
170.439 -(*a total, irreflexive ordering on index names*)
170.440 -fun xless ((a,i), (b,j): indexname) = i<j orelse (i=j andalso a<b);
170.441 -(*a partial ordering (not reflexive) for atomic terms*)
170.442 -fun atless (Const (a,_), Const (b,_)) = a<b
170.443 - | atless (Free (a,_), Free (b,_)) = a<b
170.444 - | atless (Var(v,_), Var(w,_)) = xless(v,w)
170.445 - | atless (Bound i, Bound j) = i<j
170.446 - | atless _ = false;
170.447 -(*insert atomic term into partially sorted list, suppressing duplicates (?)*)
170.448 -fun insert_aterm (t,us) =
170.449 - let fun inserta [] = [t]
170.450 - | inserta (us as u::us') =
170.451 - if atless(t,u) then t::us
170.452 - else if t=u then us (*duplicate*)
170.453 - else u :: inserta(us')
170.454 - in inserta us end;
170.455 -
170.456 -(*Accumulates the Vars in the term, suppressing duplicates*)
170.457 -fun add_term_vars (t, vars: term list) = case t of
170.458 - Var _ => insert_aterm(t,vars)
170.459 - | Abs (_,_,body) => add_term_vars(body,vars)
170.460 - | f$t => add_term_vars (f, add_term_vars(t, vars))
170.461 - | _ => vars;
170.462 -fun term_vars t = add_term_vars(t,[]);
170.463 -
170.464 -
170.465 -fun var_perm (t, u) = (*2002 Pure/thm.ML *)
170.466 - vperm (t, u) andalso eq_set_term (term_vars t, term_vars u);
170.467 -
170.468 -(*2002 fun decomp_simp, Pure/thm.ML *)
170.469 -fun perm lhs rhs = var_perm (lhs, rhs) andalso not (lhs aconv rhs)
170.470 - andalso not (is_Var lhs);
170.471 -
170.472 -
170.473 -fun str_of_int n =
170.474 - if n < 0 then "-"^((string_of_int o abs) n)
170.475 - else string_of_int n;
170.476 -(*
170.477 -> str_of_int 1;
170.478 -val it = "1" : string > str_of_int ~1;
170.479 -val it = "-1" : string
170.480 -*)
170.481 -
170.482 -
170.483 -fun power b 0 = 1
170.484 - | power b n =
170.485 - if n>0 then b*(power b (n-1))
170.486 - else raise error ("power "^(str_of_int b)^" "^(str_of_int n));
170.487 -(*
170.488 -> power 2 3;
170.489 -val it = 8 : int
170.490 -> power ~2 3;
170.491 -val it = ~8 : int
170.492 -> power ~3 2;
170.493 -val it = 9 : int
170.494 -> power 3 ~2;
170.495 -*)
170.496 -fun gcd 0 b = b
170.497 - | gcd a b = if a < b then gcd (b mod a) a
170.498 - else gcd (a mod b) b;
170.499 -fun sign n = if n < 0 then ~1
170.500 - else if n = 0 then 0 else 1;
170.501 -fun sign2 n1 n2 = (sign n1) * (sign n2);
170.502 -
170.503 -infix dvd;
170.504 -fun d dvd n = n mod d = 0;
170.505 -
170.506 -fun divisors n =
170.507 - let fun pdiv ds d n =
170.508 - if d=n then d::ds
170.509 - else if d dvd n then pdiv (d::ds) d (n div d)
170.510 - else pdiv ds (d+1) n
170.511 - in pdiv [] 2 n end;
170.512 -
170.513 -divisors 30;
170.514 -divisors 32;
170.515 -divisors 60;
170.516 -divisors 11;
170.517 -
170.518 -fun doubles ds = (* ds is ordered *)
170.519 - let fun dbls ds [] = ds
170.520 - | dbls ds [i] = ds
170.521 - | dbls ds (i::i'::is) = if i=i' then dbls (i::ds) is
170.522 - else dbls ds (i'::is)
170.523 - in dbls [] ds end;
170.524 -(*> doubles [2,3,4];
170.525 -val it = [] : int list
170.526 -> doubles [2,3,3,5,5,7];
170.527 -val it = [5,3] : int list*)
170.528 -
170.529 -fun squfact 0 = 0
170.530 - | squfact 1 = 1
170.531 - | squfact n = foldl op* (1, (doubles o divisors) n);
170.532 -(*> squfact 30;
170.533 -val it = 1 : int
170.534 -> squfact 32;
170.535 -val it = 4 : int
170.536 -> squfact 60;
170.537 -val it = 2 : int
170.538 -> squfact 11;
170.539 -val it = 1 : int*)
170.540 -
170.541 -
170.542 -fun dest_type (Type(T,[])) = T
170.543 - | dest_type T =
170.544 - (atomtyp T;
170.545 - raise error ("... dest_type: not impl. for this type"));
170.546 -
170.547 -fun term_of_num ntyp n = Free (str_of_int n, ntyp);
170.548 -
170.549 -fun pairT T1 T2 = Type ("*", [T1, T2]);
170.550 -(*> val t = str2term "(1,2)";
170.551 -> type_of t = pairT HOLogic.realT HOLogic.realT;
170.552 -val it = true : bool
170.553 -*)
170.554 -fun PairT T1 T2 = ([T1, T2] ---> Type ("*", [T1, T2]));
170.555 -(*> val t = str2term "(1,2)";
170.556 -> val Const ("Pair",pT) $ _ $ _ = t;
170.557 -> pT = PairT HOLogic.realT HOLogic.realT;
170.558 -val it = true : bool
170.559 -*)
170.560 -fun pairt t1 t2 =
170.561 - Const ("Pair", PairT (type_of t1) (type_of t2)) $ t1 $ t2;
170.562 -(*> val t = str2term "(1,2)";
170.563 -> val (t1, t2) = (str2term "1", str2term "2");
170.564 -> t = pairt t1 t2;
170.565 -val it = true : bool*)
170.566 -
170.567 -
170.568 -fun num_of_term (t as Free (s,_)) =
170.569 - (case int_of_str s of
170.570 - SOME s' => s'
170.571 - | NONE => raise error ("num_of_term not for "^ term2str t))
170.572 - | num_of_term t = raise error ("num_of_term not for "^term2str t);
170.573 -
170.574 -fun mk_factroot op_(*=thy.sqrt*) T fact root =
170.575 - Const ("op *", [T, T] ---> T) $ (term_of_num T fact) $
170.576 - (Const (op_, T --> T) $ term_of_num T root);
170.577 -(*
170.578 -val T = (type_of o term_of o the) (parse thy "#12::real");
170.579 -val t = mk_factroot "SqRoot.sqrt" T 2 3;
170.580 -(cterm_of thy) t;
170.581 -val it = "#2 * sqrt #3 " : cterm
170.582 -*)
170.583 -fun var_op_num v op_ optype ntyp n =
170.584 - Const (op_, optype) $ v $
170.585 - Free (str_of_int n, ntyp);
170.586 -
170.587 -fun num_op_var v op_ optype ntyp n =
170.588 - Const (op_,optype) $
170.589 - Free (str_of_int n, ntyp) $ v;
170.590 -
170.591 -fun num_op_num T1 T2 (op_,Top) n1 n2 =
170.592 - Const (op_,Top) $
170.593 - Free (str_of_int n1, T1) $ Free (str_of_int n2, T2);
170.594 -(*
170.595 -> val t = num_op_num "Int" 3 4;
170.596 -> atomty t;
170.597 -> string_of_cterm ((cterm_of thy) t);
170.598 -*)
170.599 -
170.600 -fun const_in str (Const _) = false
170.601 - | const_in str (Free (s,_)) = if strip_thy s = str then true else false
170.602 - | const_in str (Bound _) = false
170.603 - | const_in str (Var _) = false
170.604 - | const_in str (Abs (_,_,body)) = const_in str body
170.605 - | const_in str (f$u) = const_in str f orelse const_in str u;
170.606 -(*
170.607 -> val t = (term_of o the o (parse thy)) "6 + 5 * sqrt 4 + 3";
170.608 -> const_in "sqrt" t;
170.609 -val it = true : bool
170.610 -> val t = (term_of o the o (parse thy)) "6 + 5 * 4 + 3";
170.611 -> const_in "sqrt" t;
170.612 -val it = false : bool
170.613 -*)
170.614 -
170.615 -(*used for calculating built in binary operations in Isabelle2002->Float.ML*)
170.616 -(*fun calc "op +" (n1, n2) = n1+n2
170.617 - | calc "op -" (n1, n2) = n1-n2
170.618 - | calc "op *" (n1, n2) = n1*n2
170.619 - | calc "HOL.divide"(n1, n2) = n1 div n2
170.620 - | calc "Atools.pow"(n1, n2) = power n1 n2
170.621 - | calc op_ _ = raise error ("calc: operator = "^op_^" not defined");-----*)
170.622 -fun calc_equ "op <" (n1, n2) = n1 < n2
170.623 - | calc_equ "op <=" (n1, n2) = n1 <= n2
170.624 - | calc_equ op_ _ =
170.625 - raise error ("calc_equ: operator = "^op_^" not defined");
170.626 -fun sqrt (n:int) = if n < 0 then 0
170.627 - (*FIXME ~~~*) else (trunc o Math.sqrt o Real.fromInt) n;
170.628 -
170.629 -fun mk_thmid thmid op_ n1 n2 =
170.630 - thmid ^ (strip_thy n1) ^ "_" ^ (strip_thy n2);
170.631 -
170.632 -fun dest_binop_typ (Type("fun",[range,Type("fun",[arg2,arg1])])) =
170.633 - (arg1,arg2,range)
170.634 - | dest_binop_typ _ = raise error "dest_binop_typ: not binary";
170.635 -(* -----
170.636 -> val t = (term_of o the o (parse thy)) "#3^#4";
170.637 -> val hT = type_of (head_of t);
170.638 -> dest_binop_typ hT;
170.639 -val it = ("'a","nat","'a") : typ * typ * typ
170.640 - ----- *)
170.641 -
170.642 -
170.643 -(** transform binary numeralsstrings **)
170.644 -(*Makarius 100308, hacked by WN*)
170.645 -val numbers_to_string =
170.646 - let
170.647 - fun dest_num t =
170.648 - (case try HOLogic.dest_number t of
170.649 - SOME (T, i) =>
170.650 - (*if T = @{typ int} orelse T = @{typ real} then WN*)
170.651 - SOME (Free (signed_string_of_int i, T))
170.652 - (*else NONE WN*)
170.653 - | NONE => NONE);
170.654 -
170.655 - fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
170.656 - | to_str (t as (u1 $ u2)) =
170.657 - (case dest_num t of
170.658 - SOME t' => t'
170.659 - | NONE => to_str u1 $ to_str u2)
170.660 - | to_str t = perhaps dest_num t;
170.661 - in to_str end
170.662 -
170.663 -(*.make uminus uniform:
170.664 - Const ("uminus", _) $ Free ("2", "RealDef.real") --> Free ("-2", _)
170.665 -to be used immediately before evaluation of numerals;
170.666 -see Scripts/calculate.sml .*)
170.667 -(*2002 fun(*app_num_tr'2 (Const("0",T)) = Free("0",T)
170.668 - | app_num_tr'2 (Const("1",T)) = Free("1",T)
170.669 - |*)app_num_tr'2 (t as Const("uminus",_) $ Free(s,T)) =
170.670 - (case int_of_str s of SOME i =>
170.671 - if i > 0 then Free("-"^s,T) else Free(s,T)
170.672 - | NONE => t)
170.673 -(*| app_num_tr'2 (t as Const(s,T)) = t
170.674 - | app_num_tr'2 (Const("Numeral.number_of",Type ("fun", [_, T])) $ t) =
170.675 - Free(NumeralSyntax.dest_bin_str t, T)
170.676 - | app_num_tr'2 (t as Free(s,T)) = t
170.677 - | app_num_tr'2 (t as Var(n,T)) = t
170.678 - | app_num_tr'2 (t as Bound i) = t
170.679 -*)| app_num_tr'2 (Abs(s,T,body)) = Abs(s,T, app_num_tr'2 body)
170.680 - | app_num_tr'2 (t1 $ t2) = (app_num_tr'2 t1) $ (app_num_tr'2 t2)
170.681 - | app_num_tr'2 t = t;
170.682 -*)
170.683 -val uminus_to_string =
170.684 - let
170.685 - fun dest_num t =
170.686 - (case t of
170.687 - (Const ("HOL.uminus_class.uminus", _) $ Free (s, T)) =>
170.688 - (case int_of_str s of
170.689 - SOME i =>
170.690 - SOME (Free (signed_string_of_int (~1 * i), T))
170.691 - | NONE => NONE)
170.692 - | _ => NONE);
170.693 -
170.694 - fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
170.695 - | to_str (t as (u1 $ u2)) =
170.696 - (case dest_num t of
170.697 - SOME t' => t'
170.698 - | NONE => to_str u1 $ to_str u2)
170.699 - | to_str t = perhaps dest_num t;
170.700 - in to_str end;
170.701 -
170.702 -
170.703 -(*2002 fun num_str thm =
170.704 - let
170.705 - val {sign_ref = sign_ref, der = der, maxidx = maxidx,
170.706 - shyps = shyps, hyps = hyps, (*tpairs = tpairs,*) prop = prop} =
170.707 - rep_thm_G thm;
170.708 - val prop' = app_num_tr'1 prop;
170.709 - in assbl_thm sign_ref der maxidx shyps hyps (*tpairs*) prop' end;*)
170.710 -fun num_str thm =
170.711 - let val (deriv,
170.712 - {thy_ref = thy_ref, tags = tags, maxidx = maxidx, shyps = shyps,
170.713 - hyps = hyps, tpairs = tpairs, prop = prop}) = rep_thm_G thm
170.714 - val prop' = numbers_to_string prop;
170.715 - in assbl_thm deriv thy_ref tags maxidx shyps hyps tpairs prop' end;
170.716 -
170.717 -fun get_thm' xstring = (*?covers 2009 Thm?!, replaces 2002 fun get_thm :
170.718 -val it = fn : theory -> xstring -> Thm.thm*)
170.719 - Thm (xstring,
170.720 - num_str (ProofContext.get_thm (thy2ctxt' "Isac") xstring));
170.721 -
170.722 -(** get types of Free and Abs for parse' **)
170.723 -(*11.1.00: not used, fix-typed +,*,-,^ instead *)
170.724 -
170.725 -val dummyT = Type ("dummy",[]);
170.726 -val dummyT = TVar (("DUMMY",0),[]);
170.727 -
170.728 -(* assumes only 1 type for numerals
170.729 - and different identifiers for Const, Free and Abs *)
170.730 -fun get_types t =
170.731 - let
170.732 - fun get ts (Const(s,T)) = (s,T)::ts
170.733 - | get ts (Free(s,T)) = if is_no s
170.734 - then ("#",T)::ts else (s,T)::ts
170.735 - | get ts (Var(n,T)) = ts
170.736 - | get ts (Bound i) = ts
170.737 - | get ts (Abs(s,T,body)) = get ((s,T)::ts) body
170.738 - | get ts (t1 $ t2) = (get ts t1) @ (get ts t2)
170.739 - in distinct (get [] t) end;
170.740 -(*
170.741 -val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
170.742 -get_types t;
170.743 -*)
170.744 -
170.745 -(*11.1.00: not used, fix-typed +,*,-,^ instead *)
170.746 -fun set_types al (Const(s,T)) =
170.747 - (case assoc (al,s) of
170.748 - SOME T' => Const(s,T')
170.749 - | NONE => (warning ("set_types: no type for "^s); Const(s,dummyT)))
170.750 - | set_types al (Free(s,T)) =
170.751 - if is_no s then
170.752 - (case assoc (al,"#") of
170.753 - SOME T' => Free(s,T')
170.754 - | NONE => (warning ("set_types: no type for numerals"); Free(s,T)))
170.755 - else (case assoc (al,s) of
170.756 - SOME T' => Free(s,T')
170.757 - | NONE => (warning ("set_types: no type for "^s); Free(s,T)))
170.758 - | set_types al (Var(n,T)) = Var(n,T)
170.759 - | set_types al (Bound i) = Bound i
170.760 - | set_types al (Abs(s,T,body)) =
170.761 - (case assoc (al,s) of
170.762 - SOME T' => Abs(s,T', set_types al body)
170.763 - | NONE => (warning ("set_types: no type for "^s);
170.764 - Abs(s,T, set_types al body)))
170.765 - | set_types al (t1 $ t2) = (set_types al t1) $ (set_types al t2);
170.766 -(*
170.767 -val t = (term_of o the o (parse thy)) "sqrt(#9+#4*x)=sqrt x + sqrt(#-3+x)";
170.768 -val al = get_types t;
170.769 -
170.770 -val t = (term_of o the o (parse thy)) "x = #0 + #-1 * #-4";
170.771 -atomty t; (* 'a *)
170.772 -val t' = set_types al t;
170.773 -atomty t'; (*real*)
170.774 -(cterm_of thy) t';
170.775 -val it = "x = #0 + #-1 * #-4" : cterm
170.776 -
170.777 -val t = (term_of o the o (parse thy))
170.778 - "#5 * x + x ^^^ #2 = (#2 + x) ^^^ #2";
170.779 -atomty t;
170.780 -val t' = set_types al t;
170.781 -atomty t';
170.782 -(cterm_of thy) t';
170.783 -uncaught exception TYPE (*^^^ is new, NOT in al*)
170.784 -*)
170.785 -
170.786 -
170.787 -(** from Descript.ML **)
170.788 -
170.789 -(** decompose an isa-list to an ML-list
170.790 - i.e. [] belong to the meta-language, too **)
170.791 -
170.792 -fun is_list ((Const("List.list.Cons",_)) $ _ $ _) = true
170.793 - | is_list _ = false;
170.794 -(* val (SOME ct) = parse thy "lll::real list";
170.795 -> val ty = (#t o rep_cterm) ct;
170.796 -> is_list ty;
170.797 -val it = false : bool
170.798 -> val (SOME ct) = parse thy "[lll]";
170.799 -> val ty = (#t o rep_cterm) ct;
170.800 -> is_list ty;
170.801 -val it = true : bool *)
170.802 -
170.803 -
170.804 -
170.805 -fun mk_Free (s,T) = Free(s,T);
170.806 -fun mk_free T s = Free(s,T);
170.807 -
170.808 -(*instantiate let; necessary for ass_up*)
170.809 -fun inst_abs thy (Const sT) = Const sT
170.810 - | inst_abs thy (Free sT) = Free sT
170.811 - | inst_abs thy (Bound n) = Bound n
170.812 - | inst_abs thy (Var iT) = Var iT
170.813 - | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) =
170.814 - let val (v',b') = variant_abs (v,T2,b); (*fun variant_abs: term.ML*)
170.815 - in Const ("Let",T1) $ inst_abs thy e $ (Abs (v',T2,inst_abs thy b')) end
170.816 - | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2
170.817 - | inst_abs thy t =
170.818 - (writeln("inst_abs: unchanged t= "^ term2str t);
170.819 - t);
170.820 -(*val scr as (Script sc) = Script ((term_of o the o (parse thy))
170.821 - "Script Testeq (e_::bool) = \
170.822 - \While (contains_root e_) Do \
170.823 - \ (let e_ = Try (Repeat (Rewrite rroot_square_inv False e_)); \
170.824 - \ e_ = Try (Repeat (Rewrite square_equation_left True e_)) \
170.825 - \ in Try (Repeat (Rewrite radd_0 False e_))) ");
170.826 -ML> atomt sc;
170.827 -*** Const ( Script.Testeq)
170.828 -*** . Free ( e_, )
170.829 -*** . Const ( Script.While)
170.830 -*** . . Const ( RatArith.contains'_root)
170.831 -*** . . . Free ( e_, )
170.832 -*** . . Const ( Let)
170.833 -*** . . . Const ( Script.Try)
170.834 -*** . . . . Const ( Script.Repeat)
170.835 -*** . . . . . Const ( Script.Rewrite)
170.836 -*** . . . . . . Free ( rroot_square_inv, )
170.837 -*** . . . . . . Const ( False)
170.838 -*** . . . . . . Free ( e_, )
170.839 -*** . . . Abs( e_,..
170.840 -*** . . . . Const ( Let)
170.841 -*** . . . . . Const ( Script.Try)
170.842 -*** . . . . . . Const ( Script.Repeat)
170.843 -*** . . . . . . . Const ( Script.Rewrite)
170.844 -*** . . . . . . . . Free ( square_equation_left, )
170.845 -*** . . . . . . . . Const ( True)
170.846 -*** . . . . . . . . Bound 0 <-- !!!
170.847 -*** . . . . . Abs( e_,..
170.848 -*** . . . . . . Const ( Script.Try)
170.849 -*** . . . . . . . Const ( Script.Repeat)
170.850 -*** . . . . . . . . Const ( Script.Rewrite)
170.851 -*** . . . . . . . . . Free ( radd_0, )
170.852 -*** . . . . . . . . . Const ( False)
170.853 -*** . . . . . . . . . Bound 0 <-- !!!
170.854 -val it = () : unit
170.855 -ML> atomt (inst_abs thy sc);
170.856 -*** Const ( Script.Testeq)
170.857 -*** . Free ( e_, )
170.858 -*** . Const ( Script.While)
170.859 -*** . . Const ( RatArith.contains'_root)
170.860 -*** . . . Free ( e_, )
170.861 -*** . . Const ( Let)
170.862 -*** . . . Const ( Script.Try)
170.863 -*** . . . . Const ( Script.Repeat)
170.864 -*** . . . . . Const ( Script.Rewrite)
170.865 -*** . . . . . . Free ( rroot_square_inv, )
170.866 -*** . . . . . . Const ( False)
170.867 -*** . . . . . . Free ( e_, )
170.868 -*** . . . Abs( e_,..
170.869 -*** . . . . Const ( Let)
170.870 -*** . . . . . Const ( Script.Try)
170.871 -*** . . . . . . Const ( Script.Repeat)
170.872 -*** . . . . . . . Const ( Script.Rewrite)
170.873 -*** . . . . . . . . Free ( square_equation_left, )
170.874 -*** . . . . . . . . Const ( True)
170.875 -*** . . . . . . . . Free ( e_, ) <-- !!!
170.876 -*** . . . . . Abs( e_,..
170.877 -*** . . . . . . Const ( Script.Try)
170.878 -*** . . . . . . . Const ( Script.Repeat)
170.879 -*** . . . . . . . . Const ( Script.Rewrite)
170.880 -*** . . . . . . . . . Free ( radd_0, )
170.881 -*** . . . . . . . . . Const ( False)
170.882 -*** . . . . . . . . . Free ( e_, ) <-- ZUFALL vor 5.03!!!
170.883 -val it = () : unit*)
170.884 -
170.885 -
170.886 -
170.887 -
170.888 -fun inst_abs thy (Const sT) = Const sT
170.889 - | inst_abs thy (Free sT) = Free sT
170.890 - | inst_abs thy (Bound n) = Bound n
170.891 - | inst_abs thy (Var iT) = Var iT
170.892 - | inst_abs thy (Const ("Let",T1) $ e $ (Abs (v,T2,b))) =
170.893 - let val b' = subst_bound (Free(v,T2),b);
170.894 - (*fun variant_abs: term.ML*)
170.895 - in Const ("Let",T1) $ inst_abs thy e $ (Abs (v,T2,inst_abs thy b')) end
170.896 - | inst_abs thy (t1 $ t2) = inst_abs thy t1 $ inst_abs thy t2
170.897 - | inst_abs thy t =
170.898 - (writeln("inst_abs: unchanged t= "^ term2str t);
170.899 - t);
170.900 -(*val scr =
170.901 - "Script Make_fun_by_explicit (f_::real) (v_::real) (eqs_::bool list) = \
170.902 - \ (let h_ = (hd o (filterVar f_)) eqs_; \
170.903 - \ e_1 = hd (dropWhile (ident h_) eqs_); \
170.904 - \ vs_ = dropWhile (ident f_) (Vars h_); \
170.905 - \ v_1 = hd (dropWhile (ident v_) vs_); \
170.906 - \ (s_1::bool list)=(SubProblem(DiffApp_,[univar,equation],[no_met])\
170.907 - \ [bool_ e_1, real_ v_1])\
170.908 - \ in Substitute [(v_1 = (rhs o hd) s_1)] h_)";
170.909 -> val ttt = (term_of o the o (parse thy)) scr;
170.910 -> writeln(term2str ttt);
170.911 -> atomt ttt;
170.912 -*** -------------
170.913 -*** Const ( DiffApp.Make'_fun'_by'_explicit)
170.914 -*** . Free ( f_, )
170.915 -*** . Free ( v_, )
170.916 -*** . Free ( eqs_, )
170.917 -*** . Const ( Let)
170.918 -*** . . Const ( Fun.op o)
170.919 -*** . . . Const ( List.hd)
170.920 -*** . . . Const ( DiffApp.filterVar)
170.921 -*** . . . . Free ( f_, )
170.922 -*** . . . Free ( eqs_, )
170.923 -*** . . Abs( h_,..
170.924 -*** . . . Const ( Let)
170.925 -*** . . . . Const ( List.hd)
170.926 -*** . . . . . Const ( List.dropWhile)
170.927 -*** . . . . . . Const ( Atools.ident)
170.928 -*** . . . . . . . Bound 0 <---- Free ( h_, )
170.929 -*** . . . . . . Free ( eqs_, )
170.930 -*** . . . . Abs( e_1,..
170.931 -*** . . . . . Const ( Let)
170.932 -*** . . . . . . Const ( List.dropWhile)
170.933 -*** . . . . . . . Const ( Atools.ident)
170.934 -*** . . . . . . . . Free ( f_, )
170.935 -*** . . . . . . . Const ( Tools.Vars)
170.936 -*** . . . . . . . . Bound 1 <---- Free ( h_, )
170.937 -*** . . . . . . Abs( vs_,..
170.938 -*** . . . . . . . Const ( Let)
170.939 -*** . . . . . . . . Const ( List.hd)
170.940 -*** . . . . . . . . . Const ( List.dropWhile)
170.941 -*** . . . . . . . . . . Const ( Atools.ident)
170.942 -*** . . . . . . . . . . . Free ( v_, )
170.943 -*** . . . . . . . . . . Bound 0 <---- Free ( vs_, )
170.944 -*** . . . . . . . . Abs( v_1,..
170.945 -*** . . . . . . . . . Const ( Let)
170.946 -*** . . . . . . . . . . Const ( Script.SubProblem)
170.947 -*** . . . . . . . . . . . Const ( Pair)
170.948 -*** . . . . . . . . . . . . Free ( DiffApp_, )
170.949 -*** . . . . . . . . . . . . Const ( Pair)
170.950 -*** . . . . . . . . . . . . . Const ( List.list.Cons)
170.951 -*** . . . . . . . . . . . . . . Free ( univar, )
170.952 -*** . . . . . . . . . . . . . . Const ( List.list.Cons)
170.953 -*** . . . . . . . . . . . . . . . Free ( equation, )
170.954 -*** . . . . . . . . . . . . . . . Const ( List.list.Nil)
170.955 -*** . . . . . . . . . . . . . Const ( List.list.Cons)
170.956 -*** . . . . . . . . . . . . . . Free ( no_met, )
170.957 -*** . . . . . . . . . . . . . . Const ( List.list.Nil)
170.958 -*** . . . . . . . . . . . Const ( List.list.Cons)
170.959 -*** . . . . . . . . . . . . Const ( Script.bool_)
170.960 -*** . . . . . . . . . . . . . Bound 2 <----- Free ( e_1, )
170.961 -*** . . . . . . . . . . . . Const ( List.list.Cons)
170.962 -*** . . . . . . . . . . . . . Const ( Script.real_)
170.963 -*** . . . . . . . . . . . . . . Bound 0 <----- Free ( v_1, )
170.964 -*** . . . . . . . . . . . . . Const ( List.list.Nil)
170.965 -*** . . . . . . . . . . Abs( s_1,..
170.966 -*** . . . . . . . . . . . Const ( Script.Substitute)
170.967 -*** . . . . . . . . . . . . Const ( List.list.Cons)
170.968 -*** . . . . . . . . . . . . . Const ( Pair)
170.969 -*** . . . . . . . . . . . . . . Bound 1 <----- Free ( v_1, )
170.970 -*** . . . . . . . . . . . . . . Const ( Fun.op o)
170.971 -*** . . . . . . . . . . . . . . . Const ( Tools.rhs)
170.972 -*** . . . . . . . . . . . . . . . Const ( List.hd)
170.973 -*** . . . . . . . . . . . . . . . Bound 0 <----- Free ( s_1, )
170.974 -*** . . . . . . . . . . . . . Const ( List.list.Nil)
170.975 -*** . . . . . . . . . . . . Bound 4 <----- Free ( h_, )
170.976 -
170.977 -> val ttt' = inst_abs thy ttt;
170.978 -> writeln(term2str ttt');
170.979 -Script Make_fun_by_explicit f_ v_ eqs_ =
170.980 - ... as above ...
170.981 -> atomt ttt';
170.982 -*** -------------
170.983 -*** Const ( DiffApp.Make'_fun'_by'_explicit)
170.984 -*** . Free ( f_, )
170.985 -*** . Free ( v_, )
170.986 -*** . Free ( eqs_, )
170.987 -*** . Const ( Let)
170.988 -*** . . Const ( Fun.op o)
170.989 -*** . . . Const ( List.hd)
170.990 -*** . . . Const ( DiffApp.filterVar)
170.991 -*** . . . . Free ( f_, )
170.992 -*** . . . Free ( eqs_, )
170.993 -*** . . Abs( h_,..
170.994 -*** . . . Const ( Let)
170.995 -*** . . . . Const ( List.hd)
170.996 -*** . . . . . Const ( List.dropWhile)
170.997 -*** . . . . . . Const ( Atools.ident)
170.998 -*** . . . . . . . Free ( h_, ) <---- Bound 0
170.999 -*** . . . . . . Free ( eqs_, )
170.1000 -*** . . . . Abs( e_1,..
170.1001 -*** . . . . . Const ( Let)
170.1002 -*** . . . . . . Const ( List.dropWhile)
170.1003 -*** . . . . . . . Const ( Atools.ident)
170.1004 -*** . . . . . . . . Free ( f_, )
170.1005 -*** . . . . . . . Const ( Tools.Vars)
170.1006 -*** . . . . . . . . Free ( h_, ) <---- Bound 1
170.1007 -*** . . . . . . Abs( vs_,..
170.1008 -*** . . . . . . . Const ( Let)
170.1009 -*** . . . . . . . . Const ( List.hd)
170.1010 -*** . . . . . . . . . Const ( List.dropWhile)
170.1011 -*** . . . . . . . . . . Const ( Atools.ident)
170.1012 -*** . . . . . . . . . . . Free ( v_, )
170.1013 -*** . . . . . . . . . . Free ( vs_, ) <---- Bound 0
170.1014 -*** . . . . . . . . Abs( v_1,..
170.1015 -*** . . . . . . . . . Const ( Let)
170.1016 -*** . . . . . . . . . . Const ( Script.SubProblem)
170.1017 -*** . . . . . . . . . . . Const ( Pair)
170.1018 -*** . . . . . . . . . . . . Free ( DiffApp_, )
170.1019 -*** . . . . . . . . . . . . Const ( Pair)
170.1020 -*** . . . . . . . . . . . . . Const ( List.list.Cons)
170.1021 -*** . . . . . . . . . . . . . . Free ( univar, )
170.1022 -*** . . . . . . . . . . . . . . Const ( List.list.Cons)
170.1023 -*** . . . . . . . . . . . . . . . Free ( equation, )
170.1024 -*** . . . . . . . . . . . . . . . Const ( List.list.Nil)
170.1025 -*** . . . . . . . . . . . . . Const ( List.list.Cons)
170.1026 -*** . . . . . . . . . . . . . . Free ( no_met, )
170.1027 -*** . . . . . . . . . . . . . . Const ( List.list.Nil)
170.1028 -*** . . . . . . . . . . . Const ( List.list.Cons)
170.1029 -*** . . . . . . . . . . . . Const ( Script.bool_)
170.1030 -*** . . . . . . . . . . . . . Free ( e_1, ) <----- Bound 2
170.1031 -*** . . . . . . . . . . . . Const ( List.list.Cons)
170.1032 -*** . . . . . . . . . . . . . Const ( Script.real_)
170.1033 -*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 0
170.1034 -*** . . . . . . . . . . . . . Const ( List.list.Nil)
170.1035 -*** . . . . . . . . . . Abs( s_1,..
170.1036 -*** . . . . . . . . . . . Const ( Script.Substitute)
170.1037 -*** . . . . . . . . . . . . Const ( List.list.Cons)
170.1038 -*** . . . . . . . . . . . . . Const ( Pair)
170.1039 -*** . . . . . . . . . . . . . . Free ( v_1, ) <----- Bound 1
170.1040 -*** . . . . . . . . . . . . . . Const ( Fun.op o)
170.1041 -*** . . . . . . . . . . . . . . . Const ( Tools.rhs)
170.1042 -*** . . . . . . . . . . . . . . . Const ( List.hd)
170.1043 -*** . . . . . . . . . . . . . . . Free ( s_1, ) <----- Bound 0
170.1044 -*** . . . . . . . . . . . . . Const ( List.list.Nil)
170.1045 -*** . . . . . . . . . . . . Free ( h_, ) <----- Bound 4
170.1046 -
170.1047 -Note numbering of de Bruijn indexes !
170.1048 -
170.1049 -Script Make_fun_by_explicit f_ v_ eqs_ =
170.1050 - let h_ = (hd o filterVar f_) eqs_;
170.1051 - e_1 = hd (dropWhile (ident h_ BOUND_0) eqs_);
170.1052 - vs_ = dropWhile (ident f_) (Vars h_ BOUND_1);
170.1053 - v_1 = hd (dropWhile (ident v_) vs_ BOUND_0);
170.1054 - s_1 =
170.1055 - SubProblem (DiffApp_, [univar, equation], [no_met])
170.1056 - [bool_ e_1 BOUND_2, real_ v_1 BOUND_0]
170.1057 - in Substitute [(v_1 BOUND_1 = (rhs o hd) s_1 BOUND_0)] h_ BOUND_4
170.1058 -*)
170.1059 -
170.1060 -
170.1061 -fun T_a2real (Type (s, [])) =
170.1062 - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else Type (s, [])
170.1063 - | T_a2real (Type (s, Ts)) = Type (s, map T_a2real Ts)
170.1064 - | T_a2real (TFree (s, srt)) =
170.1065 - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TFree (s, srt)
170.1066 - | T_a2real (TVar (("DUMMY",_),srt)) = HOLogic.realT;
170.1067 -
170.1068 -(*FIXME .. fixes the type (+see Typefix.thy*)
170.1069 -fun typ_a2real (Const( s, T)) = (Const( s, T_a2real T))
170.1070 - | typ_a2real (Free( s, T)) = (Free( s, T_a2real T))
170.1071 - | typ_a2real (Var( n, T)) = (Var( n, T_a2real T))
170.1072 - | typ_a2real (Bound i) = (Bound i)
170.1073 - | typ_a2real (Abs(s,T,t)) = Abs(s, T, typ_a2real t)
170.1074 - | typ_a2real (t1 $ t2) = (typ_a2real t1) $ (typ_a2real t2);
170.1075 -(*
170.1076 -----------------6.8.02---------------------------------------------------
170.1077 - val str = "1";
170.1078 - val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[])));
170.1079 - atomty (term_of t);
170.1080 -*** -------------
170.1081 -*** Const ( 1, 'a)
170.1082 - val t = (app_num_tr' o term_of) t;
170.1083 - atomty t;
170.1084 -*** -------------
170.1085 -*** Const ( 1, 'a)
170.1086 - val t = typ_a2real t;
170.1087 - atomty t;
170.1088 -*** -------------
170.1089 -*** Const ( 1, real)
170.1090 -
170.1091 - val str = "2";
170.1092 - val t = read_cterm (sign_of thy) (str,(TVar(("DUMMY",0),[])));
170.1093 - atomty (term_of t);
170.1094 -*** -------------
170.1095 -*** Const ( Numeral.number_of, bin => 'a)
170.1096 -*** . Const ( Numeral.bin.Bit, [bin, bool] => bin)
170.1097 -*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin)
170.1098 -*** . . . Const ( Numeral.bin.Pls, bin)
170.1099 -*** . . . Const ( True, bool)
170.1100 -*** . . Const ( False, bool)
170.1101 - val t = (app_num_tr' o term_of) t;
170.1102 - atomty t;
170.1103 -*** -------------
170.1104 -*** Free ( 2, 'a)
170.1105 - val t = typ_a2real t;
170.1106 - atomty t;
170.1107 -*** -------------
170.1108 -*** Free ( 2, real)
170.1109 -----------------6.8.02---------------------------------------------------
170.1110 -
170.1111 -
170.1112 -> val str = "R";
170.1113 -> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[]))));
170.1114 -val t = Free ("R","?DUMMY") : term
170.1115 -> val t' = typ_a2real t;
170.1116 -> (cterm_of thy) t';
170.1117 -val it = "R::RealDef.real" : cterm
170.1118 -
170.1119 -> val str = "R=R";
170.1120 -> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[]))));
170.1121 -> atomty (typ_a2real t);
170.1122 -*** -------------
170.1123 -*** Const ( op =, [RealDef.real, RealDef.real] => bool)
170.1124 -*** Free ( R, RealDef.real)
170.1125 -*** Free ( R, RealDef.real)
170.1126 -> val t' = typ_a2real t;
170.1127 -> (cterm_of thy) t';
170.1128 -val it = "(R::RealDef.real) = R" : cterm
170.1129 -
170.1130 -> val str = "fixed_values [R=R]";
170.1131 -> val t = term_of (read_cterm(sign_of thy)(str,(TVar(("DUMMY",0),[]))));
170.1132 -> val t' = typ_a2real t;
170.1133 -> (cterm_of thy) t';
170.1134 -val it = "fixed_values [(R::RealDef.real) = R]" : cterm
170.1135 -*)
170.1136 -
170.1137 -(*TODO.WN0609: parse should return a term or a string
170.1138 - (or even more comprehensive datastructure for error-messages)
170.1139 - i.e. in wrapping with SOME term or NONE the latter is not sufficient*)
170.1140 -(*2002 fun parseold thy str =
170.1141 - (let
170.1142 - val sgn = sign_of thy;
170.1143 - val t = ((*typ_a2real o*) app_num_tr'1 o term_of)
170.1144 - (read_cterm sgn (str,(TVar(("DUMMY",0),[]))));
170.1145 - in SOME (cterm_of sgn t) end)
170.1146 - handle _ => NONE;*)
170.1147 -
170.1148 -
170.1149 -
170.1150 -fun parseold thy str =
170.1151 - (let val t = ((*typ_a2real o*) numbers_to_string)
170.1152 - (Syntax.read_term_global thy str)
170.1153 - in SOME (cterm_of thy t) end)
170.1154 - handle _ => NONE;
170.1155 -(*2002 fun parseN thy str =
170.1156 - (let
170.1157 - val sgn = sign_of thy;
170.1158 - val t = ((*typ_a2real o app_num_tr'1 o*) term_of)
170.1159 - (read_cterm sgn (str,(TVar(("DUMMY",0),[]))));
170.1160 - in SOME (cterm_of sgn t) end)
170.1161 - handle _ => NONE;*)
170.1162 -fun parseN thy str =
170.1163 - (let val t = (*(typ_a2real o numbers_to_string)*)
170.1164 - (Syntax.read_term_global thy str)
170.1165 - in SOME (cterm_of thy t) end)
170.1166 - handle _ => NONE;
170.1167 -(*2002 fun parse thy str =
170.1168 - (let
170.1169 - val sgn = sign_of thy;
170.1170 - val t = (typ_a2real o app_num_tr'1 o term_of)
170.1171 - (read_cterm sgn (str,(TVar(("DUMMY",0),[]))));
170.1172 - in SOME (cterm_of sgn t) end) (*FIXXXXME 10.8.02: return term !!!*)
170.1173 - handle _ => NONE;*)
170.1174 -(*2010 fun parse thy str =
170.1175 - (let val t = (typ_a2real o app_num_tr'1) (Syntax.read_term_global thy str)
170.1176 - in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*)
170.1177 - handle _ => NONE;*)
170.1178 -fun parse thy str =
170.1179 - (let val t = (typ_a2real o numbers_to_string)
170.1180 - (Syntax.read_term_global thy str)
170.1181 - in SOME (cterm_of thy t) end) (*FIXXXXME 10.8.02: return term !!!*)
170.1182 - handle _ => NONE;
170.1183 -
170.1184 -(* 10.8.02: for this reason we still have ^^^--------------------
170.1185 - val thy = SqRoot.thy;
170.1186 - val str = "(1::real) ^ (2::nat)";
170.1187 - val sgn = sign_of thy;
170.1188 - val ct = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e =>print_exn e;
170.1189 -(*1*)"(1::real) ^ 2";
170.1190 - atomty (term_of ct);
170.1191 -*** -------------
170.1192 -*** Const ( Nat.power, [real, nat] => real)
170.1193 -*** . Const ( 1, real)
170.1194 -*** . Const ( Numeral.number_of, bin => nat)
170.1195 -*** . . Const ( Numeral.bin.Bit, [bin, bool] => bin)
170.1196 -*** . . . Const ( Numeral.bin.Bit, [bin, bool] => bin)
170.1197 -*** . . . . Const ( Numeral.bin.Pls, bin)
170.1198 -*** . . . . Const ( True, bool)
170.1199 -*** . . . Const ( False, bool)
170.1200 - val t = ((app_num_tr' o term_of)
170.1201 - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e;
170.1202 - val ct = (cterm_of sgn t) handle e => print_exn e;
170.1203 -(*2*)"(1::real) ^ (2::nat)";
170.1204 - atomty (term_of ct);
170.1205 -*** -------------
170.1206 -*** Const ( Nat.power, [real, nat] => real)
170.1207 -*** . Free ( 1, real)
170.1208 -*** . Free ( 2, nat) (*1*) Const("2",_) (*2*) Free("2",_)
170.1209 -
170.1210 -
170.1211 - val str = "(2::real) ^ (2::nat)";
170.1212 - val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e;
170.1213 -val t = "(2::real) ^ 2" : cterm
170.1214 - val t = ((app_num_tr' o term_of)
170.1215 - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e;
170.1216 - val ct = (cterm_of sgn t) handle e => print_exn e;
170.1217 -Variable "2" has two distinct types
170.1218 -real
170.1219 -nat
170.1220 -uncaught exception TYPE
170.1221 - raised at: sign.ML:672.26-673.56
170.1222 - goals.ML:1100.61
170.1223 -
170.1224 -
170.1225 - val str = "(3::real) ^ (2::nat)";
170.1226 - val t = (read_cterm sgn (str,(TVar(("DUMMY",0),[])))) handle e => print_exn e;
170.1227 -val t = "(3::real) ^ 2" : cterm
170.1228 - val t = ((app_num_tr' o term_of)
170.1229 - (read_cterm sgn (str,(TVar(("DUMMY",0),[])))))handle e => print_exn e;
170.1230 - val ct = (cterm_of sgn t) handle e => print_exn e;
170.1231 -val ct = "(3::real) ^ (2::nat)" : cterm
170.1232 -
170.1233 -
170.1234 -Conclusion: The type inference allows different types
170.1235 - for one and the same Numeral.number_of
170.1236 - BUT the type inference doesn't allow
170.1237 - Free ( 2, real) and Free ( 2, nat) within one term
170.1238 ---------------- ~~~~ ~~~ *)
170.1239 -(*
170.1240 -> val (SOME ct) = parse thy "(-#5)^^^#3";
170.1241 -> atomty (term_of ct);
170.1242 -*** -------------
170.1243 -*** Const ( Nat.op ^, ['a, nat] => 'a)
170.1244 -*** Const ( uminus, 'a => 'a)
170.1245 -*** Free ( #5, 'a)
170.1246 -*** Free ( #3, nat)
170.1247 -> val (SOME ct) = parse thy "R=R";
170.1248 -> atomty (term_of ct);
170.1249 -*** -------------
170.1250 -*** Const ( op =, [real, real] => bool)
170.1251 -*** Free ( R, real)
170.1252 -*** Free ( R, real)
170.1253 -
170.1254 -THIS IS THE OUTPUT FOR VERSION (3) above at typ_a2real !!!!!
170.1255 -*** -------------
170.1256 -*** Const ( op =, [RealDef.real, RealDef.real] => bool)
170.1257 -*** Free ( R, RealDef.real)
170.1258 -*** Free ( R, RealDef.real) *)
170.1259 -
170.1260 -(*version for testing local to theories*)
170.1261 -fun str2term_ thy str = (term_of o the o (parse thy)) str;
170.1262 -fun str2term str = (term_of o the o (parse (theory "Isac"))) str;
170.1263 -fun strs2terms ss = map str2term ss;
170.1264 -fun str2termN str = (term_of o the o (parseN (theory "Isac"))) str;
170.1265 -
170.1266 -(*+ makes a substitution from the output of Pattern.match +*)
170.1267 -(*fun mk_subs ((id, _):indexname, t:term) = (Free (id,type_of t), t);*)
170.1268 -fun mk_subs (subs: ((string * int) * (Term.typ * Term.term)) list) =
170.1269 -let fun mk_sub ((id, _), (ty, tm)) = (Free (id, ty), tm) in
170.1270 -map mk_sub subs end;
170.1271 -
170.1272 -val atomthm = atomt o #prop o rep_thm;
170.1273 -
170.1274 -(*.instantiate #prop thm with bound variables (as Free).*)
170.1275 -fun inst_bdv [] t = t : term
170.1276 - | inst_bdv (instl: (term*term) list) t =
170.1277 - let fun subst (v as Var((s,_),T)) =
170.1278 - (case explode s of
170.1279 - "b"::"d"::"v"::_ =>
170.1280 - if_none (assoc(instl,Free(s,T))) (Free(s,T))
170.1281 - | _ => v)
170.1282 - | subst (Abs(a,T,body)) = Abs(a, T, subst body)
170.1283 - | subst (f$t') = subst f $ subst t'
170.1284 - | subst t = if_none (assoc(instl,t)) t
170.1285 - in subst t end;
170.1286 -
170.1287 -
170.1288 -(*WN050829 caution: is_atom (str2term"q_0/2 * L * x") = true !!!
170.1289 - use length (vars term) = 1 instead*)
170.1290 -fun is_atom (Const ("Float.Float",_) $ _) = true
170.1291 - | is_atom (Const ("ComplexI.I'_'_",_)) = true
170.1292 - | is_atom (Const ("op *",_) $ t $ Const ("ComplexI.I'_'_",_)) = is_atom t
170.1293 - | is_atom (Const ("op +",_) $ t1 $ Const ("ComplexI.I'_'_",_)) = is_atom t1
170.1294 - | is_atom (Const ("op +",_) $ t1 $
170.1295 - (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_))) =
170.1296 - is_atom t1 andalso is_atom t2
170.1297 - | is_atom (Const _) = true
170.1298 - | is_atom (Free _) = true
170.1299 - | is_atom (Var _) = true
170.1300 - | is_atom _ = false;
170.1301 -(* val t = str2term "q_0/2 * L * x";
170.1302 -
170.1303 -
170.1304 -*)
170.1305 -(*val t = str2term "Float ((1,2),(0,0))";
170.1306 -> is_atom t;
170.1307 -val it = true : bool
170.1308 -> val t = str2term "Float ((1,2),(0,0)) * I__";
170.1309 -> is_atom t;
170.1310 -val it = true : bool
170.1311 -> val t = str2term "Float ((1,2),(0,0)) + Float ((3,4),(0,0)) * I__";
170.1312 -> is_atom t;
170.1313 -val it = true : bool
170.1314 -> val t = str2term "1 + 2*I__";
170.1315 -> val Const ("op +",_) $ t1 $ (Const ("op *",_) $ t2 $ Const ("ComplexI.I'_'_",_)) = t;
170.1316 -*)
170.1317 -
170.1318 -(*.adaption from Isabelle/src/Pure/term.ML; reports if ALL Free's
170.1319 - have found a substitution (required for evaluating the preconditions
170.1320 - of _incomplete_ models).*)
170.1321 -fun subst_atomic_all [] t = (false, (*TODO may be 'true' for some terms ?*)
170.1322 - t : term)
170.1323 - | subst_atomic_all (instl: (term*term) list) t =
170.1324 - let fun subst (Abs(a,T,body)) =
170.1325 - let val (all, body') = subst body
170.1326 - in (all, Abs(a, T, body')) end
170.1327 - | subst (f$tt) =
170.1328 - let val (all1, f') = subst f
170.1329 - val (all2, tt') = subst tt
170.1330 - in (all1 andalso all2, f' $ tt') end
170.1331 - | subst (t as Free _) =
170.1332 - if is_num t then (true, t) (*numerals cannot be subst*)
170.1333 - else (case assoc(instl,t) of
170.1334 - SOME t' => (true, t')
170.1335 - | NONE => (false, t))
170.1336 - | subst t = (true, if_none (assoc(instl,t)) t)
170.1337 - in subst t end;
170.1338 -
170.1339 -(*.add two terms with a type given.*)
170.1340 -fun mk_add t1 t2 =
170.1341 - let val T1 = type_of t1
170.1342 - val T2 = type_of t2
170.1343 - in if T1 <> T2 then raise TYPE ("mk_add gets ",[T1, T2],[t1,t2])
170.1344 - else (Const ("op +", [T1, T2] ---> T1) $ t1 $ t2)
170.1345 - end;
170.1346 -
171.1 --- a/src/Tools/isac/Test.thy Wed Aug 25 15:15:01 2010 +0200
171.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
171.3 @@ -1,7 +0,0 @@
171.4 -theory Test imports Main begin;
171.5 - theorem my_thm: " A & B --> B & A";
171.6 - proof;
171.7 - assume " A & B";
171.8 - then obtain B and A ..;
171.9 - then show "B & A" ..;
171.10 - qed;
172.1 --- a/src/Tools/isac/calcelems.sml Wed Aug 25 15:15:01 2010 +0200
172.2 +++ b/src/Tools/isac/calcelems.sml Wed Aug 25 16:20:07 2010 +0200
172.3 @@ -342,7 +342,7 @@
172.4
172.5 (*rewrite orders, also stored in 'type met' and type 'and rls'
172.6 The association list is required for 'rewrite.."rew_ord"..'
172.7 - WN0509 tests not well-organized: see smltest/IsacKnowledge/termorder.sml*)
172.8 + WN0509 tests not well-organized: see smltest/Knowledge/termorder.sml*)
172.9 val rew_ord' =
172.10 ref ([]:(rew_ord' * (*the key for the association list *)
172.11 (subst (*the bound variables - they get high order*)
173.1 --- a/src/Tools/isac/xmlsrc/mathml.sml Wed Aug 25 15:15:01 2010 +0200
173.2 +++ b/src/Tools/isac/xmlsrc/mathml.sml Wed Aug 25 16:20:07 2010 +0200
173.3 @@ -13,10 +13,10 @@
173.4 'isac.util.parser.FormalizationDigest.decodeEntities'
173.5 called within Formula#toSMLString in java
173.6
173.7 - ad(1) decode "^^^" ---> "^"; see IsacKnowledge/Atools.thy;
173.8 + ad(1) decode "^^^" ---> "^"; see Knowledge/Atools.thy;
173.9 ad(2) decode "<" ---> "<", decode ">" ---> ">"
173.10 decode "&" ---> "&"
173.11 - called for term2xml; + see "fun encode" in FE-interface/interface.sml.*)
173.12 + called for term2xml; + see "fun encode" in Frontend/interface.sml.*)
173.13 fun decode (str:cterm') =
173.14 let fun dec [] = []
173.15 | dec ("^"::"^"::"^"::cs) = "^"::(dec cs)
173.16 @@ -35,7 +35,7 @@
173.17 val indentation = 2;
173.18 val i = indentation;
173.19
173.20 -(*WN071016 checked that _all_ FE-interface/interface.sml uses this*)
173.21 +(*WN071016 checked that _all_ Frontend/interface.sml uses this*)
173.22 fun term2xml j t =
173.23 indt (j+i) ^ "<MATHML>\n" ^
173.24 indt (j+2*i) ^ "<ISA> " ^ (decode o term2str) t ^ " </ISA>\n" ^